{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module PlutusCore.Builtin.KnownTypeAst
( TyNameRep (..)
, TyVarRep
, TyAppRep
, TyForallRep
, Hole
, RepHole
, HasTermLevel
, HasTypeLevel
, HasTypeAndTermLevel
, mkTyBuiltin
, TypeHole
, KnownBuiltinTypeAst
, KnownTypeAst (..)
, toTypeAst
, Insert
, Delete
) where
import PlutusCore.Builtin.KnownKind
import PlutusCore.Builtin.Polymorphism
import PlutusCore.Builtin.Result
import PlutusCore.Core
import PlutusCore.Evaluation.Result
import PlutusCore.Name.Unique
import PlutusCore.Subst (typeMapNames)
import Data.Kind qualified as GHC (Constraint, Type)
import Data.Proxy
import Data.Some.GADT qualified as GADT
import Data.Text qualified as Text
import Data.Type.Bool
import Data.Void
import GHC.TypeLits
import Universe
data Hole
type RepHole :: forall a hole. a -> hole
data family RepHole x
type TypeHole :: forall hole. GHC.Type -> hole
data family TypeHole a
type HasTypeLevel :: forall a. (GHC.Type -> GHC.Type) -> a -> GHC.Constraint
type HasTypeLevel uni x = KnownTypeAst Void uni (ElaborateBuiltin uni x)
type HasTypeAndTermLevel :: forall a. (GHC.Type -> GHC.Type) -> a -> GHC.Constraint
type HasTypeAndTermLevel uni x = (uni `HasTypeLevel` x, uni `HasTermLevel` x)
mkTyBuiltin :: forall a (x :: a) uni ann tyname. uni `HasTypeLevel` x => ann -> Type tyname uni ann
mkTyBuiltin :: forall a (x :: a) (uni :: * -> *) ann tyname.
HasTypeLevel uni x =>
ann -> Type tyname uni ann
mkTyBuiltin ann
ann = ann
ann ann -> Type tyname uni () -> Type tyname uni ann
forall a b. a -> Type tyname uni b -> Type tyname uni a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Void -> tyname) -> Type Void uni () -> Type tyname uni ()
forall tyname tyname' (uni :: * -> *) ann.
(tyname -> tyname') -> Type tyname uni ann -> Type tyname' uni ann
typeMapNames Void -> tyname
forall a. Void -> a
absurd (Proxy (ElaborateBuiltin uni x) -> Type Void uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy (ElaborateBuiltin uni x) -> Type Void uni ())
-> Proxy (ElaborateBuiltin uni x) -> Type Void uni ()
forall a b. (a -> b) -> a -> b
$ forall (t :: a). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ElaborateBuiltin uni x))
{-# INLINE mkTyBuiltin #-}
type KnownBuiltinTypeAst :: forall a. GHC.Type -> (GHC.Type -> GHC.Type) -> a -> GHC.Constraint
type KnownBuiltinTypeAst tyname uni x = AllBuiltinArgs uni (KnownTypeAst tyname uni) x
type KnownTypeAst :: forall a. GHC.Type -> (GHC.Type -> GHC.Type) -> a -> GHC.Constraint
class KnownTypeAst tyname uni x where
type IsBuiltin uni x :: Bool
type IsBuiltin uni x = IsBuiltin uni (ElaborateBuiltin uni x)
type ToHoles uni x :: [Hole]
type ToHoles uni x = ToHoles uni (ElaborateBuiltin uni x)
type ToBinds uni (acc :: [GADT.Some TyNameRep]) x :: [GADT.Some TyNameRep]
type ToBinds uni acc x = ToBinds uni acc (ElaborateBuiltin uni x)
typeAst :: Type tyname uni ()
default typeAst :: KnownTypeAst tyname uni (ElaborateBuiltin uni x) => Type tyname uni ()
typeAst = Proxy (ElaborateBuiltin uni x) -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy (ElaborateBuiltin uni x) -> Type tyname uni ())
-> Proxy (ElaborateBuiltin uni x) -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall (t :: a). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ElaborateBuiltin uni x)
{-# INLINE typeAst #-}
instance KnownTypeAst tyname uni a => KnownTypeAst tyname uni (EvaluationResult a) where
type IsBuiltin _ (EvaluationResult a) = 'False
type ToHoles _ (EvaluationResult a) = '[TypeHole a]
type ToBinds uni acc (EvaluationResult a) = ToBinds uni acc a
typeAst :: Type tyname uni ()
typeAst = Proxy a -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy a -> Type tyname uni ()) -> Proxy a -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
{-# INLINE typeAst #-}
instance KnownTypeAst tyname uni a => KnownTypeAst tyname uni (BuiltinResult a) where
type IsBuiltin _ (BuiltinResult a) = 'False
type ToHoles _ (BuiltinResult a) = '[TypeHole a]
type ToBinds uni acc (BuiltinResult a) = ToBinds uni acc a
typeAst :: Type tyname uni ()
typeAst = Proxy a -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy a -> Type tyname uni ()) -> Proxy a -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
{-# INLINE typeAst #-}
instance KnownTypeAst tyname uni rep => KnownTypeAst tyname uni (SomeConstant uni rep) where
type IsBuiltin _ (SomeConstant uni rep) = 'False
type ToHoles _ (SomeConstant _ rep) = '[RepHole rep]
type ToBinds uni acc (SomeConstant _ rep) = ToBinds uni acc rep
typeAst :: Type tyname uni ()
typeAst = Proxy rep -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy rep -> Type tyname uni ())
-> Proxy rep -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @rep
{-# INLINE typeAst #-}
instance KnownTypeAst tyname uni rep => KnownTypeAst tyname uni (Opaque val rep) where
type IsBuiltin _ (Opaque val rep) = 'False
type ToHoles _ (Opaque _ rep) = '[RepHole rep]
type ToBinds uni acc (Opaque _ rep) = ToBinds uni acc rep
typeAst :: Type tyname uni ()
typeAst = Proxy rep -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy rep -> Type tyname uni ())
-> Proxy rep -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @rep
{-# INLINE typeAst #-}
toTypeAst
:: forall a tyname uni (x :: a) proxy. KnownTypeAst tyname uni x
=> proxy x -> Type tyname uni ()
toTypeAst :: forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst proxy x
_ = forall a tyname (uni :: * -> *) (x :: a).
KnownTypeAst tyname uni x =>
Type tyname uni ()
typeAst @_ @tyname @uni @x
{-# INLINE toTypeAst #-}
toTyNameAst
:: forall text uniq. (KnownSymbol text, KnownNat uniq)
=> Proxy ('TyNameRep text uniq) -> TyName
toTyNameAst :: forall {kind} (text :: Symbol) (uniq :: Nat).
(KnownSymbol text, KnownNat uniq) =>
Proxy ('TyNameRep text uniq) -> TyName
toTyNameAst Proxy ('TyNameRep text uniq)
_ =
Name -> TyName
TyName (Name -> TyName) -> Name -> TyName
forall a b. (a -> b) -> a -> b
$ Text -> Unique -> Name
Name
(String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @text Proxy text
forall {k} (t :: k). Proxy t
Proxy)
(Int -> Unique
Unique (Int -> Unique) -> (Integer -> Int) -> Integer -> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Unique) -> Integer -> Unique
forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal @uniq Proxy uniq
forall {k} (t :: k). Proxy t
Proxy)
{-# INLINE toTyNameAst #-}
instance uni `Contains` f => KnownTypeAst tyname uni (BuiltinHead f) where
type IsBuiltin _ (BuiltinHead f) = 'True
type ToHoles _ (BuiltinHead f) = '[]
type ToBinds _ acc (BuiltinHead f) = acc
typeAst :: Type tyname uni ()
typeAst = () -> SomeTypeIn uni -> Type tyname uni ()
forall tyname (uni :: * -> *) ann.
ann -> SomeTypeIn uni -> Type tyname uni ann
TyBuiltin () (SomeTypeIn uni -> Type tyname uni ())
-> SomeTypeIn uni -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall k (a :: k) (uni :: * -> *). Contains uni a => SomeTypeIn uni
someType @_ @f
{-# INLINE typeAst #-}
instance (KnownTypeAst tyname uni a, KnownTypeAst tyname uni b) =>
KnownTypeAst tyname uni (a -> b) where
type IsBuiltin _ (a -> b) = 'False
type ToHoles _ (a -> b) = '[TypeHole a, TypeHole b]
type ToBinds uni acc (a -> b) = ToBinds uni (ToBinds uni acc a) b
typeAst :: Type tyname uni ()
typeAst = ()
-> Type tyname uni () -> Type tyname uni () -> Type tyname uni ()
forall tyname (uni :: * -> *) ann.
ann
-> Type tyname uni ann
-> Type tyname uni ann
-> Type tyname uni ann
TyFun () (Proxy a -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy a -> Type tyname uni ()) -> Proxy a -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) (Proxy b -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy b -> Type tyname uni ()) -> Proxy b -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)
{-# INLINE typeAst #-}
instance (tyname ~ TyName, name ~ 'TyNameRep text uniq, KnownSymbol text, KnownNat uniq) =>
KnownTypeAst tyname uni (TyVarRep name) where
type IsBuiltin _ (TyVarRep name) = 'False
type ToHoles _ (TyVarRep name) = '[]
type ToBinds _ acc (TyVarRep name) = Insert ('GADT.Some name) acc
typeAst :: Type tyname uni ()
typeAst = () -> tyname -> Type tyname uni ()
forall tyname (uni :: * -> *) ann.
ann -> tyname -> Type tyname uni ann
TyVar () (tyname -> Type tyname uni ())
-> (Proxy ('TyNameRep text uniq) -> tyname)
-> Proxy ('TyNameRep text uniq)
-> Type tyname uni ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ('TyNameRep text uniq) -> tyname
Proxy ('TyNameRep text uniq) -> TyName
forall {kind} (text :: Symbol) (uniq :: Nat).
(KnownSymbol text, KnownNat uniq) =>
Proxy ('TyNameRep text uniq) -> TyName
toTyNameAst (Proxy ('TyNameRep text uniq) -> Type tyname uni ())
-> Proxy ('TyNameRep text uniq) -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: TyNameRep Any). Proxy t
Proxy @('TyNameRep text uniq)
{-# INLINE typeAst #-}
instance (KnownTypeAst tyname uni fun, KnownTypeAst tyname uni arg) =>
KnownTypeAst tyname uni (TyAppRep fun arg) where
type IsBuiltin uni (TyAppRep fun arg) = IsBuiltin uni fun && IsBuiltin uni arg
type ToHoles _ (TyAppRep fun arg) = '[RepHole fun, RepHole arg]
type ToBinds uni acc (TyAppRep fun arg) = ToBinds uni (ToBinds uni acc fun) arg
typeAst :: Type tyname uni ()
typeAst = ()
-> Type tyname uni () -> Type tyname uni () -> Type tyname uni ()
forall tyname (uni :: * -> *) ann.
ann
-> Type tyname uni ann
-> Type tyname uni ann
-> Type tyname uni ann
TyApp () (Proxy fun -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy fun -> Type tyname uni ())
-> Proxy fun -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: dom -> a). Proxy t
Proxy @fun) (Proxy arg -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy arg -> Type tyname uni ())
-> Proxy arg -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall (t :: dom). Proxy t
forall {k} (t :: k). Proxy t
Proxy @arg)
{-# INLINE typeAst #-}
instance
( tyname ~ TyName, name ~ 'TyNameRep @kind text uniq, KnownSymbol text, KnownNat uniq
, KnownKind kind, KnownTypeAst tyname uni a
) => KnownTypeAst tyname uni (TyForallRep name a) where
type IsBuiltin _ (TyForallRep name a) = 'False
type ToHoles _ (TyForallRep name a) = '[RepHole a]
type ToBinds uni acc (TyForallRep name a) = Delete ('GADT.Some name) (ToBinds uni acc a)
typeAst :: Type tyname uni ()
typeAst =
() -> tyname -> Kind () -> Type tyname uni () -> Type tyname uni ()
forall tyname (uni :: * -> *) ann.
ann
-> tyname -> Kind ann -> Type tyname uni ann -> Type tyname uni ann
TyForall ()
(Proxy ('TyNameRep text uniq) -> TyName
forall {kind} (text :: Symbol) (uniq :: Nat).
(KnownSymbol text, KnownNat uniq) =>
Proxy ('TyNameRep text uniq) -> TyName
toTyNameAst (Proxy ('TyNameRep text uniq) -> TyName)
-> Proxy ('TyNameRep text uniq) -> TyName
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: TyNameRep Any). Proxy t
Proxy @('TyNameRep text uniq))
(SingKind kind -> Kind ()
forall k. SingKind k -> Kind ()
demoteKind (SingKind kind -> Kind ()) -> SingKind kind -> Kind ()
forall a b. (a -> b) -> a -> b
$ forall k. KnownKind k => SingKind k
knownKind @kind)
(Proxy a -> Type tyname uni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
toTypeAst (Proxy a -> Type tyname uni ()) -> Proxy a -> Type tyname uni ()
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
{-# INLINE typeAst #-}
type Insert :: forall a. a -> [a] -> [a]
type family Insert x xs where
Insert x '[] = '[x]
Insert x (x : xs) = x ': xs
Insert x (y : xs) = y ': Insert x xs
type Delete :: forall a. a -> [a] -> [a]
type family Delete x xs where
Delete _ '[] = '[]
Delete x (x ': xs) = xs
Delete x (y ': xs) = y ': Delete x xs