{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module PlutusTx.Compiler.Types (
module PlutusTx.Compiler.Types,
module PlutusCore.Annotation
) where
import PlutusTx.Compiler.Error
import PlutusTx.Coverage
import PlutusTx.PLCTypes
import PlutusIR.Analysis.Builtins qualified as PIR
import PlutusIR.Compiler.Definitions
import PlutusIR.Transform.RewriteRules qualified as PIR
import PlutusCore.Annotation
import PlutusCore.Builtin qualified as PLC
import PlutusCore.Default qualified as PLC
import PlutusCore.Quote
import GHC qualified
import GHC.Core.FamInstEnv qualified as GHC
import GHC.Plugins qualified as GHC
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Language.Haskell.TH.Syntax qualified as TH
import Prettyprinter
type NameInfo = Map.Map TH.Name GHC.TyThing
data CompileOptions = CompileOptions {
CompileOptions -> ProfileOpts
coProfile :: ProfileOpts
, CompileOptions -> CoverageOpts
coCoverage :: CoverageOpts
, CompileOptions -> Bool
coRemoveTrace :: Bool
}
data CompileContext uni fun = CompileContext {
forall (uni :: * -> *) fun.
CompileContext uni fun -> CompileOptions
ccOpts :: CompileOptions,
forall (uni :: * -> *) fun. CompileContext uni fun -> DynFlags
ccFlags :: GHC.DynFlags,
forall (uni :: * -> *) fun. CompileContext uni fun -> FamInstEnvs
ccFamInstEnvs :: GHC.FamInstEnvs,
forall (uni :: * -> *) fun. CompileContext uni fun -> NameInfo
ccNameInfo :: NameInfo,
forall (uni :: * -> *) fun. CompileContext uni fun -> Scope uni
ccScope :: Scope uni,
forall (uni :: * -> *) fun. CompileContext uni fun -> Set Name
ccBlackholed :: Set.Set GHC.Name,
forall (uni :: * -> *) fun. CompileContext uni fun -> Maybe LexName
ccCurDef :: Maybe LexName,
forall (uni :: * -> *) fun.
CompileContext uni fun -> Maybe ModBreaks
ccModBreaks :: Maybe GHC.ModBreaks,
forall (uni :: * -> *) fun.
CompileContext uni fun -> BuiltinsInfo uni fun
ccBuiltinsInfo :: PIR.BuiltinsInfo uni fun,
forall (uni :: * -> *) fun.
CompileContext uni fun -> CostingPart uni fun
ccBuiltinCostModel :: PLC.CostingPart uni fun,
forall (uni :: * -> *) fun. CompileContext uni fun -> Bool
ccDebugTraceOn :: Bool,
forall (uni :: * -> *) fun.
CompileContext uni fun -> RewriteRules uni fun
ccRewriteRules :: PIR.RewriteRules uni fun
}
data CompileState = CompileState
{
CompileState -> Int
csNextStep :: Int
, CompileState -> [Int]
csPreviousSteps :: [Int]
}
data Verbosity =
Quiet
| Verbose
| Debug
deriving stock (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: Verbosity -> Verbosity -> Bool
Eq, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Verbosity -> ShowS
showsPrec :: Int -> Verbosity -> ShowS
$cshow :: Verbosity -> String
show :: Verbosity -> String
$cshowList :: [Verbosity] -> ShowS
showList :: [Verbosity] -> ShowS
Show)
instance Pretty Verbosity where
pretty :: forall ann. Verbosity -> Doc ann
pretty = Verbosity -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow
data ProfileOpts =
All
| None
deriving stock (ProfileOpts -> ProfileOpts -> Bool
(ProfileOpts -> ProfileOpts -> Bool)
-> (ProfileOpts -> ProfileOpts -> Bool) -> Eq ProfileOpts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProfileOpts -> ProfileOpts -> Bool
== :: ProfileOpts -> ProfileOpts -> Bool
$c/= :: ProfileOpts -> ProfileOpts -> Bool
/= :: ProfileOpts -> ProfileOpts -> Bool
Eq, Int -> ProfileOpts -> ShowS
[ProfileOpts] -> ShowS
ProfileOpts -> String
(Int -> ProfileOpts -> ShowS)
-> (ProfileOpts -> String)
-> ([ProfileOpts] -> ShowS)
-> Show ProfileOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProfileOpts -> ShowS
showsPrec :: Int -> ProfileOpts -> ShowS
$cshow :: ProfileOpts -> String
show :: ProfileOpts -> String
$cshowList :: [ProfileOpts] -> ShowS
showList :: [ProfileOpts] -> ShowS
Show)
instance Pretty ProfileOpts where
pretty :: forall ann. ProfileOpts -> Doc ann
pretty = ProfileOpts -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow
data CoverageOpts = CoverageOpts { CoverageOpts -> Set CoverageType
unCoverageOpts :: Set CoverageType }
activeCoverageTypes :: CompileOptions -> Set CoverageType
activeCoverageTypes :: CompileOptions -> Set CoverageType
activeCoverageTypes = CoverageOpts -> Set CoverageType
unCoverageOpts (CoverageOpts -> Set CoverageType)
-> (CompileOptions -> CoverageOpts)
-> CompileOptions
-> Set CoverageType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileOptions -> CoverageOpts
coCoverage
data CoverageType = LocationCoverage
| BooleanCoverage
deriving stock (Eq CoverageType
Eq CoverageType =>
(CoverageType -> CoverageType -> Ordering)
-> (CoverageType -> CoverageType -> Bool)
-> (CoverageType -> CoverageType -> Bool)
-> (CoverageType -> CoverageType -> Bool)
-> (CoverageType -> CoverageType -> Bool)
-> (CoverageType -> CoverageType -> CoverageType)
-> (CoverageType -> CoverageType -> CoverageType)
-> Ord CoverageType
CoverageType -> CoverageType -> Bool
CoverageType -> CoverageType -> Ordering
CoverageType -> CoverageType -> CoverageType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CoverageType -> CoverageType -> Ordering
compare :: CoverageType -> CoverageType -> Ordering
$c< :: CoverageType -> CoverageType -> Bool
< :: CoverageType -> CoverageType -> Bool
$c<= :: CoverageType -> CoverageType -> Bool
<= :: CoverageType -> CoverageType -> Bool
$c> :: CoverageType -> CoverageType -> Bool
> :: CoverageType -> CoverageType -> Bool
$c>= :: CoverageType -> CoverageType -> Bool
>= :: CoverageType -> CoverageType -> Bool
$cmax :: CoverageType -> CoverageType -> CoverageType
max :: CoverageType -> CoverageType -> CoverageType
$cmin :: CoverageType -> CoverageType -> CoverageType
min :: CoverageType -> CoverageType -> CoverageType
Ord, CoverageType -> CoverageType -> Bool
(CoverageType -> CoverageType -> Bool)
-> (CoverageType -> CoverageType -> Bool) -> Eq CoverageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CoverageType -> CoverageType -> Bool
== :: CoverageType -> CoverageType -> Bool
$c/= :: CoverageType -> CoverageType -> Bool
/= :: CoverageType -> CoverageType -> Bool
Eq, Int -> CoverageType -> ShowS
[CoverageType] -> ShowS
CoverageType -> String
(Int -> CoverageType -> ShowS)
-> (CoverageType -> String)
-> ([CoverageType] -> ShowS)
-> Show CoverageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CoverageType -> ShowS
showsPrec :: Int -> CoverageType -> ShowS
$cshow :: CoverageType -> String
show :: CoverageType -> String
$cshowList :: [CoverageType] -> ShowS
showList :: [CoverageType] -> ShowS
Show, Int -> CoverageType
CoverageType -> Int
CoverageType -> [CoverageType]
CoverageType -> CoverageType
CoverageType -> CoverageType -> [CoverageType]
CoverageType -> CoverageType -> CoverageType -> [CoverageType]
(CoverageType -> CoverageType)
-> (CoverageType -> CoverageType)
-> (Int -> CoverageType)
-> (CoverageType -> Int)
-> (CoverageType -> [CoverageType])
-> (CoverageType -> CoverageType -> [CoverageType])
-> (CoverageType -> CoverageType -> [CoverageType])
-> (CoverageType -> CoverageType -> CoverageType -> [CoverageType])
-> Enum CoverageType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: CoverageType -> CoverageType
succ :: CoverageType -> CoverageType
$cpred :: CoverageType -> CoverageType
pred :: CoverageType -> CoverageType
$ctoEnum :: Int -> CoverageType
toEnum :: Int -> CoverageType
$cfromEnum :: CoverageType -> Int
fromEnum :: CoverageType -> Int
$cenumFrom :: CoverageType -> [CoverageType]
enumFrom :: CoverageType -> [CoverageType]
$cenumFromThen :: CoverageType -> CoverageType -> [CoverageType]
enumFromThen :: CoverageType -> CoverageType -> [CoverageType]
$cenumFromTo :: CoverageType -> CoverageType -> [CoverageType]
enumFromTo :: CoverageType -> CoverageType -> [CoverageType]
$cenumFromThenTo :: CoverageType -> CoverageType -> CoverageType -> [CoverageType]
enumFromThenTo :: CoverageType -> CoverageType -> CoverageType -> [CoverageType]
Enum, CoverageType
CoverageType -> CoverageType -> Bounded CoverageType
forall a. a -> a -> Bounded a
$cminBound :: CoverageType
minBound :: CoverageType
$cmaxBound :: CoverageType
maxBound :: CoverageType
Bounded)
newtype LexName = LexName GHC.Name
deriving stock (LexName -> LexName -> Bool
(LexName -> LexName -> Bool)
-> (LexName -> LexName -> Bool) -> Eq LexName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LexName -> LexName -> Bool
== :: LexName -> LexName -> Bool
$c/= :: LexName -> LexName -> Bool
/= :: LexName -> LexName -> Bool
Eq)
instance Show LexName where
show :: LexName -> String
show (LexName Name
n) = OccName -> String
GHC.occNameString (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall name. HasOccName name => name -> OccName
GHC.occName Name
n
instance Ord LexName where
compare :: LexName -> LexName -> Ordering
compare (LexName Name
n1) (LexName Name
n2) =
case Name -> Name -> Ordering
stableNameCmp Name
n1 Name
n2 of
Ordering
EQ -> Name -> Name -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Name
n1 Name
n2
Ordering
o -> Ordering
o
stableNameCmp :: GHC.Name -> GHC.Name -> Ordering
stableNameCmp :: Name -> Name -> Ordering
stableNameCmp Name
n1 Name
n2 =
(Name -> OccName
forall name. HasOccName name => name -> OccName
GHC.occName Name
n1 OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Name -> OccName
forall name. HasOccName name => name -> OccName
GHC.occName Name
n2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
(Module -> Module -> Ordering)
-> Maybe Module -> Maybe Module -> Ordering
forall a. (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering
maybeCmp Module -> Module -> Ordering
stableModuleCmp (Name -> Maybe Module
GHC.nameModule_maybe Name
n1) (Name -> Maybe Module
GHC.nameModule_maybe Name
n2)
where
maybeCmp :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering
maybeCmp :: forall a. (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering
maybeCmp a -> a -> Ordering
cmp (Just a
l) (Just a
r) = a
l a -> a -> Ordering
`cmp` a
r
maybeCmp a -> a -> Ordering
_ Maybe a
Nothing (Just a
_) = Ordering
LT
maybeCmp a -> a -> Ordering
_ (Just a
_) Maybe a
Nothing = Ordering
GT
maybeCmp a -> a -> Ordering
_ Maybe a
Nothing Maybe a
Nothing = Ordering
EQ
stableModuleCmp :: GHC.Module -> GHC.Module -> Ordering
stableModuleCmp :: Module -> Module -> Ordering
stableModuleCmp Module
m1 Module
m2 =
(Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m1 ModuleName -> ModuleName -> Ordering
`GHC.stableModuleNameCmp` Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
(Module -> Unit
forall unit. GenModule unit -> unit
GHC.moduleUnit Module
m1 Unit -> Unit -> Ordering
`GHC.stableUnitCmp` Module -> Unit
forall unit. GenModule unit -> unit
GHC.moduleUnit Module
m2)
type Compiling uni fun m ann =
( MonadError (CompileError uni fun ann) m
, MonadQuote m
, MonadReader (CompileContext uni fun) m
, MonadState CompileState m
, MonadDefs LexName uni fun Ann m
, MonadWriter CoverageIndex m
)
type CompilingDefault uni fun m ann =
( uni ~ PLC.DefaultUni
, fun ~ PLC.DefaultFun
, Compiling uni fun m ann
)
blackhole :: MonadReader (CompileContext uni fun) m => GHC.Name -> m a -> m a
blackhole :: forall (uni :: * -> *) fun (m :: * -> *) a.
MonadReader (CompileContext uni fun) m =>
Name -> m a -> m a
blackhole Name
name = (CompileContext uni fun -> CompileContext uni fun) -> m a -> m a
forall a.
(CompileContext uni fun -> CompileContext uni fun) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\CompileContext uni fun
cc -> CompileContext uni fun
cc {ccBlackholed=Set.insert name (ccBlackholed cc)})
blackholed :: MonadReader (CompileContext uni fun) m => GHC.Name -> m Bool
blackholed :: forall (uni :: * -> *) fun (m :: * -> *).
MonadReader (CompileContext uni fun) m =>
Name -> m Bool
blackholed Name
name = do
CompileContext {ccBlackholed :: forall (uni :: * -> *) fun. CompileContext uni fun -> Set Name
ccBlackholed=Set Name
bh} <- m (CompileContext uni fun)
forall r (m :: * -> *). MonadReader r m => m r
ask
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
name Set Name
bh
data Scope uni = Scope (Map.Map GHC.Name (PLCVar uni)) (Map.Map GHC.Name PLCTyVar)
initialScope :: Scope uni
initialScope :: forall (uni :: * -> *). Scope uni
initialScope = Map Name (PLCVar uni) -> Map Name PLCTyVar -> Scope uni
forall (uni :: * -> *).
Map Name (PLCVar uni) -> Map Name PLCTyVar -> Scope uni
Scope Map Name (PLCVar uni)
forall k a. Map k a
Map.empty Map Name PLCTyVar
forall k a. Map k a
Map.empty
withCurDef :: Compiling uni fun m ann => LexName -> m a -> m a
withCurDef :: forall (uni :: * -> *) fun (m :: * -> *) ann a.
Compiling uni fun m ann =>
LexName -> m a -> m a
withCurDef LexName
name = (CompileContext uni fun -> CompileContext uni fun) -> m a -> m a
forall a.
(CompileContext uni fun -> CompileContext uni fun) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\CompileContext uni fun
cc -> CompileContext uni fun
cc {ccCurDef=Just name})
modifyCurDeps :: Compiling uni fun m ann => (Set.Set LexName -> Set.Set LexName) -> m ()
modifyCurDeps :: forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
(Set LexName -> Set LexName) -> m ()
modifyCurDeps Set LexName -> Set LexName
f = do
Maybe LexName
cur <- (CompileContext uni fun -> Maybe LexName) -> m (Maybe LexName)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompileContext uni fun -> Maybe LexName
forall (uni :: * -> *) fun. CompileContext uni fun -> Maybe LexName
ccCurDef
case Maybe LexName
cur of
Maybe LexName
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just LexName
n -> LexName -> (Set LexName -> Set LexName) -> m ()
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
key -> (Set key -> Set key) -> m ()
modifyDeps LexName
n Set LexName -> Set LexName
f