-- editorconfig-checker-disable-file
{-# 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

-- | Compilation options.
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
    { -- | The ID of the next step to be taken by the PlutusTx compiler.
      -- This is used when generating debug traces.
      CompileState -> Int
csNextStep      :: Int
      -- | The IDs of the previous steps taken by the PlutusTx compiler leading up to
      -- the current point. This is used when generating debug traces.
    , CompileState -> [Int]
csPreviousSteps :: [Int]
    }

-- | Verbosity level of the Plutus Tx compiler.
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

-- | Profiling options. @All@ profiles everything. @None@ is the default.
data ProfileOpts =
    All -- set this with -fplugin-opt PlutusTx.Plugin:profile-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

-- | Coverage options
-- See Note [Coverage annotations]
data CoverageOpts = CoverageOpts { CoverageOpts -> Set CoverageType
unCoverageOpts :: Set CoverageType }

-- | Get the coverage types we are using
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

-- | Option `{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-all #-}` enables all these
-- See Note [Adding more coverage annotations].
-- See Note [Coverage order]
data CoverageType = LocationCoverage -- ^ Check that all source locations that we can identify in GHC Core have been covered.
                                     -- For this to work at all we need `{-# OPTIONS_GHC -g #-}`
                                     -- turn on with `{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-location #-}`
                  | BooleanCoverage -- ^ Check that every boolean valued expression that isn't `True` or `False` for which
                                    -- we know the source location have been covered. For this to work at all we need
                                    -- `{-# OPTIONS_GHC -g #-}` turn on with
                                    -- `{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-boolean #-}`
                    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)

{- Note [Coverage order]
   The order in which `CoverageType` constructors appear in the type determine the order in
   which their respective transformations in `coverageCompile` will be executed. The topmost `CoverageType`
   will be executed first, followed by the second from the top and so on. It is important to either:
   1. Never add coverage transformations that don't commute or
   2. BE VERY CAREFUL!
   Currently we are employing option (1). Please don't change that unless you know what you're doing
   and you've read the code of `coverageCompile` carefully.
-}

-- | A wrapper around 'GHC.Name' with a stable 'Ord' instance. Use this where the ordering
-- will affect the output of the compiler, i.e. when sorting or so on. It's  fine to use
-- 'GHC.Name' if we're just putting them in a 'Set.Set', for example.
--
-- The 'Eq' instance we derive - it's also not stable across builds, but I believe this is only
-- a problem if you compare things from different builds, which we don't do.
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
            -- This case is not sound if the names are generated, so we have to
            -- fall back on the default sound comparison for names. This is
            -- non-deterministic! But we care even more about not mixing up things
            -- that are different than we do about determinism.
            Ordering
EQ -> Name -> Name -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Name
n1 Name
n2
            Ordering
o  -> Ordering
o

{- Note [Stable name comparisons]
GHC defines `stableNameCmp` which does a good job of being a stable name
comparator across compiles. *However*, it includes, indirectly, the unit
id that a name comes from, including the hash. While this is stable across
compiles of exactly the same thing, it is *not* stable across compiles
in slightly different environments, e.g. with cabal new-build vs with nix.

This matters since that can eventually affect our test output.

We partially fix this by making the comparison less likely to consult the
unstable unit id. We do this by just flipping the order in which we consult
components: normally GHC looks at the unit id first, then the module name, then
the `OccName`. We do it in the opposite order.

While we can still get instability from this, it should now only happen
if we have a binding with the same name in the same module name but from
different units.

We would like to just copy GHC's implementation and tweak it, but it relies
on non-exported data constructors, so we have to write our own. This is mostly
the same, but e.g. we can't look directly at the "sort" of a `Name`.
-}

-- | Our own version of 'GHC.stableNameCmp'.
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
<>
    -- See Note [Stable name comparisons]
    (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

-- | Our own version of 'GHC.stableModuleCmp'.
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
<>
    -- See Note [Stable name comparisons]
    (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)

-- See Note [Scopes]
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
    )

-- Packing up equality constraints gives us a nice way of writing type signatures as this way
-- we don't need to write 'PLC.DefaultUni' everywhere (in 'PIRTerm', 'PIRType' etc) and instead
-- can write the short @uni@ and know that it actually means 'PLC.DefaultUni'. Same regarding
-- 'DefaultFun'.
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

{- Note [Scopes]
We need a notion of scope, because we have to make sure that if we convert a GHC
Var into a variable, then we always convert it into the same variable, while also making
sure that if we encounter multiple things with the same name we produce fresh variables
appropriately.

We keep the scope in a `Reader` monad, so any modifications are only local.
-}

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