{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module PlutusTx.Compiler.Expr (compileExpr, compileExprWithDefs, compileDataConRef) where
import GHC.Builtin.Names qualified as GHC
import GHC.Builtin.Types.Prim qualified as GHC
import GHC.ByteCode.Types qualified as GHC
import GHC.Core qualified as GHC
import GHC.Core.Class qualified as GHC
import GHC.Core.Multiplicity qualified as GHC
import GHC.Core.TyCo.Rep qualified as GHC
import GHC.Plugins qualified as GHC
import GHC.Types.CostCentre qualified as GHC
import GHC.Types.Id.Make qualified as GHC
import GHC.Types.Tickish qualified as GHC
import GHC.Types.TyThing qualified as GHC
#if MIN_VERSION_ghc(9,6,0)
import GHC.Tc.Utils.TcType qualified as GHC
#endif
import PlutusTx.Bool qualified
import PlutusTx.Builtins qualified as Builtins
import PlutusTx.Builtins.Internal qualified as Builtins
import PlutusTx.Compiler.Binders
import PlutusTx.Compiler.Builtins
import PlutusTx.Compiler.Error
import PlutusTx.Compiler.Laziness
import PlutusTx.Compiler.Names
import PlutusTx.Compiler.Trace
import PlutusTx.Compiler.Type
import PlutusTx.Compiler.Types
import PlutusTx.Compiler.Utils
import PlutusTx.Coverage
import PlutusTx.PIRTypes
import PlutusTx.PLCTypes (PLCType, PLCVar)
import PlutusTx.Builtins.HasOpaque qualified as Builtins
import PlutusTx.Trace
import PlutusIR qualified as PIR
import PlutusIR.Analysis.Builtins
import PlutusIR.Compiler.Definitions qualified as PIR
import PlutusIR.Compiler.Names (safeFreshName)
import PlutusIR.Core.Type (Term (..))
import PlutusIR.MkPir qualified as PIR
import PlutusIR.Purity qualified as PIR
import PlutusCore qualified as PLC
import PlutusCore.Data qualified as PLC
import PlutusCore.MkPlc qualified as PLC
import PlutusCore.Pretty qualified as PP
import PlutusCore.Subst qualified as PLC
import Control.Lens hiding (index, strict, transform)
import Control.Monad
import Control.Monad.Reader (ask)
import Data.Array qualified as Array
import Data.ByteString qualified as BS
import Data.Generics.Uniplate.Data (transform, universeBi)
import Data.List (elemIndex, isPrefixOf, isSuffixOf)
import Data.Map qualified as Map
import Data.Maybe
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Traversable
import GHC.Num.Integer qualified
compileLiteral ::
(CompilingDefault uni fun m ann) =>
GHC.Literal ->
m (PIRTerm uni fun)
compileLiteral :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Literal -> m (PIRTerm uni fun)
compileLiteral = \case
(GHC.LitNumber LitNumType
_ Integer
i) -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun Ann -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
Term tyname name uni fun ann -> term ann
PIR.embedTerm (Term TyName Name DefaultUni DefaultFun Ann -> PIRTerm uni fun)
-> Term TyName Name DefaultUni DefaultFun Ann -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ Ann -> Integer -> Term TyName Name DefaultUni DefaultFun Ann
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline Integer
i
GHC.LitString ByteString
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal string (maybe you need to use OverloadedStrings)"
GHC.LitChar Char
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal char"
GHC.LitFloat Rational
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal float"
GHC.LitDouble Rational
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal double"
GHC.LitLabel{} -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal label"
Literal
GHC.LitNullAddr -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal null"
GHC.LitRubbish{} -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal rubbish"
stringExprContent :: GHC.CoreExpr -> Maybe BS.ByteString
stringExprContent :: CoreExpr -> Maybe ByteString
stringExprContent = \case
GHC.Lit (GHC.LitString ByteString
bs) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
GHC.Var Id
n `GHC.App` CoreExpr
expr
| let name :: Name
name = Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n
, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringName Bool -> Bool -> Bool
|| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringUtf8Name ->
CoreExpr -> Maybe ByteString
stringExprContent CoreExpr
expr
GHC.Var Id
build `GHC.App` CoreExpr
_ `GHC.App` GHC.Lam Id
_ (GHC.Var Id
unpack `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
expr)
| Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
build Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.buildName Bool -> Bool -> Bool
&& Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
unpack Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringFoldrName -> CoreExpr -> Maybe ByteString
stringExprContent CoreExpr
expr
GHC.Var Id
nil `GHC.App` GHC.Type (Type -> Maybe TyCon
GHC.tyConAppTyCon_maybe -> Just TyCon
tc)
| Id
nil Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Id
GHC.dataConWorkId DataCon
GHC.nilDataCon, TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.charTyConName -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
forall a. Monoid a => a
mempty
GHC.Var (Unfolding -> Maybe CoreExpr
GHC.maybeUnfoldingTemplate (Unfolding -> Maybe CoreExpr)
-> (Id -> Unfolding) -> Id -> Maybe CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unfolding
GHC.realIdUnfolding -> Just CoreExpr
unfolding) -> CoreExpr -> Maybe ByteString
stringExprContent CoreExpr
unfolding
CoreExpr
_ -> Maybe ByteString
forall a. Maybe a
Nothing
strip :: GHC.CoreExpr -> GHC.CoreExpr
strip :: CoreExpr -> CoreExpr
strip = \case
GHC.Var Id
n `GHC.App` GHC.Type Type
_ `GHC.App` CoreExpr
expr | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.noinlineIdName -> CoreExpr -> CoreExpr
strip CoreExpr
expr
GHC.Tick CoreTickish
_ CoreExpr
expr -> CoreExpr -> CoreExpr
strip CoreExpr
expr
CoreExpr
expr -> CoreExpr
expr
compileDataConRef :: (CompilingDefault uni fun m ann) => GHC.DataCon -> m (PIRTerm uni fun)
compileDataConRef :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
DataCon -> m (PIRTerm uni fun)
compileDataConRef DataCon
dc = do
[DataCon]
dcs <- TyCon -> m [DataCon]
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
TyCon -> m [DataCon]
getDataCons TyCon
tc
[PIRTerm uni fun]
constrs <- TyCon -> m [PIRTerm uni fun]
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
TyCon -> m [PIRTerm uni fun]
getConstructors TyCon
tc
Int
index <- case DataCon -> [DataCon] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex DataCon
dc [DataCon]
dcs of
Just Int
i -> Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
Maybe Int
Nothing ->
Error DefaultUni DefaultFun ann -> m Int
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m Int)
-> Error DefaultUni DefaultFun ann -> m Int
forall a b. (a -> b) -> a -> b
$
Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"Data constructor not in the type constructor's list of constructors"
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ [PIRTerm uni fun]
constrs [PIRTerm uni fun] -> Int -> PIRTerm uni fun
forall a. HasCallStack => [a] -> Int -> a
!! Int
index
where
tc :: TyCon
tc = DataCon -> TyCon
GHC.dataConTyCon DataCon
dc
compileAlt ::
(CompilingDefault uni fun m ann) =>
GHC.CoreAlt ->
[GHC.Type] ->
PIRTerm uni fun ->
m (PIRTerm uni fun, PIRTerm uni fun)
compileAlt :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreAlt
-> [Type]
-> PIRTerm uni fun
-> m (PIRTerm uni fun, PIRTerm uni fun)
compileAlt (GHC.Alt AltCon
alt [Id]
vars CoreExpr
body) [Type]
instArgTys PIRTerm uni fun
defaultBody =
Int
-> SDoc
-> m (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
3 (SDoc
"Creating alternative:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr AltCon
alt) (m (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun))
-> m (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ case AltCon
alt of
GHC.LitAlt Literal
_ -> Error DefaultUni DefaultFun ann
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann
-> m (PIRTerm uni fun, PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal case"
GHC.DataAlt DataCon
_ -> [Id]
-> ([VarDecl TyName Name DefaultUni Ann]
-> m (PIRTerm uni fun, PIRTerm uni fun))
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
[Id] -> ([VarDecl TyName Name uni Ann] -> m a) -> m a
withVarsScoped [Id]
vars (([VarDecl TyName Name DefaultUni Ann]
-> m (PIRTerm uni fun, PIRTerm uni fun))
-> m (PIRTerm uni fun, PIRTerm uni fun))
-> ([VarDecl TyName Name DefaultUni Ann]
-> m (PIRTerm uni fun, PIRTerm uni fun))
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \[VarDecl TyName Name DefaultUni Ann]
vars' -> do
PIRTerm uni fun
b <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
PIRTerm uni fun
delayed <- PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
delay PIRTerm uni fun
b
(PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarDecl TyName Name DefaultUni Ann]
-> PIRTerm uni fun -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
[VarDecl tyname name uni ann] -> term ann -> term ann
PLC.mkIterLamAbs [VarDecl TyName Name DefaultUni Ann]
vars' PIRTerm uni fun
b, [VarDecl TyName Name DefaultUni Ann]
-> PIRTerm uni fun -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
[VarDecl tyname name uni ann] -> term ann -> term ann
PLC.mkIterLamAbs [VarDecl TyName Name DefaultUni Ann]
vars' PIRTerm uni fun
delayed)
AltCon
GHC.DEFAULT -> do
let compiledBody :: PIRTerm uni fun
compiledBody = PIRTerm uni fun
defaultBody
PIRTerm uni fun
nonDelayed <- PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
wrapDefaultAlt PIRTerm uni fun
compiledBody
PIRTerm uni fun
delayed <- PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
delay PIRTerm uni fun
compiledBody m (PIRTerm uni fun)
-> (PIRTerm uni fun -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
wrapDefaultAlt
(PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PIRTerm uni fun
nonDelayed, PIRTerm uni fun
delayed)
where
wrapDefaultAlt :: (CompilingDefault uni fun m ann) => PIRTerm uni fun -> m (PIRTerm uni fun)
wrapDefaultAlt :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
wrapDefaultAlt PIRTerm uni fun
body' = do
[PLCType DefaultUni]
argTypes <- (Type -> m (PLCType DefaultUni))
-> [Type] -> m [PLCType DefaultUni]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> m (PLCType DefaultUni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm [Type]
instArgTys
[Name]
argNames <- [Int] -> (Int -> m Name) -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. ([PLCType DefaultUni] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PLCType DefaultUni]
argTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] (\Int
i -> Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
safeFreshName (Text -> m Name) -> Text -> m Name
forall a b. (a -> b) -> a -> b
$ Text
"default_arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i))
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ [VarDecl TyName Name DefaultUni Ann]
-> PIRTerm uni fun -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
[VarDecl tyname name uni ann] -> term ann -> term ann
PIR.mkIterLamAbs ((Name -> PLCType DefaultUni -> VarDecl TyName Name DefaultUni Ann)
-> [Name]
-> [PLCType DefaultUni]
-> [VarDecl TyName Name DefaultUni Ann]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Ann
-> Name -> PLCType DefaultUni -> VarDecl TyName Name DefaultUni Ann
forall tyname name (uni :: * -> *) ann.
ann -> name -> Type tyname uni ann -> VarDecl tyname name uni ann
PIR.VarDecl Ann
annMayInline) [Name]
argNames [PLCType DefaultUni]
argTypes) PIRTerm uni fun
body'
isErrorId :: GHC.Id -> Bool
isErrorId :: Id -> Bool
isErrorId Id
ghcId = Id
ghcId Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
GHC.errorIds
isProbablyBytestringEq :: GHC.Id -> Bool
isProbablyBytestringEq :: Id -> Bool
isProbablyBytestringEq (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
| Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
, ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Data.ByteString.Internal" Bool -> Bool -> Bool
|| ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Data.ByteString.Lazy.Internal"
, OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"eq" =
Bool
True
isProbablyBytestringEq Id
_ = Bool
False
isProbablyIntegerEq :: GHC.Id -> Bool
isProbablyIntegerEq :: Id -> Bool
isProbablyIntegerEq (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
| Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
, ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Num.Integer"
, OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"integerEq" =
Bool
True
isProbablyIntegerEq Id
_ = Bool
False
isProbablyBoundedRange :: GHC.Id -> Bool
isProbablyBoundedRange :: Id -> Bool
isProbablyBoundedRange (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
| Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
, ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Enum" =
(String
"$fEnum" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName Bool -> Bool -> Bool
&&
( String
"_$cenumFromTo" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName
Bool -> Bool -> Bool
|| String
"_$cenumFromThenTo" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName
)
)
Bool -> Bool -> Bool
|| String
"enumDeltaToInteger" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName
where methodName :: String
methodName = OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n)
isProbablyBoundedRange Id
_ = Bool
False
isProbablyUnboundedRange :: GHC.Id -> Bool
isProbablyUnboundedRange :: Id -> Bool
isProbablyUnboundedRange (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
| Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
, ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Enum" =
(String
"$fEnum" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName Bool -> Bool -> Bool
&&
( String
"_$cenumFrom" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName
Bool -> Bool -> Bool
|| String
"_$cenumFromThen" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName
)
)
Bool -> Bool -> Bool
|| String
"enumDeltaInteger" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName
where methodName :: String
methodName = OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n)
isProbablyUnboundedRange Id
_ = Bool
False
hoistExpr ::
(CompilingDefault uni fun m ann) =>
GHC.Var ->
GHC.CoreExpr ->
m (PIRTerm uni fun)
hoistExpr :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> CoreExpr -> m (PIRTerm uni fun)
hoistExpr Id
var CoreExpr
t = do
let name :: Name
name = Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
var
lexName :: LexName
lexName = Name -> LexName
LexName Name
name
hasInlinePragma :: Bool
hasInlinePragma = InlinePragma -> Bool
GHC.isInlinePragma (InlinePragma -> Bool) -> InlinePragma -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> InlinePragma
GHC.idInlinePragma Id
var
ann :: Ann
ann = if Bool
hasInlinePragma then Ann
annAlwaysInline else Ann
annMayInline
(Set LexName -> Set LexName) -> m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
(Set LexName -> Set LexName) -> m ()
modifyCurDeps (LexName -> Set LexName -> Set LexName
forall a. Ord a => a -> Set a -> Set a
Set.insert LexName
lexName)
Maybe (PIRTerm uni fun)
maybeDef <- Ann -> LexName -> m (Maybe (PIRTerm uni fun))
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
ann -> key -> m (Maybe (Term TyName Name uni fun ann))
PIR.lookupTerm Ann
annMayInline LexName
lexName
let addSpan :: m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
addSpan = case Id -> Maybe RealSrcSpan
getVarSourceSpan Id
var of
Maybe RealSrcSpan
Nothing -> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a. a -> a
id
Just RealSrcSpan
src -> (Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann))
-> (SrcSpan
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann)
-> SrcSpan
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b.
(a -> b)
-> Term TyName Name DefaultUni DefaultFun a
-> Term TyName Name DefaultUni DefaultFun b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Ann -> Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann)
-> (SrcSpan -> Ann -> Ann)
-> SrcSpan
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Ann -> Ann
addSrcSpan (SrcSpan
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann))
-> SrcSpan
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
src RealSrcSpan -> Getting SrcSpan RealSrcSpan SrcSpan -> SrcSpan
forall s a. s -> Getting a s a -> a
^. Getting SrcSpan RealSrcSpan SrcSpan
Iso' RealSrcSpan SrcSpan
srcSpanIso
case Maybe (PIRTerm uni fun)
maybeDef of
Just PIRTerm uni fun
term -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
term
Maybe (PIRTerm uni fun)
Nothing -> LexName -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
Compiling uni fun m ann =>
LexName -> m a -> m a
withCurDef LexName
lexName (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
-> m (PIRTerm uni fun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SDoc -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
1 (SDoc
"Compiling definition of:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Id
var) (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ do
VarDecl TyName Name DefaultUni Ann
var' <- Ann -> Id -> m (VarDecl TyName Name DefaultUni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Ann -> Id -> m (PLCVar uni)
compileVarFresh Ann
ann Id
var
LexName
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> Set LexName
-> m ()
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
key -> TermDefWithStrictness uni fun ann -> Set key -> m ()
PIR.defineTerm
LexName
lexName
(VarDecl TyName Name DefaultUni Ann
-> (Term TyName Name DefaultUni DefaultFun Ann, Strictness)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall var val. var -> val -> Def var val
PIR.Def VarDecl TyName Name DefaultUni Ann
var' (Ann
-> VarDecl TyName Name DefaultUni Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> VarDecl tyname name uni ann -> term ann
PIR.mkVar Ann
ann VarDecl TyName Name DefaultUni Ann
var', Strictness
PIR.Strict))
Set LexName
forall a. Monoid a => a
mempty
Term TyName Name DefaultUni DefaultFun Ann
t' <- VarDecl TyName Name DefaultUni Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs VarDecl TyName Name DefaultUni Ann
var' (Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann))
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
addSpan (CoreExpr -> m (Term TyName Name DefaultUni DefaultFun Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
t)
LexName
-> (TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann)
-> m ()
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
key
-> (TermDefWithStrictness uni fun ann
-> TermDefWithStrictness uni fun ann)
-> m ()
PIR.modifyTermDef LexName
lexName (TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall a b. a -> b -> a
const (TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$ VarDecl TyName Name DefaultUni Ann
-> (Term TyName Name DefaultUni DefaultFun Ann, Strictness)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall var val. var -> val -> Def var val
PIR.Def VarDecl TyName Name DefaultUni Ann
var' (Term TyName Name DefaultUni DefaultFun Ann
t', Strictness
PIR.NonStrict))
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> VarDecl TyName Name DefaultUni Ann -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> VarDecl tyname name uni ann -> term ann
PIR.mkVar Ann
ann VarDecl TyName Name DefaultUni Ann
var'
maybeProfileRhs :: (CompilingDefault uni fun m ann) => PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs PLCVar uni
var PIRTerm uni fun
t = do
CompileContext{ccOpts :: forall (uni :: * -> *) fun.
CompileContext uni fun -> CompileOptions
ccOpts = CompileOptions
compileOpts} <- m (CompileContext DefaultUni DefaultFun)
forall r (m :: * -> *). MonadReader r m => m r
ask
let ty :: Type TyName uni Ann
ty = PLCVar uni -> Type TyName uni Ann
forall tyname name (uni :: * -> *) ann.
VarDecl tyname name uni ann -> Type tyname uni ann
PLC._varDeclType PLCVar uni
var
varName :: Name
varName = PLCVar uni -> Name
forall tyname name (uni :: * -> *) ann.
VarDecl tyname name uni ann -> name
PLC._varDeclName PLCVar uni
var
displayName :: Text
displayName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a str. (PrettyPlc a, Render str) => a -> str
PP.displayPlcSimple Name
varName
isFunctionOrAbstraction :: Bool
isFunctionOrAbstraction = case Type TyName uni Ann
ty of PLC.TyFun{} -> Bool
True; PLC.TyForall{} -> Bool
True; Type TyName uni Ann
_ -> Bool
False
if CompileOptions -> ProfileOpts
coProfile CompileOptions
compileOpts ProfileOpts -> ProfileOpts -> Bool
forall a. Eq a => a -> a -> Bool
== ProfileOpts
All Bool -> Bool -> Bool
&& Bool
isFunctionOrAbstraction
then do
Name
thunk <- Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
PLC.freshName Text
"thunk"
Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann))
-> Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> a -> b
$ Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracingInside Name
thunk Text
displayName PIRTerm uni fun
Term TyName Name DefaultUni DefaultFun Ann
t Type TyName uni Ann
PLCType DefaultUni
ty
else PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
t
mkTrace ::
(uni `PLC.HasTermLevel` T.Text) =>
PLC.Type PLC.TyName uni Ann ->
T.Text ->
PIRTerm uni PLC.DefaultFun ->
PIRTerm uni PLC.DefaultFun
mkTrace :: forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace Type TyName uni Ann
ty Text
str PIRTerm uni DefaultFun
v =
PIRTerm uni DefaultFun
-> [(Ann, PIRTerm uni DefaultFun)] -> PIRTerm uni DefaultFun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PLC.mkIterApp
(Ann
-> PIRTerm uni DefaultFun
-> Type TyName uni Ann
-> PIRTerm uni DefaultFun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (Ann -> DefaultFun -> PIRTerm uni DefaultFun
forall tyname name (uni :: * -> *) fun a.
a -> fun -> Term tyname name uni fun a
PIR.Builtin Ann
annMayInline DefaultFun
PLC.Trace) Type TyName uni Ann
ty)
((Ann
annMayInline,) (PIRTerm uni DefaultFun -> (Ann, PIRTerm uni DefaultFun))
-> [PIRTerm uni DefaultFun] -> [(Ann, PIRTerm uni DefaultFun)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ann -> Text -> PIRTerm uni DefaultFun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline Text
str, PIRTerm uni DefaultFun
v])
mkLazyTrace ::
(CompilingDefault uni fun m ann) =>
PLC.Type PLC.TyName uni Ann ->
T.Text ->
PIRTerm uni PLC.DefaultFun ->
m (PIRTerm uni fun)
mkLazyTrace :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> m (PIRTerm uni fun)
mkLazyTrace Type TyName uni Ann
ty Text
str PIRTerm uni DefaultFun
v = do
PIRTerm uni DefaultFun
delayedBody <- PIRTerm uni DefaultFun -> m (PIRTerm uni DefaultFun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
delay PIRTerm uni DefaultFun
v
Type TyName uni Ann
delayedType <- Type TyName uni Ann -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRType uni -> m (PIRType uni)
delayType Type TyName uni Ann
ty
PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
force (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace Type TyName uni Ann
delayedType Text
str PIRTerm uni DefaultFun
delayedBody
entryExitTracingInside ::
PIR.Name ->
T.Text ->
PIRTerm PLC.DefaultUni PLC.DefaultFun ->
PLCType PLC.DefaultUni ->
PIRTerm PLC.DefaultUni PLC.DefaultFun
entryExitTracingInside :: Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracingInside Name
lamName Text
displayName = Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
forall a. Monoid a => a
mempty
where
go ::
Map.Map PLC.TyName (PLCType PLC.DefaultUni) ->
PIRTerm PLC.DefaultUni PLC.DefaultFun ->
PLCType PLC.DefaultUni ->
PIRTerm PLC.DefaultUni PLC.DefaultFun
go :: Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
subst (LamAbs Ann
ann Name
n PLCType DefaultUni
t Term TyName Name DefaultUni DefaultFun Ann
body) (PLC.TyFun Ann
_ PLCType DefaultUni
_dom PLCType DefaultUni
cod) =
Ann
-> Name
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> name
-> Type tyname uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
LamAbs Ann
ann Name
n PLCType DefaultUni
t (Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$ Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
subst Term TyName Name DefaultUni DefaultFun Ann
body PLCType DefaultUni
cod
go Map TyName (PLCType DefaultUni)
subst (TyAbs Ann
ann TyName
tn1 Kind Ann
k Term TyName Name DefaultUni DefaultFun Ann
body) (PLC.TyForall Ann
_ TyName
tn2 Kind Ann
_k PLCType DefaultUni
ty) =
let subst' :: Map TyName (PLCType DefaultUni)
subst' = TyName
-> PLCType DefaultUni
-> Map TyName (PLCType DefaultUni)
-> Map TyName (PLCType DefaultUni)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TyName
tn2 (Ann -> TyName -> PLCType DefaultUni
forall tyname (uni :: * -> *) ann.
ann -> tyname -> Type tyname uni ann
PLC.TyVar Ann
annMayInline TyName
tn1) Map TyName (PLCType DefaultUni)
subst
in Ann
-> TyName
-> Kind Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> tyname
-> Kind a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
TyAbs Ann
ann TyName
tn1 Kind Ann
k (Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$ Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
subst' Term TyName Name DefaultUni DefaultFun Ann
body PLCType DefaultUni
ty
go Map TyName (PLCType DefaultUni)
subst Term TyName Name DefaultUni DefaultFun Ann
e PLCType DefaultUni
ty =
let ty' :: PLCType DefaultUni
ty' = (TyName -> Maybe (PLCType DefaultUni))
-> PLCType DefaultUni -> PLCType DefaultUni
forall tyname (uni :: * -> *) ann.
(tyname -> Maybe (Type tyname uni ann))
-> Type tyname uni ann -> Type tyname uni ann
PLC.typeSubstTyNames (\TyName
tn -> TyName
-> Map TyName (PLCType DefaultUni) -> Maybe (PLCType DefaultUni)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TyName
tn Map TyName (PLCType DefaultUni)
subst) PLCType DefaultUni
ty
in Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracing Name
lamName Text
displayName Term TyName Name DefaultUni DefaultFun Ann
e PLCType DefaultUni
ty'
entryExitTracing ::
PLC.Name ->
T.Text ->
PIRTerm PLC.DefaultUni PLC.DefaultFun ->
PLC.Type PLC.TyName PLC.DefaultUni Ann ->
PIRTerm PLC.DefaultUni PLC.DefaultFun
entryExitTracing :: Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracing Name
lamName Text
displayName Term TyName Name DefaultUni DefaultFun Ann
e PLCType DefaultUni
ty =
let defaultUnitTy :: Type tyname DefaultUni Ann
defaultUnitTy = Ann -> SomeTypeIn DefaultUni -> Type tyname DefaultUni Ann
forall tyname (uni :: * -> *) ann.
ann -> SomeTypeIn uni -> Type tyname uni ann
PLC.TyBuiltin Ann
annMayInline (DefaultUni (Esc ()) -> SomeTypeIn DefaultUni
forall (uni :: * -> *) k (a :: k). uni (Esc a) -> SomeTypeIn uni
PLC.SomeTypeIn DefaultUni (Esc ())
PLC.DefaultUniUnit)
defaultUnit :: Term tyname name DefaultUni fun Ann
defaultUnit = Ann
-> Some (ValueOf DefaultUni) -> Term tyname name DefaultUni fun Ann
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (DefaultUni (Esc ()) -> () -> Some (ValueOf DefaultUni)
forall a (uni :: * -> *). uni (Esc a) -> a -> Some (ValueOf uni)
PLC.someValueOf DefaultUni (Esc ())
PLC.DefaultUniUnit ())
in
Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Apply
Ann
annMayInline
( PLCType DefaultUni
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace
(Ann
-> PLCType DefaultUni -> PLCType DefaultUni -> PLCType DefaultUni
forall tyname (uni :: * -> *) ann.
ann
-> Type tyname uni ann
-> Type tyname uni ann
-> Type tyname uni ann
PLC.TyFun Ann
annMayInline PLCType DefaultUni
forall {tyname}. Type tyname DefaultUni Ann
defaultUnitTy PLCType DefaultUni
ty)
(Text
"entering " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
displayName)
(Ann
-> Name
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> name
-> Type tyname uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
LamAbs Ann
annMayInline Name
lamName PLCType DefaultUni
forall {tyname}. Type tyname DefaultUni Ann
defaultUnitTy (PLCType DefaultUni
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace PLCType DefaultUni
ty (Text
"exiting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
displayName) Term TyName Name DefaultUni DefaultFun Ann
e))
)
Term TyName Name DefaultUni DefaultFun Ann
forall {tyname} {name} {fun}. Term tyname name DefaultUni fun Ann
defaultUnit
compileExpr ::
(CompilingDefault uni fun m ann) =>
GHC.CoreExpr ->
m (PIRTerm uni fun)
compileExpr :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
e = Int -> SDoc -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
2 (SDoc
"Compiling expr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr CoreExpr
e) (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ do
CompileContext{ccScope :: forall (uni :: * -> *) fun. CompileContext uni fun -> Scope uni
ccScope = Scope uni
scope, ccNameInfo :: forall (uni :: * -> *) fun. CompileContext uni fun -> NameInfo
ccNameInfo = NameInfo
nameInfo, ccModBreaks :: forall (uni :: * -> *) fun.
CompileContext uni fun -> Maybe ModBreaks
ccModBreaks = Maybe ModBreaks
maybeModBreaks, ccBuiltinsInfo :: forall (uni :: * -> *) fun.
CompileContext uni fun -> BuiltinsInfo uni fun
ccBuiltinsInfo = BuiltinsInfo uni fun
binfo} <- m (CompileContext uni fun)
forall r (m :: * -> *). MonadReader r m => m r
ask
TyCon
builtinIntegerTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinInteger NameInfo
nameInfo of
Just (GHC.ATyCon TyCon
builtinInteger) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinInteger
Maybe TyThing
_ -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Integer builtin"
TyCon
builtinBoolTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinBool NameInfo
nameInfo of
Just (GHC.ATyCon TyCon
builtinBool) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinBool
Maybe TyThing
_ -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Bool builtin"
TyCon
builtinDataTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinData NameInfo
nameInfo of
Just (GHC.ATyCon TyCon
builtinData) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinData
Maybe TyThing
_ -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Data builtin"
TyCon
builtinPairTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinPair NameInfo
nameInfo of
Just (GHC.ATyCon TyCon
builtinPair) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinPair
Maybe TyThing
_ -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Pair builtin"
(Name
stringTyName, Name
sbsName) <- case (Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinString NameInfo
nameInfo, Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup 'Builtins.stringToBuiltinString NameInfo
nameInfo) of
(Just TyThing
t1, Just TyThing
t2) -> (Name, Name) -> m (Name, Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t1, TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t2)
(Maybe TyThing, Maybe TyThing)
_ -> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (Name, Name))
-> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for String builtin"
(Name
bsTyName, Name
sbbsName) <- case (Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinByteString NameInfo
nameInfo, Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup 'Builtins.stringToBuiltinByteString NameInfo
nameInfo) of
(Just TyThing
t1, Just TyThing
t2) -> (Name, Name) -> m (Name, Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t1, TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t2)
(Maybe TyThing, Maybe TyThing)
_ -> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (Name, Name))
-> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for ByteString builtin"
Name
useToOpaqueName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'Builtins.useToOpaque
Name
useFromOpaqueName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'Builtins.useFromOpaque
Name
mkNilOpaqueName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'Builtins.mkNilOpaque
Name
boolOperatorOr <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing '(PlutusTx.Bool.||)
Name
boolOperatorAnd <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing '(PlutusTx.Bool.&&)
case CoreExpr
e of
GHC.App (GHC.App (GHC.Var Id
var) CoreExpr
a) CoreExpr
b | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
var Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
boolOperatorOr ->
CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr (CoreExpr -> m (PIRTerm uni fun))
-> CoreExpr -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
GHC.mkIfThenElse CoreExpr
a (Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
GHC.trueDataConId) CoreExpr
b
GHC.App (GHC.App (GHC.Var Id
var) CoreExpr
a) CoreExpr
b | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
var Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
boolOperatorAnd ->
CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr (CoreExpr -> m (PIRTerm uni fun))
-> CoreExpr -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
GHC.mkIfThenElse CoreExpr
a CoreExpr
b (Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
GHC.falseDataConId)
(CoreExpr -> CoreExpr
strip -> GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.ClassOpId Class
cls)) `GHC.App` GHC.Type Type
ty `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
content
| Class -> Name
forall a. NamedThing a => a -> Name
GHC.getName Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.isStringClassName ->
case Type -> Maybe TyCon
GHC.tyConAppTyCon_maybe Type
ty of
Just TyCon
tc -> case CoreExpr -> Maybe ByteString
stringExprContent (CoreExpr -> CoreExpr
strip CoreExpr
content) of
Just ByteString
bs ->
if
| TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
bsTyName -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ ByteString -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue ByteString
bs
| TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
stringTyName -> case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bs of
Right Text
t -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ Text -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue Text
t
Left UnicodeException
err ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> (Text -> Error DefaultUni DefaultFun ann)
-> Text
-> m (PIRTerm uni fun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (Text -> m (PIRTerm uni fun)) -> Text -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
Text
"Text literal with invalid UTF-8 content: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err)
| Bool
otherwise ->
(Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
SDoc
"Use of fromString on type other than builtin strings or bytestrings:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
ty
Maybe ByteString
Nothing ->
(Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
SDoc
"Use of fromString with inscrutable content:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr CoreExpr
content
Maybe TyCon
Nothing ->
(Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
SDoc
"Use of fromString on type other than builtin strings or bytestrings:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
ty
(CoreExpr -> CoreExpr
strip -> GHC.Var Id
n) `GHC.App` (CoreExpr -> CoreExpr
strip -> CoreExpr -> Maybe ByteString
stringExprContent -> Just ByteString
bs)
| Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sbbsName ->
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ ByteString -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue ByteString
bs
(CoreExpr -> CoreExpr
strip -> GHC.Var Id
n) `GHC.App` (CoreExpr -> CoreExpr
strip -> CoreExpr -> Maybe ByteString
stringExprContent -> Just ByteString
bs) | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sbsName ->
case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bs of
Right Text
t -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ Text -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue Text
t
Left UnicodeException
err ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (Text -> Error DefaultUni DefaultFun ann)
-> Text -> Error DefaultUni DefaultFun ann
forall a b. (a -> b) -> a -> b
$
Text
"Text literal with invalid UTF-8 content: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err)
GHC.Lit Literal
lit -> Literal -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Literal -> m (PIRTerm uni fun)
compileLiteral Literal
lit
GHC.Var Id
n `GHC.App` CoreExpr
expr | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringName -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
expr
GHC.Var Id
build `GHC.App` CoreExpr
_ `GHC.App` GHC.Lam Id
_ (GHC.Var Id
unpack `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
expr)
| Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
build Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.buildName Bool -> Bool -> Bool
&& Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
unpack Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringFoldrName -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
expr
GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) `GHC.App` CoreExpr
arg | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
GHC.charDataCon -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) `GHC.App` CoreExpr
arg | DataCon -> TyCon
GHC.dataConTyCon DataCon
dc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
GHC.integerTyCon -> do
PIRTerm uni fun
i <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
if DataCon -> Name
GHC.dataConName DataCon
dc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.integerINDataConName
then do
PIRTerm uni fun
negateTerm <- m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
lookupIntegerNegate
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ PIRTerm uni fun -> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PIR.mkIterApp PIRTerm uni fun
negateTerm [(Ann
annMayInline, PIRTerm uni fun
i)]
else PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
i
GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
GHC.unboxedUnitDataCon -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ann -> () -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PIR.mkConstant Ann
annMayInline ())
GHC.Var Id
n `GHC.App` GHC.Type Type
_ `GHC.App` CoreExpr
arg | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.noinlineIdName -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
GHC.Var (Id -> Bool
isErrorId -> Bool
True) `GHC.App` CoreExpr
_ `GHC.App` GHC.Type Type
t `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
_ ->
Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
errorFunc m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
GHC.Var (Id -> Bool
isErrorId -> Bool
True) `GHC.App` CoreExpr
_ `GHC.App` GHC.Type Type
t `GHC.App` CoreExpr
_ ->
Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
errorFunc m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
GHC.Var (Id -> Bool
isErrorId -> Bool
True) `GHC.App` GHC.Type Type
t `GHC.App` CoreExpr
_ ->
Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
errorFunc m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
GHC.Var Id
n `GHC.App` GHC.Type Type
ty
| Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
mkNilOpaqueName -> case Type
ty of
GHC.TyConApp TyCon
tyCon []
| TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
GHC.integerTyCon Bool -> Bool -> Bool
|| TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
builtinIntegerTyCon ->
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [Integer] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @Integer)
| TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
builtinBoolTyCon -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [Bool] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @Bool)
| TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
builtinDataTyCon -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [Data] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @PLC.Data)
GHC.TyConApp TyCon
tyCon [GHC.TyConApp TyCon
tyArg1 [], GHC.TyConApp TyCon
tyArg2 []]
| (TyCon
tyCon, TyCon
tyArg1, TyCon
tyArg2) (TyCon, TyCon, TyCon) -> (TyCon, TyCon, TyCon) -> Bool
forall a. Eq a => a -> a -> Bool
== (TyCon
builtinPairTyCon, TyCon
builtinDataTyCon, TyCon
builtinDataTyCon) ->
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [(Data, Data)] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @(PLC.Data, PLC.Data))
Type
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"'mkNil' applied to an unknown type"
GHC.Var Id
n
| Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
useToOpaqueName ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"It is no longer possible to use 'toBuiltin' with a script, use 'toOpaque' instead"
GHC.Var Id
n
| Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
useFromOpaqueName ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"It is no longer possible to use 'fromBuiltin' with a script, use 'fromOpaque' instead"
GHC.Var Id
n
| Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.eqName ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Use of == from the Haskell Eq typeclass"
GHC.Var Id
n
| Id -> Bool
isProbablyIntegerEq Id
n ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Use of Haskell Integer equality, possibly via the Haskell Eq typeclass"
GHC.Var Id
n
| Id -> Bool
isProbablyBytestringEq Id
n ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Use of Haskell ByteString equality, possibly via the Haskell Eq typeclass"
GHC.Var Id
n
| Id -> Bool
isProbablyBoundedRange Id
n ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (Text -> Error DefaultUni DefaultFun ann)
-> Text -> Error DefaultUni DefaultFun ann
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"Use of enumFromTo or enumFromThenTo, possibly via range syntax. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Please use PlutusTx.Enum.enumFromTo or PlutusTx.Enum.enumFromThenTo instead.")
GHC.Var Id
n
| Id -> Bool
isProbablyUnboundedRange Id
n ->
Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (Text -> Error DefaultUni DefaultFun ann)
-> Text -> Error DefaultUni DefaultFun ann
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"Use of enumFrom or enumFromThen, possibly via range syntax. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Unbounded ranges are not supported.")
GHC.Var (Scope uni -> Name -> Maybe (PLCVar uni)
forall (uni :: * -> *). Scope uni -> Name -> Maybe (PLCVar uni)
lookupName Scope uni
scope (Name -> Maybe (PLCVar uni))
-> (Id -> Name) -> Id -> Maybe (PLCVar uni)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Just PLCVar uni
var) -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> PLCVar uni -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> VarDecl tyname name uni ann -> term ann
PIR.mkVar Ann
annMayInline PLCVar uni
var
GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) -> DataCon -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
DataCon -> m (PIRTerm uni fun)
compileDataConRef DataCon
dc
GHC.Var n :: Id
n@(Id -> IdDetails
GHC.idDetails -> GHC.ClassOpId Class
cls) -> do
let sel_names :: [Name]
sel_names = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName (Class -> [Id]
GHC.classAllSelIds Class
cls)
Int
val_index <- case Name -> [Name] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n) [Name]
sel_names of
Just Int
i -> Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
Maybe Int
Nothing -> (Text -> Error DefaultUni DefaultFun ann) -> SDoc -> m Int
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m Int) -> SDoc -> m Int
forall a b. (a -> b) -> a -> b
$ SDoc
"Id not in class method list:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Id
n
let rhs :: CoreExpr
rhs = Class -> Int -> CoreExpr
GHC.mkDictSelRhs Class
cls Int
val_index
Id -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> CoreExpr -> m (PIRTerm uni fun)
hoistExpr Id
n CoreExpr
rhs
GHC.Var Id
n -> do
let lexName :: LexName
lexName = Name -> LexName
LexName (Name -> LexName) -> Name -> LexName
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n
(Set LexName -> Set LexName) -> m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
(Set LexName -> Set LexName) -> m ()
modifyCurDeps (\Set LexName
d -> LexName -> Set LexName -> Set LexName
forall a. Ord a => a -> Set a -> Set a
Set.insert LexName
lexName Set LexName
d)
Maybe (PIRTerm uni fun)
maybeDef <- Ann -> LexName -> m (Maybe (PIRTerm uni fun))
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
ann -> key -> m (Maybe (Term TyName Name uni fun ann))
PIR.lookupTerm Ann
annMayInline LexName
lexName
case Maybe (PIRTerm uni fun)
maybeDef of
Just PIRTerm uni fun
term -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
term
Maybe (PIRTerm uni fun)
Nothing ->
case Unfolding -> Maybe CoreExpr
GHC.maybeUnfoldingTemplate (Id -> Unfolding
GHC.realIdUnfolding Id
n) of
Just CoreExpr
unfolding -> Id -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> CoreExpr -> m (PIRTerm uni fun)
hoistExpr Id
n CoreExpr
unfolding
Maybe CoreExpr
Nothing ->
(Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
FreeVariableError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
SDoc
"Variable"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Id
n
SDoc -> SDoc -> SDoc
GHC.$+$ (IdDetails -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr (IdDetails -> SDoc) -> IdDetails -> SDoc
forall a b. (a -> b) -> a -> b
$ Id -> IdDetails
GHC.idDetails Id
n)
SDoc -> SDoc -> SDoc
GHC.$+$ (Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr (Unfolding -> SDoc) -> Unfolding -> SDoc
forall a b. (a -> b) -> a -> b
$ Id -> Unfolding
GHC.realIdUnfolding Id
n)
CoreExpr
l `GHC.App` GHC.Type Type
t ->
if Type -> Bool
GHC.isRuntimeRepKindedTy Type
t
then CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
l
else Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
l m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
CoreExpr
l `GHC.App` CoreExpr
arg -> Ann -> PIRTerm uni fun -> PIRTerm uni fun -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Apply Ann
annMayInline (PIRTerm uni fun -> PIRTerm uni fun -> PIRTerm uni fun)
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
l m (PIRTerm uni fun -> PIRTerm uni fun)
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
GHC.Lam b :: Id
b@(Id -> Bool
GHC.isTyVar -> Bool
True) CoreExpr
body ->
if Type -> Bool
GHC.isRuntimeRepTy (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Type
GHC.varType Id
b
then CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
else Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
mkTyAbsScoped Id
b (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
GHC.Lam Id
b CoreExpr
body -> Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
mkLamAbsScoped Id
b (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
GHC.Let (GHC.NonRec Id
b CoreExpr
rhs) CoreExpr
body -> do
PIRTerm DefaultUni fun
rhs' <- CoreExpr -> m (PIRTerm DefaultUni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
rhs
PLCType DefaultUni
ty <- case CoreExpr
rhs of
GHC.Lit (GHC.LitNumber{}) | Type -> Type -> Bool
GHC.eqType (Id -> Type
GHC.varType Id
b) Type
GHC.byteArrayPrimTy ->
PLCType DefaultUni -> m (PLCType DefaultUni)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PLCType DefaultUni -> m (PLCType DefaultUni))
-> PLCType DefaultUni -> m (PLCType DefaultUni)
forall a b. (a -> b) -> a -> b
$ forall a (x :: a) (uni :: * -> *) ann tyname.
HasTypeLevel uni x =>
ann -> Type tyname uni ann
PIR.mkTyBuiltin @_ @Integer @PLC.DefaultUni Ann
annMayInline
CoreExpr
_ -> Type -> m (PLCType DefaultUni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm (Type -> m (PLCType DefaultUni)) -> Type -> m (PLCType DefaultUni)
forall a b. (a -> b) -> a -> b
$ Id -> Type
GHC.varType Id
b
Id
-> PLCType DefaultUni
-> (VarDecl TyName Name DefaultUni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
Id -> PIRType uni -> (VarDecl TyName Name uni Ann -> m a) -> m a
withVarTyScoped Id
b PLCType DefaultUni
ty ((VarDecl TyName Name DefaultUni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun))
-> (VarDecl TyName Name DefaultUni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \VarDecl TyName Name DefaultUni Ann
v -> do
PIRTerm DefaultUni fun
rhs'' <- VarDecl TyName Name DefaultUni Ann
-> PIRTerm DefaultUni fun -> m (PIRTerm DefaultUni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs VarDecl TyName Name DefaultUni Ann
v PIRTerm DefaultUni fun
rhs'
let binds :: NonEmpty (Binding TyName Name DefaultUni fun Ann)
binds = Binding TyName Name DefaultUni fun Ann
-> NonEmpty (Binding TyName Name DefaultUni fun Ann)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding TyName Name DefaultUni fun Ann
-> NonEmpty (Binding TyName Name DefaultUni fun Ann))
-> Binding TyName Name DefaultUni fun Ann
-> NonEmpty (Binding TyName Name DefaultUni fun Ann)
forall a b. (a -> b) -> a -> b
$ Ann
-> Strictness
-> VarDecl TyName Name DefaultUni Ann
-> PIRTerm DefaultUni fun
-> Binding TyName Name DefaultUni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict VarDecl TyName Name DefaultUni Ann
v PIRTerm DefaultUni fun
rhs''
PIRTerm uni fun
body' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> NonEmpty (Binding TyName Name uni fun Ann)
-> PIRTerm uni fun
-> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Recursivity
-> NonEmpty (Binding tyname name uni fun a)
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Let Ann
annMayInline Recursivity
PIR.NonRec NonEmpty (Binding TyName Name uni fun Ann)
NonEmpty (Binding TyName Name DefaultUni fun Ann)
binds PIRTerm uni fun
body'
GHC.Let (GHC.Rec [(Id, CoreExpr)]
bs) CoreExpr
body ->
[Id]
-> ([PLCVar uni] -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
[Id] -> ([VarDecl TyName Name uni Ann] -> m a) -> m a
withVarsScoped (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
bs) (([PLCVar uni] -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun))
-> ([PLCVar uni] -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \[PLCVar uni]
vars -> do
[Binding TyName Name uni fun Ann]
binds <- [(PLCVar uni, (Id, CoreExpr))]
-> ((PLCVar uni, (Id, CoreExpr))
-> m (Binding TyName Name uni fun Ann))
-> m [Binding TyName Name uni fun Ann]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([PLCVar uni] -> [(Id, CoreExpr)] -> [(PLCVar uni, (Id, CoreExpr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [PLCVar uni]
vars [(Id, CoreExpr)]
bs) (((PLCVar uni, (Id, CoreExpr))
-> m (Binding TyName Name uni fun Ann))
-> m [Binding TyName Name uni fun Ann])
-> ((PLCVar uni, (Id, CoreExpr))
-> m (Binding TyName Name uni fun Ann))
-> m [Binding TyName Name uni fun Ann]
forall a b. (a -> b) -> a -> b
$ \(PLCVar uni
v, (Id
_, CoreExpr
rhs)) -> do
PIRTerm uni fun
rhs' <- PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs PLCVar uni
v (PIRTerm uni fun -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
rhs
Binding TyName Name uni fun Ann
-> m (Binding TyName Name uni fun Ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding TyName Name uni fun Ann
-> m (Binding TyName Name uni fun Ann))
-> Binding TyName Name uni fun Ann
-> m (Binding TyName Name uni fun Ann)
forall a b. (a -> b) -> a -> b
$ Ann
-> Strictness
-> PLCVar uni
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict PLCVar uni
v PIRTerm uni fun
rhs'
PIRTerm uni fun
body' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> [Binding TyName Name uni fun Ann]
-> PIRTerm uni fun
-> PIRTerm uni fun
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.mkLet Ann
annMayInline Recursivity
PIR.Rec [Binding TyName Name uni fun Ann]
binds PIRTerm uni fun
body'
GHC.Case CoreExpr
scrutinee Id
b Type
t [CoreAlt]
alts ->
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
compileCase (Bool -> CoreExpr -> Bool
forall a b. a -> b -> a
const (Bool -> CoreExpr -> Bool)
-> (Id -> Bool) -> Id -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccInfo -> Bool
GHC.isDeadOcc (OccInfo -> Bool) -> (Id -> OccInfo) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> OccInfo
GHC.occInfo (IdInfo -> OccInfo) -> (Id -> IdInfo) -> Id -> OccInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
GHC.idInfo) Bool
True BuiltinsInfo uni fun
binfo CoreExpr
scrutinee Id
b Type
t [CoreAlt]
alts
GHC.Tick CoreTickish
tick CoreExpr
body | Just RealSrcSpan
src <- Maybe ModBreaks -> CoreTickish -> Maybe RealSrcSpan
forall {pass :: TickishPass}.
Maybe ModBreaks -> GenTickish pass -> Maybe RealSrcSpan
getSourceSpan Maybe ModBreaks
maybeModBreaks CoreTickish
tick ->
Int -> SDoc -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
1 (SDoc
"Compiling expr at:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr RealSrcSpan
src) (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ do
CompileContext{ccOpts :: forall (uni :: * -> *) fun.
CompileContext uni fun -> CompileOptions
ccOpts = CompileOptions
coverageOpts} <- m (CompileContext DefaultUni DefaultFun)
forall r (m :: * -> *). MonadReader r m => m r
ask
let anns :: [CoverageType]
anns = Set CoverageType -> [CoverageType]
forall a. Set a -> [a]
Set.toList (Set CoverageType -> [CoverageType])
-> Set CoverageType -> [CoverageType]
forall a b. (a -> b) -> a -> b
$ CompileOptions -> Set CoverageType
activeCoverageTypes CompileOptions
coverageOpts
PIRTerm uni fun
compiledBody <- (Ann -> Ann) -> PIRTerm uni fun -> PIRTerm uni fun
forall a b.
(a -> b)
-> Term TyName Name uni fun a -> Term TyName Name uni fun b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpan -> Ann -> Ann
addSrcSpan (SrcSpan -> Ann -> Ann) -> SrcSpan -> Ann -> Ann
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
src RealSrcSpan -> Getting SrcSpan RealSrcSpan SrcSpan -> SrcSpan
forall s a. s -> Getting a s a -> a
^. Getting SrcSpan RealSrcSpan SrcSpan
Iso' RealSrcSpan SrcSpan
srcSpanIso) (PIRTerm uni fun -> PIRTerm uni fun)
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
(PIRTerm uni fun -> CoverageType -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> [CoverageType] -> m (PIRTerm uni fun)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (CoreExpr
-> Type
-> RealSrcSpan
-> PIRTerm uni fun
-> CoverageType
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr
-> Type
-> RealSrcSpan
-> PIRTerm uni fun
-> CoverageType
-> m (PIRTerm uni fun)
coverageCompile CoreExpr
body ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
GHC.exprType CoreExpr
body) RealSrcSpan
src) PIRTerm uni fun
compiledBody [CoverageType]
anns
GHC.Tick CoreTickish
_ CoreExpr
body -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
GHC.Cast CoreExpr
body CoercionR
_ -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
GHC.Type Type
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Types as standalone expressions"
GHC.Coercion CoercionR
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Coercions as expressions"
compileCase ::
(CompilingDefault uni fun m ann) =>
(GHC.Var -> GHC.CoreExpr -> Bool) ->
Bool ->
BuiltinsInfo uni fun ->
GHC.CoreExpr ->
GHC.Var ->
GHC.Type ->
[GHC.CoreAlt] ->
m (PIRTerm uni fun)
compileCase :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
compileCase Id -> CoreExpr -> Bool
isDead Bool
rewriteConApps BuiltinsInfo uni fun
binfo CoreExpr
scrutinee Id
binder Type
t [CoreAlt]
alts = case [CoreAlt]
alts of
[GHC.Alt AltCon
con [Id]
bs CoreExpr
body]
| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Id -> CoreExpr -> Bool
`isDead` CoreExpr
body) [Id]
bs -> do
PIRTerm uni fun
scrutinee' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
scrutinee
Id
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
Id -> (VarDecl TyName Name uni Ann -> m a) -> m a
withVarScoped Id
binder ((VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun))
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \VarDecl TyName Name uni Ann
v -> do
PIRTerm uni fun
body' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
let binds :: [Binding TyName Name uni fun Ann]
binds = [Ann
-> Strictness
-> VarDecl TyName Name uni Ann
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.Strict VarDecl TyName Name uni Ann
v PIRTerm uni fun
scrutinee']
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> [Binding TyName Name uni fun Ann]
-> PIRTerm uni fun
-> PIRTerm uni fun
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.mkLet Ann
annMayInline Recursivity
PIR.NonRec [Binding TyName Name uni fun Ann]
binds PIRTerm uni fun
body'
| Bool
rewriteConApps
, GHC.DataAlt DataCon
dataCon <- AltCon
con -> do
let f :: CoreExpr -> CoreExpr
f (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
GHC.collectArgs -> (GHC.Var (Id -> Maybe DataCon
GHC.isDataConId_maybe -> Just DataCon
dataCon'), [CoreExpr]
args0))
| DataCon
dataCon DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
dataCon'
, let args :: [Id]
args = (CoreExpr -> Maybe Id) -> [CoreExpr] -> [Id]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case GHC.Var Id
v -> Id -> Maybe Id
forall a. a -> Maybe a
Just Id
v; CoreExpr
_ -> Maybe Id
forall a. Maybe a
Nothing) [CoreExpr]
args0
, [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args
, [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Id -> Id -> Bool) -> [Id] -> [Id] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Id]
bs [Id]
args) =
Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
binder
f CoreExpr
other = CoreExpr
other
isDead' :: a -> a -> Bool
isDead' a
b = Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b) ([a] -> Bool) -> (a -> [a]) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall from to. Biplate from to => from -> [to]
universeBi
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
compileCase Id -> CoreExpr -> Bool
forall {a} {a}. (Eq a, Data a, Data a) => a -> a -> Bool
isDead' Bool
False BuiltinsInfo uni fun
binfo CoreExpr
scrutinee Id
binder Type
t [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
GHC.Alt AltCon
con [Id]
bs ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall on. Uniplate on => (on -> on) -> on -> on
transform CoreExpr -> CoreExpr
f CoreExpr
body)]
[CoreAlt]
_ -> do
PIRTerm uni fun
scrutinee' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
scrutinee
let scrutineeType :: Type
scrutineeType = Id -> Type
GHC.varType Id
binder
Id
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
Id -> (VarDecl TyName Name uni Ann -> m a) -> m a
withVarScoped Id
binder ((VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun))
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \VarDecl TyName Name uni Ann
v -> do
(TyCon
tc, [Type]
argTys) <- case (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
GHC.splitTyConApp_maybe Type
scrutineeType of
Just (TyCon
tc, [Type]
argTys) -> (TyCon, [Type]) -> m (TyCon, [Type])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyCon
tc, [Type]
argTys)
Maybe (TyCon, [Type])
Nothing ->
(Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (TyCon, [Type])
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (SDoc -> m (TyCon, [Type])) -> SDoc -> m (TyCon, [Type])
forall a b. (a -> b) -> a -> b
$
SDoc
"Cannot case on a value of type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
scrutineeType
[DataCon]
dcs <- TyCon -> m [DataCon]
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
TyCon -> m [DataCon]
getDataCons TyCon
tc
PIRTerm uni fun
match <- Type -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRTerm uni fun)
getMatchInstantiated Type
scrutineeType
let matched :: PIRTerm uni fun
matched = Ann -> PIRTerm uni fun -> PIRTerm uni fun -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Apply Ann
annMayInline PIRTerm uni fun
match PIRTerm uni fun
scrutinee'
let ([CoreAlt]
rest, Maybe CoreExpr
mdef) = [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
GHC.findDefault [CoreAlt]
alts
([CoreAlt]
alts', PIRTerm uni fun
defCompiled) <- case Maybe CoreExpr
mdef of
Just CoreExpr
d -> do
PIRTerm uni fun
defCompiled <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
d
([CoreAlt], PIRTerm uni fun) -> m ([CoreAlt], PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CoreAlt] -> Maybe CoreExpr -> [CoreAlt]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
GHC.addDefault [CoreAlt]
rest (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
d), PIRTerm uni fun
defCompiled)
Maybe CoreExpr
Nothing -> do
#if MIN_VERSION_ghc(9,6,0)
let d :: CoreExpr
d = Type -> String -> CoreExpr
GHC.mkImpossibleExpr Type
t String
"unreachable alternative"
#else
let d = GHC.mkImpossibleExpr t
#endif
PIRTerm uni fun
defCompiled <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
d
([CoreAlt], PIRTerm uni fun) -> m ([CoreAlt], PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CoreAlt] -> Maybe CoreExpr -> [CoreAlt]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
GHC.addDefault [CoreAlt]
alts (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
d), PIRTerm uni fun
defCompiled)
Name
defName <- Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
PLC.freshName Text
"defaultBody"
[(PIRTerm uni fun, PIRTerm uni fun)]
compiledAlts <- [DataCon]
-> (DataCon -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m [(PIRTerm uni fun, PIRTerm uni fun)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcs ((DataCon -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m [(PIRTerm uni fun, PIRTerm uni fun)])
-> (DataCon -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m [(PIRTerm uni fun, PIRTerm uni fun)]
forall a b. (a -> b) -> a -> b
$ \DataCon
dc -> do
let alt :: Maybe CoreAlt
alt = AltCon -> [CoreAlt] -> Maybe CoreAlt
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
GHC.findAlt (DataCon -> AltCon
GHC.DataAlt DataCon
dc) [CoreAlt]
alts'
instArgTys :: [Type]
instArgTys = Scaled Type -> Type
forall a. Scaled a -> a
GHC.scaledThing (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> [Type] -> [Scaled Type]
GHC.dataConInstOrigArgTys DataCon
dc [Type]
argTys
case Maybe CoreAlt
alt of
Just CoreAlt
a -> do
(PIRTerm uni fun
nonDelayedAlt, PIRTerm uni fun
delayedAlt) <- CoreAlt
-> [Type]
-> PIRTerm uni fun
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreAlt
-> [Type]
-> PIRTerm uni fun
-> m (PIRTerm uni fun, PIRTerm uni fun)
compileAlt CoreAlt
a [Type]
instArgTys (Ann -> Name -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> name -> Term tyname name uni fun a
PIR.Var Ann
annMayInline Name
defName)
(PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PIRTerm uni fun
nonDelayedAlt, PIRTerm uni fun
delayedAlt)
Maybe CoreAlt
Nothing -> (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m (PIRTerm uni fun, PIRTerm uni fun))
-> SDoc -> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ SDoc
"No alternative for:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr DataCon
dc
let
isPureAlt :: [Bool]
isPureAlt = [(PIRTerm uni fun, PIRTerm uni fun)]
compiledAlts [(PIRTerm uni fun, PIRTerm uni fun)]
-> ((PIRTerm uni fun, PIRTerm uni fun) -> Bool) -> [Bool]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(PIRTerm uni fun
nonDelayed, PIRTerm uni fun
_) -> BuiltinsInfo uni fun
-> VarsInfo TyName Name uni Ann -> PIRTerm uni fun -> Bool
forall (uni :: * -> *) fun name tyname a.
(ToBuiltinMeaning uni fun, HasUnique name TermUnique) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni a -> Term tyname name uni fun a -> Bool
PIR.isPure BuiltinsInfo uni fun
binfo VarsInfo TyName Name uni Ann
forall a. Monoid a => a
mempty PIRTerm uni fun
nonDelayed
lazyCase :: Bool
lazyCase = Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
isPureAlt Bool -> Bool -> Bool
|| [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
dcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
branches :: [PIRTerm uni fun]
branches =
[(PIRTerm uni fun, PIRTerm uni fun)]
compiledAlts [(PIRTerm uni fun, PIRTerm uni fun)]
-> ((PIRTerm uni fun, PIRTerm uni fun) -> PIRTerm uni fun)
-> [PIRTerm uni fun]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(PIRTerm uni fun
nonDelayedAlt, PIRTerm uni fun
delayedAlt) ->
if Bool
lazyCase then PIRTerm uni fun
delayedAlt else PIRTerm uni fun
nonDelayedAlt
PIRType uni
originalResultType <- Type -> m (PIRType uni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
PIRType uni
resultType <- Bool -> PIRType uni -> m (PIRType uni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Bool -> PIRType uni -> m (PIRType uni)
maybeDelayType Bool
lazyCase PIRType uni
originalResultType
let instantiated :: PIRTerm uni fun
instantiated = Ann -> PIRTerm uni fun -> PIRType uni -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline PIRTerm uni fun
matched PIRType uni
resultType
let applied :: PIRTerm uni fun
applied = PIRTerm uni fun -> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PIR.mkIterApp PIRTerm uni fun
instantiated ([(Ann, PIRTerm uni fun)] -> PIRTerm uni fun)
-> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ (Ann
annMayInline,) (PIRTerm uni fun -> (Ann, PIRTerm uni fun))
-> [PIRTerm uni fun] -> [(Ann, PIRTerm uni fun)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PIRTerm uni fun]
branches
PIRTerm uni fun
mainCase <- Bool -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Bool -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeForce Bool
lazyCase PIRTerm uni fun
applied
let binds :: [Binding TyName Name uni fun Ann]
binds =
[
Ann
-> Strictness
-> VarDecl TyName Name uni Ann
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict VarDecl TyName Name uni Ann
v PIRTerm uni fun
scrutinee'
,
Ann
-> Strictness
-> VarDecl TyName Name uni Ann
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict (Ann -> Name -> PIRType uni -> VarDecl TyName Name uni Ann
forall tyname name (uni :: * -> *) ann.
ann -> name -> Type tyname uni ann -> VarDecl tyname name uni ann
PIR.VarDecl Ann
annMayInline Name
defName PIRType uni
originalResultType) PIRTerm uni fun
defCompiled
]
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> [Binding TyName Name uni fun Ann]
-> PIRTerm uni fun
-> PIRTerm uni fun
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.mkLet Ann
annMayInline Recursivity
PIR.NonRec [Binding TyName Name uni fun Ann]
binds PIRTerm uni fun
mainCase
getSourceSpan :: Maybe GHC.ModBreaks -> _ -> Maybe GHC.RealSrcSpan
getSourceSpan :: Maybe ModBreaks -> GenTickish pass -> Maybe RealSrcSpan
getSourceSpan Maybe ModBreaks
_ GHC.SourceNote{sourceSpan :: forall (pass :: TickishPass). GenTickish pass -> RealSrcSpan
GHC.sourceSpan = RealSrcSpan
src} = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
src
getSourceSpan Maybe ModBreaks
_ GHC.ProfNote{profNoteCC :: forall (pass :: TickishPass). GenTickish pass -> CostCentre
GHC.profNoteCC = CostCentre
cc} =
case CostCentre
cc of
GHC.NormalCC CCFlavour
_ CcName
_ Module
_ (GHC.RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_) -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
sp
GHC.AllCafsCC Module
_ (GHC.RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_) -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
sp
CostCentre
_ -> Maybe RealSrcSpan
forall a. Maybe a
Nothing
getSourceSpan Maybe ModBreaks
mmb GHC.HpcTick{tickId :: forall (pass :: TickishPass). GenTickish pass -> Int
GHC.tickId = Int
tid} = do
ModBreaks
mb <- Maybe ModBreaks
mmb
let arr :: Array Int SrcSpan
arr = ModBreaks -> Array Int SrcSpan
GHC.modBreaks_locs ModBreaks
mb
range :: (Int, Int)
range = Array Int SrcSpan -> (Int, Int)
forall i e. Array i e -> (i, i)
Array.bounds Array Int SrcSpan
arr
GHC.RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_ <- if (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
Array.inRange (Int, Int)
range Int
tid then SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpan -> Maybe SrcSpan) -> SrcSpan -> Maybe SrcSpan
forall a b. (a -> b) -> a -> b
$ Array Int SrcSpan
arr Array Int SrcSpan -> Int -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
Array.! Int
tid else Maybe SrcSpan
forall a. Maybe a
Nothing
RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return RealSrcSpan
sp
getSourceSpan Maybe ModBreaks
_ GenTickish pass
_ = Maybe RealSrcSpan
forall a. Maybe a
Nothing
getVarSourceSpan :: GHC.Var -> Maybe GHC.RealSrcSpan
getVarSourceSpan :: Id -> Maybe RealSrcSpan
getVarSourceSpan = SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan)
-> (Id -> SrcSpan) -> Id -> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SrcSpan
GHC.nameSrcSpan (Name -> SrcSpan) -> (Id -> Name) -> Id -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
GHC.varName
srcSpanIso :: Iso' GHC.RealSrcSpan SrcSpan
srcSpanIso :: Iso' RealSrcSpan SrcSpan
srcSpanIso = (RealSrcSpan -> SrcSpan)
-> (SrcSpan -> RealSrcSpan) -> Iso' RealSrcSpan SrcSpan
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso RealSrcSpan -> SrcSpan
fromGHC SrcSpan -> RealSrcSpan
toGHC
where
fromGHC :: RealSrcSpan -> SrcSpan
fromGHC RealSrcSpan
sp =
SrcSpan
{ srcSpanFile :: String
srcSpanFile = CcName -> String
GHC.unpackFS (RealSrcSpan -> CcName
GHC.srcSpanFile RealSrcSpan
sp)
, srcSpanSLine :: Int
srcSpanSLine = RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
sp
, srcSpanSCol :: Int
srcSpanSCol = RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
sp
, srcSpanELine :: Int
srcSpanELine = RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
sp
, srcSpanECol :: Int
srcSpanECol = RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
sp
}
toGHC :: SrcSpan -> RealSrcSpan
toGHC SrcSpan
sp =
RealSrcLoc -> RealSrcLoc -> RealSrcSpan
GHC.mkRealSrcSpan
(CcName -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (SrcSpan -> CcName
fileNameFs SrcSpan
sp) (SrcSpan -> Int
srcSpanSLine SrcSpan
sp) (SrcSpan -> Int
srcSpanSCol SrcSpan
sp))
(CcName -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (SrcSpan -> CcName
fileNameFs SrcSpan
sp) (SrcSpan -> Int
srcSpanELine SrcSpan
sp) (SrcSpan -> Int
srcSpanECol SrcSpan
sp))
fileNameFs :: SrcSpan -> CcName
fileNameFs = String -> CcName
GHC.fsLit (String -> CcName) -> (SrcSpan -> String) -> SrcSpan -> CcName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String
srcSpanFile
toCovLoc :: GHC.RealSrcSpan -> CovLoc
toCovLoc :: RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
sp =
String -> Int -> Int -> Int -> Int -> CovLoc
CovLoc
(CcName -> String
GHC.unpackFS (CcName -> String) -> CcName -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> CcName
GHC.srcSpanFile RealSrcSpan
sp)
(RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
sp)
(RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
sp)
(RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
sp)
(RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
sp)
coverageCompile ::
(CompilingDefault uni fun m ann) =>
GHC.CoreExpr ->
GHC.Type ->
GHC.RealSrcSpan ->
PIRTerm uni fun ->
CoverageType ->
m (PIRTerm uni fun)
coverageCompile :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr
-> Type
-> RealSrcSpan
-> PIRTerm uni fun
-> CoverageType
-> m (PIRTerm uni fun)
coverageCompile CoreExpr
originalExpr Type
exprType RealSrcSpan
src PIRTerm uni fun
compiledTerm CoverageType
covT =
case CoverageType
covT of
CoverageType
LocationCoverage -> do
CoverageAnnotation
ann <- CovLoc -> m CoverageAnnotation
forall (m :: * -> *).
MonadWriter CoverageIndex m =>
CovLoc -> m CoverageAnnotation
addLocationToCoverageIndex (RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
src)
PIRType uni
ty <- Type -> m (PIRType uni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
exprType
PIRType uni
-> Text -> PIRTerm uni DefaultFun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> m (PIRTerm uni fun)
mkLazyTrace PIRType uni
ty (String -> Text
T.pack (String -> Text)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> String
forall a. Show a => a -> String
show (CoverageAnnotation -> Text) -> CoverageAnnotation -> Text
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation
ann) PIRTerm uni fun
PIRTerm uni DefaultFun
compiledTerm
CoverageType
BooleanCoverage -> do
TyThing
bool <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing ''Bool
TyThing
true <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'True
TyThing
false <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'False
let tyHeadName :: Maybe Name
tyHeadName = TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyCon -> Name) -> Maybe TyCon -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe TyCon
GHC.tyConAppTyCon_maybe Type
exprType
headSymName :: Maybe Name
headSymName = Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName (Id -> Name) -> Maybe Id -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
originalExpr
isTrueOrFalse :: Bool
isTrueOrFalse = case CoreExpr
originalExpr of
GHC.Var Id
v
| GHC.DataConWorkId DataCon
dc <- Id -> IdDetails
GHC.idDetails Id
v ->
DataCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName DataCon
dc Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
c | TyThing
c <- [TyThing
true, TyThing
false]]
CoreExpr
_ -> Bool
False
if Maybe Name
tyHeadName Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
bool) Bool -> Bool -> Bool
|| Bool
isTrueOrFalse
then PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PIRTerm uni fun
compiledTerm
else
do
TyThing
traceBoolThing <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'traceBool
case TyThing
traceBoolThing of
GHC.AnId Id
traceBoolId -> do
PIRTerm uni fun
traceBoolCompiled <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr (CoreExpr -> m (PIRTerm uni fun))
-> CoreExpr -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
traceBoolId
let mkMetadata :: Maybe Name -> CoverageMetadata
mkMetadata = Set Metadata -> CoverageMetadata
CoverageMetadata (Set Metadata -> CoverageMetadata)
-> (Maybe Name -> Set Metadata) -> Maybe Name -> CoverageMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Set Metadata) -> Maybe Name -> Set Metadata
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Metadata -> Set Metadata
forall a. a -> Set a
Set.singleton (Metadata -> Set Metadata)
-> (Name -> Metadata) -> Name -> Set Metadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Metadata
ApplicationHeadSymbol (String -> Metadata) -> (Name -> String) -> Name -> Metadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. NamedThing a => a -> String
GHC.getOccString)
CoverageAnnotation
fc <- CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
forall (m :: * -> *).
MonadWriter CoverageIndex m =>
CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
addBoolCaseToCoverageIndex (RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
src) Bool
False (Maybe Name -> CoverageMetadata
mkMetadata Maybe Name
headSymName)
CoverageAnnotation
tc <- CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
forall (m :: * -> *).
MonadWriter CoverageIndex m =>
CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
addBoolCaseToCoverageIndex (RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
src) Bool
True (Maybe Name -> CoverageMetadata
mkMetadata Maybe Name
headSymName)
PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
PIRTerm uni fun -> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PLC.mkIterApp PIRTerm uni fun
traceBoolCompiled ([(Ann, PIRTerm uni fun)] -> PIRTerm uni fun)
-> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$
(Ann
annMayInline,)
(PIRTerm uni fun -> (Ann, PIRTerm uni fun))
-> [PIRTerm uni fun] -> [(Ann, PIRTerm uni fun)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Ann -> Text -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline (String -> Text
T.pack (String -> Text)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> String
forall a. Show a => a -> String
show (CoverageAnnotation -> Text) -> CoverageAnnotation -> Text
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation
tc)
, Ann -> Text -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline (String -> Text
T.pack (String -> Text)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> String
forall a. Show a => a -> String
show (CoverageAnnotation -> Text) -> CoverageAnnotation -> Text
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation
fc)
, PIRTerm uni fun
compiledTerm
]
TyThing
_ ->
(Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
SDoc
"Lookup of traceBool failed. Expected to get AnId but saw: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr TyThing
traceBoolThing
where
findHeadSymbol :: GHC.CoreExpr -> Maybe GHC.Id
findHeadSymbol :: CoreExpr -> Maybe Id
findHeadSymbol (GHC.Var Id
n) = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
n
findHeadSymbol (GHC.App CoreExpr
t CoreExpr
_) = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
findHeadSymbol (GHC.Lam Id
_ CoreExpr
t) = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
findHeadSymbol (GHC.Tick CoreTickish
_ CoreExpr
t) = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
findHeadSymbol (GHC.Let Bind Id
_ CoreExpr
t) = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
findHeadSymbol (GHC.Cast CoreExpr
t CoercionR
_) = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
findHeadSymbol CoreExpr
_ = Maybe Id
forall a. Maybe a
Nothing
defineIntegerNegate :: (CompilingDefault PLC.DefaultUni fun m ann) => m ()
defineIntegerNegate :: forall fun (m :: * -> *) ann.
CompilingDefault DefaultUni fun m ann =>
m ()
defineIntegerNegate = do
Id
ghcId <- (() :: Constraint) => TyThing -> Id
TyThing -> Id
GHC.tyThingId (TyThing -> Id) -> m TyThing -> m Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'GHC.Num.Integer.integerNegate
VarDecl TyName Name DefaultUni Ann
var <- Ann -> Id -> m (VarDecl TyName Name DefaultUni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Ann -> Id -> m (PLCVar uni)
compileVarFresh Ann
annAlwaysInline Id
ghcId
let ann :: Ann
ann = Ann
annMayInline
Name
x <- Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
safeFreshName Text
"x"
let
body :: Term TyName Name DefaultUni DefaultFun Ann
body =
Ann
-> Name
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> name
-> Type tyname uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.LamAbs Ann
ann Name
x (forall a (x :: a) (uni :: * -> *) ann tyname.
HasTypeLevel uni x =>
ann -> Type tyname uni ann
PIR.mkTyBuiltin @_ @Integer @PLC.DefaultUni Ann
ann) (Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$
Term TyName Name DefaultUni DefaultFun Ann
-> [(Ann, Term TyName Name DefaultUni DefaultFun Ann)]
-> Term TyName Name DefaultUni DefaultFun Ann
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PIR.mkIterApp
(Ann -> DefaultFun -> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a -> fun -> Term tyname name uni fun a
PIR.Builtin Ann
ann DefaultFun
PLC.SubtractInteger)
[ (Ann
ann, forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PIR.mkConstant @Integer Ann
ann Integer
0)
, (Ann
ann, Ann -> Name -> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a -> name -> Term tyname name uni fun a
PIR.Var Ann
ann Name
x)
]
def :: TermDefWithStrictness DefaultUni DefaultFun Ann
def = VarDecl TyName Name DefaultUni Ann
-> (Term TyName Name DefaultUni DefaultFun Ann, Strictness)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall var val. var -> val -> Def var val
PIR.Def VarDecl TyName Name DefaultUni Ann
var (Term TyName Name DefaultUni DefaultFun Ann
body, Strictness
PIR.Strict)
LexName
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> Set LexName
-> m ()
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
key -> TermDefWithStrictness uni fun ann -> Set key -> m ()
PIR.defineTerm (Name -> LexName
LexName Name
GHC.integerNegateName) TermDefWithStrictness DefaultUni DefaultFun Ann
def Set LexName
forall a. Monoid a => a
mempty
lookupIntegerNegate :: (Compiling uni fun m ann) => m (PIRTerm uni fun)
lookupIntegerNegate :: forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
lookupIntegerNegate = do
Name
ghcName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'GHC.Num.Integer.integerNegate
Ann -> LexName -> m (Maybe (PIRTerm uni fun))
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
ann -> key -> m (Maybe (Term TyName Name uni fun ann))
PIR.lookupTerm Ann
annMayInline (Name -> LexName
LexName Name
ghcName) m (Maybe (PIRTerm uni fun))
-> (Maybe (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just PIRTerm uni fun
t -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
t
Maybe (PIRTerm uni fun)
Nothing -> Error uni fun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error uni fun ann -> m (PIRTerm uni fun))
-> Error uni fun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
Text -> Error uni fun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"Cannot find the definition of integerNegate. Please file a bug report."
compileExprWithDefs ::
(CompilingDefault uni fun m ann) =>
GHC.CoreExpr ->
m (PIRTerm uni fun)
compileExprWithDefs :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExprWithDefs CoreExpr
e = do
m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
m ()
defineBuiltinTypes
m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
m ()
defineBuiltinTerms
m ()
forall fun (m :: * -> *) ann.
CompilingDefault DefaultUni fun m ann =>
m ()
defineIntegerNegate
CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
e