{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module ConCat.BuildDictionary
(buildDictionary
,WithType
,withType, withExplicitType
,varWithType
,uniqSetToList
,annotateEvidence
) where
import Data.Monoid (Any(..))
import Data.Char (isSpace)
import Control.Monad (filterM,when)
import Control.Arrow (second)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import GHC.Core.Predicate
import GHC.Core.TyCo.Rep (CoercionHole(..), Type(..))
import GHC.Core.TyCon (isTupleTyCon)
import GHC.HsToCore.Binds
import GHC.HsToCore.Monad
import GHC.Plugins
import GHC.Tc.Errors(warnAllUnsolved)
import GHC.Tc.Module
import GHC.Tc.Solver
import GHC.Tc.Solver.Interact (solveSimpleGivens)
import GHC.Tc.Solver.Monad
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence (evBindMapBinds)
import GHC.Tc.Types.Origin
import qualified GHC.Tc.Utils.Instantiate as TcMType
import GHC.Tc.Utils.Monad (getCtLocM,traceTc)
import GHC.Tc.Utils.Zonk (emptyZonkEnv,zonkEvBinds)
import GHC.Types.Unique (mkUniqueGrimily)
import qualified GHC.Types.Unique.Set as NonDetSet
import GHC.Core.FVs (exprFreeVars)
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
import GHC.Runtime.Eval.Types (IcGlobalRdrEnv(..))
import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Core.InstEnv (mkInstEnv)
import GHC.Data.Maybe (expectJust)
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Runtime.Context (InteractiveContext (..), InteractiveImport (..))
import GHC.Types.Error (getErrorMessages, getWarningMessages)
import GHC.Unit.Finder (FindResult (..), findExposedPackageModule)
import GHC.Unit.Module.Deps (Dependencies (..))
import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc)
#else
import GHC.Driver.Finder (findExposedPackageModule)
import GHC.Utils.Error (pprErrMsgBagWithLoc)
#endif
#else
import GhcPlugins
import TyCoRep (CoercionHole(..), Type(..))
import TyCon (isTupleTyCon)
import TcHsSyn (emptyZonkEnv,zonkEvBinds)
import TcRnMonad (getCtLocM,traceTc)
import Constraint
import TcOrigin
import Predicate
import TcInteract (solveSimpleGivens)
import TcSMonad
import TcEvidence (evBindMapBinds)
import TcErrors(warnAllUnsolved)
import qualified TcMType as TcMType
import DsMonad
import DsBinds
import TcSimplify
import TcRnTypes
import ErrUtils (pprErrMsgBagWithLoc)
import Unique (mkUniqueGrimily)
import Finder (findExposedPackageModule)
import TcRnDriver
import qualified UniqSet as NonDetSet
#endif
import ConCat.Simplify
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
import GHC.Utils.Trace
#endif
isEvVarType' :: Type -> Bool
isEvVarType' :: Type -> Bool
isEvVarType' = Type -> Bool
isEvVarType
isFound :: FindResult -> Bool
isFound :: FindResult -> Bool
isFound (Found ModLocation
_ Module
_) = Bool
True
isFound FindResult
_ = Bool
False
moduleIsOkay :: HscEnv -> DynFlags -> ModuleName -> IO Bool
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
moduleIsOkay :: HscEnv -> DynFlags -> ModuleName -> IO Bool
moduleIsOkay HscEnv
env DynFlags
dflags ModuleName
mname =
FindResult -> Bool
isFound (FindResult -> Bool) -> IO FindResult -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinderCache
-> FinderOpts
-> UnitState
-> ModuleName
-> PkgQual
-> IO FindResult
findExposedPackageModule (HscEnv -> FinderCache
hsc_FC HscEnv
env) (DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags) ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
env) ModuleName
mname PkgQual
NoPkgQual
#else
moduleIsOkay env _dflags mname = isFound <$> findExposedPackageModule env mname Nothing
#endif
mkLocalId' :: HasDebugCallStack => Name -> Type -> Id
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
mkLocalId' :: (() :: Constraint) => Name -> Type -> Var
mkLocalId' Name
n = (() :: Constraint) => Name -> Type -> Type -> Var
Name -> Type -> Type -> Var
mkLocalId Name
n Type
One
#else
mkLocalId' = mkLocalId
#endif
mkWildCase' :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
mkWildCase' :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase' CoreExpr
ce Type
t = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
ce (Type -> Scaled Type
forall a. a -> Scaled a
linear Type
t)
#else
mkWildCase' = mkWildCase
#endif
uniqSetToList :: UniqSet a -> [a]
uniqSetToList :: forall a. UniqSet a -> [a]
uniqSetToList = UniqSet a -> [a]
forall a. UniqSet a -> [a]
NonDetSet.nonDetEltsUniqSet
pprTrace' :: String -> SDoc -> a -> a
#ifdef TRACING
pprTrace' = pprTrace
#else
pprTrace' :: forall a. String -> SDoc -> a -> a
pprTrace' String
_ SDoc
_ = a -> a
forall a. a -> a
id
#endif
traceTcS' :: String -> SDoc -> TcS ()
traceTcS' :: String -> SDoc -> TcS ()
traceTcS' String
str SDoc
doc = String -> SDoc -> TcS () -> TcS ()
forall a. String -> SDoc -> a -> a
pprTrace' String
str SDoc
doc (() -> TcS ()
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
traceTc' :: String -> SDoc -> TcRn ()
traceTc' :: String -> SDoc -> TcRn ()
traceTc' String
str SDoc
doc = String -> SDoc -> TcRn () -> TcRn ()
forall a. String -> SDoc -> a -> a
pprTrace' String
str SDoc
doc (() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
runTcM :: HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM :: forall a. HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM HscEnv
env0 DynFlags
dflags ModGuts
guts TcM a
m = do
[ModuleName]
orphans <- (ModuleName -> IO Bool) -> [ModuleName] -> IO [ModuleName]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (HscEnv -> DynFlags -> ModuleName -> IO Bool
moduleIsOkay HscEnv
env0 DynFlags
dflags) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> [Module] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dependencies -> [Module]
dep_orphs (ModGuts -> Dependencies
mg_deps ModGuts
guts))
(Messages TcRnMessage
msgs, Maybe a
mr) <- HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive ([ModuleName] -> HscEnv
env [ModuleName]
orphans) TcM a
m
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
let showMsgs :: Messages e -> String
showMsgs Messages e
msg = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Errors:" SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: Bag (MsgEnvelope e) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (Messages e -> Bag (MsgEnvelope e)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getErrorMessages Messages e
msg)
[SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ String -> SDoc
text String
"Warnings:" SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: Bag (MsgEnvelope e) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (Messages e -> Bag (MsgEnvelope e)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages Messages e
msg)
#else
let showMsgs (warns, errs) = showSDoc dflags $ vcat $
text "Errors:" : pprErrMsgBagWithLoc errs
++ text "Warnings:" : pprErrMsgBagWithLoc warns
#endif
IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ Messages TcRnMessage -> String
forall {e}. Diagnostic e => Messages e -> String
showMsgs Messages TcRnMessage
msgs) a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mr
where
imports0 :: [InteractiveImport]
imports0 = InteractiveContext -> [InteractiveImport]
ic_imports (HscEnv -> InteractiveContext
hsc_IC HscEnv
env0)
env :: [ModuleName] -> HscEnv
env :: [ModuleName] -> HscEnv
env [ModuleName]
extraModuleNames =
HscEnv
env0 { hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
env0)
{ ic_imports :: [InteractiveImport]
ic_imports = (ModuleName -> InteractiveImport)
-> [ModuleName] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> InteractiveImport
IIModule [ModuleName]
extraModuleNames [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
imports0
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
, ic_gre_cache :: IcGlobalRdrEnv
ic_gre_cache = IcGlobalRdrEnv { igre_env :: GlobalRdrEnv
igre_env = ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts, igre_prompt_env :: GlobalRdrEnv
igre_prompt_env = GlobalRdrEnv
emptyGlobalRdrEnv }
, ic_instances :: (InstEnv, [FamInst])
ic_instances = ([ClsInst] -> InstEnv
mkInstEnv (ModGuts -> [ClsInst]
mg_insts ModGuts
guts), ModGuts -> [FamInst]
mg_fam_insts ModGuts
guts)
#else
, ic_rn_gbl_env = mg_rdr_env guts
, ic_instances = (mg_insts guts, mg_fam_insts guts)
#endif
} }
runDsM :: HscEnv -> DynFlags -> ModGuts -> DsM a -> IO a
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
runDsM :: forall a. HscEnv -> DynFlags -> ModGuts -> DsM a -> IO a
runDsM HscEnv
env DynFlags
dflags ModGuts
guts DsM a
dsm = HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
forall a. HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM HscEnv
env DynFlags
dflags ModGuts
guts (TcM a -> IO a) -> TcM a -> IO a
forall a b. (a -> b) -> a -> b
$ do
(Messages DsMessage
_tc_msgs, Maybe a
mb_result) <- DsM a -> TcM (Messages DsMessage, Maybe a)
forall a. DsM a -> TcM (Messages DsMessage, Maybe a)
initDsTc DsM a
dsm
a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe a -> a
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"initDsTc" Maybe a
mb_result)
#else
runDsM env dflags guts = runTcM env dflags guts . initDsTc
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
unkskol :: SkolemInfoAnon
unkskol :: SkolemInfoAnon
unkskol = SkolemInfoAnon
HasCallStack => SkolemInfoAnon
unkSkolAnon
#else
unkskol :: SkolemInfo
unkskol = UnkSkol
#endif
buildDictionary' :: HscEnv -> DynFlags -> ModGuts -> VarSet -> Type
-> IO (Maybe (Id, [CoreBind]))
buildDictionary' :: HscEnv
-> DynFlags
-> ModGuts
-> VarSet
-> Type
-> IO (Maybe (Var, [CoreBind]))
buildDictionary' HscEnv
env DynFlags
dflags ModGuts
guts VarSet
evIds Type
predTy =
do Maybe (Var, Bag EvBind)
res <-
HscEnv
-> DynFlags
-> ModGuts
-> TcM (Maybe (Var, Bag EvBind))
-> IO (Maybe (Var, Bag EvBind))
forall a. HscEnv -> DynFlags -> ModGuts -> TcM a -> IO a
runTcM HscEnv
env DynFlags
dflags ModGuts
guts (TcM (Maybe (Var, Bag EvBind)) -> IO (Maybe (Var, Bag EvBind)))
-> TcM (Maybe (Var, Bag EvBind)) -> IO (Maybe (Var, Bag EvBind))
forall a b. (a -> b) -> a -> b
$
do CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (SkolemInfoAnon -> CtOrigin
GivenOrigin SkolemInfoAnon
unkskol) Maybe TypeOrKind
forall a. Maybe a
Nothing
CtEvidence
evidence <- CtOrigin -> Maybe TypeOrKind -> Type -> TcM CtEvidence
TcMType.newWanted (SkolemInfoAnon -> CtOrigin
GivenOrigin SkolemInfoAnon
unkskol) Maybe TypeOrKind
forall a. Maybe a
Nothing Type
predTy
let EvVarDest Var
evarDest = CtEvidence -> TcEvDest
ctev_dest CtEvidence
evidence
givens :: [Ct]
givens = CtLoc -> [Var] -> [Ct]
mkGivens CtLoc
loc (VarSet -> [Var]
forall a. UniqSet a -> [a]
uniqSetToList VarSet
evIds)
wCs :: WantedConstraints
wCs = [CtEvidence] -> WantedConstraints
mkSimpleWC [CtEvidence
evidence]
String -> SDoc -> TcRn ()
traceTc' String
"buildDictionary': givens" ([Ct] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Ct]
givens)
(WantedConstraints
wantedConstraints, Bag EvBind
bnds0) <-
(EvBindMap -> Bag EvBind)
-> (WantedConstraints, EvBindMap)
-> (WantedConstraints, Bag EvBind)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second EvBindMap -> Bag EvBind
evBindMapBinds ((WantedConstraints, EvBindMap) -> (WantedConstraints, Bag EvBind))
-> IOEnv (Env TcGblEnv TcLclEnv) (WantedConstraints, EvBindMap)
-> IOEnv (Env TcGblEnv TcLclEnv) (WantedConstraints, Bag EvBind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
TcS WantedConstraints
-> IOEnv (Env TcGblEnv TcLclEnv) (WantedConstraints, EvBindMap)
forall a. TcS a -> TcM (a, EvBindMap)
runTcS (do ()
_ <- [Ct] -> TcS ()
solveSimpleGivens [Ct]
givens
String -> SDoc -> TcS ()
traceTcS' String
"buildDictionary' back from solveSimpleGivens" SDoc
empty
WantedConstraints
z <- WantedConstraints -> TcS WantedConstraints
solveWanteds WantedConstraints
wCs
String -> SDoc -> TcS ()
traceTcS' String
"buildDictionary' back from solveWanteds" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
z)
WantedConstraints -> TcS WantedConstraints
forall a. a -> TcS a
forall (m :: * -> *) a. Monad m => a -> m a
return WantedConstraints
z
)
String -> SDoc -> TcRn ()
traceTc' String
"buildDictionary' back from runTcS" (Bag EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag EvBind
bnds0)
ZonkEnv
ez <- TcM ZonkEnv
emptyZonkEnv
(ZonkEnv
_env',Bag EvBind
bnds) <- ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds ZonkEnv
ez Bag EvBind
bnds0
String -> SDoc -> TcRn ()
traceTc' String
"buildDictionary' zonked" (Bag EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag EvBind
bnds)
if WantedConstraints -> Bool
isEmptyWC WantedConstraints
wantedConstraints
then Maybe (Var, Bag EvBind) -> TcM (Maybe (Var, Bag EvBind))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, Bag EvBind) -> Maybe (Var, Bag EvBind)
forall a. a -> Maybe a
Just (Var
evarDest, Bag EvBind
bnds))
else Maybe (Var, Bag EvBind) -> TcM (Maybe (Var, Bag EvBind))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Var, Bag EvBind)
forall a. Maybe a
Nothing
case Maybe (Var, Bag EvBind)
res of
Just (Var
i, Bag EvBind
bs) ->
do [CoreBind]
bs' <- HscEnv -> DynFlags -> ModGuts -> DsM [CoreBind] -> IO [CoreBind]
forall a. HscEnv -> DynFlags -> ModGuts -> DsM a -> IO a
runDsM HscEnv
env DynFlags
dflags ModGuts
guts (Bag EvBind -> DsM [CoreBind]
dsEvBinds Bag EvBind
bs)
Maybe (Var, [CoreBind]) -> IO (Maybe (Var, [CoreBind]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var, [CoreBind]) -> Maybe (Var, [CoreBind])
forall a. a -> Maybe a
Just (Var
i, [CoreBind]
bs'))
Maybe (Var, Bag EvBind)
Nothing -> Maybe (Var, [CoreBind]) -> IO (Maybe (Var, [CoreBind]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Var, [CoreBind])
forall a. Maybe a
Nothing
buildDictionary :: HscEnv -> DynFlags -> ModGuts -> UniqSupply -> InScopeEnv -> Type -> CoreExpr -> Type -> IO (Either SDoc CoreExpr)
buildDictionary :: HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
buildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope evType :: Type
evType@(TyConApp TyCon
tyCon [Type]
evTypes) CoreExpr
ev Type
goalTy | TyCon -> Bool
isTupleTyCon TyCon
tyCon =
HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> [Type]
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
reallyBuildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType [Type]
evTypes CoreExpr
ev Type
goalTy
buildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType CoreExpr
ev Type
goalTy | Type -> Bool
isEvVarType' Type
evType =
HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> [Type]
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
reallyBuildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType [Type
evType] CoreExpr
ev Type
goalTy
buildDictionary HscEnv
_env DynFlags
_dflags ModGuts
_guts UniqSupply
_uniqSupply InScopeEnv
_inScope Type
evT CoreExpr
_ev Type
_goalTy = String -> SDoc -> IO (Either SDoc CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"evidence type mismatch" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
evT)
reallyBuildDictionary :: HscEnv -> DynFlags -> ModGuts -> UniqSupply -> InScopeEnv -> Type -> [Type] -> CoreExpr -> Type -> IO (Either SDoc CoreExpr)
reallyBuildDictionary :: HscEnv
-> DynFlags
-> ModGuts
-> UniqSupply
-> InScopeEnv
-> Type
-> [Type]
-> CoreExpr
-> Type
-> IO (Either SDoc CoreExpr)
reallyBuildDictionary HscEnv
env DynFlags
dflags ModGuts
guts UniqSupply
uniqSupply InScopeEnv
inScope Type
evType [Type]
evTypes CoreExpr
ev Type
goalTy =
String
-> SDoc -> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace' String
"\nbuildDictionary" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
goalTy) (IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr))
-> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a b. (a -> b) -> a -> b
$
String
-> SDoc -> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary in-scope evidence" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
ev) (IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr))
-> IO (Either SDoc CoreExpr) -> IO (Either SDoc CoreExpr)
forall a b. (a -> b) -> a -> b
$
Maybe (Var, [CoreBind]) -> Either SDoc CoreExpr
reassemble (Maybe (Var, [CoreBind]) -> Either SDoc CoreExpr)
-> IO (Maybe (Var, [CoreBind])) -> IO (Either SDoc CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv
-> DynFlags
-> ModGuts
-> VarSet
-> Type
-> IO (Maybe (Var, [CoreBind]))
buildDictionary' HscEnv
env DynFlags
dflags ModGuts
guts VarSet
evIdSet Type
goalTy
where
evIds :: [Var]
evIds = [ Var
local
| (Type
evTy, Unique
unq) <- [Type]
evTypes [Type] -> [Unique] -> [(Type, Unique)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
uniqSupply)
, let local :: Var
local = (() :: Constraint) => Name -> Type -> Var
Name -> Type -> Var
mkLocalId' (Unique -> FastString -> Name
mkSystemVarName Unique
unq FastString
evVarName) Type
evTy ]
evIdSet :: VarSet
evIdSet = [Var] -> VarSet
mkVarSet [Var]
evIds
reassemble :: Maybe (Var, [CoreBind]) -> Either SDoc CoreExpr
reassemble Maybe (Var, [CoreBind])
Nothing =
SDoc -> Either SDoc CoreExpr
forall a b. a -> Either a b
Left (String -> SDoc
text String
"unsolved constraints")
reassemble (Just (Var
i,[CoreBind]
bnds)) =
String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
goalTy SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"-->" SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary evIds" ([Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
evIds) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary expr" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
(SDoc -> Either SDoc CoreExpr)
-> (CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr
-> Either SDoc CoreExpr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ SDoc
e -> String -> SDoc -> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a. String -> SDoc -> a -> a
pprTrace' String
"buildDictionary fail" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
goalTy SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"-->" SDoc -> SDoc -> SDoc
$$ SDoc
e) Either SDoc CoreExpr
res) (Either SDoc CoreExpr -> CoreExpr -> Either SDoc CoreExpr
forall a b. a -> b -> a
const Either SDoc CoreExpr
res) (Either SDoc CoreExpr -> Either SDoc CoreExpr)
-> Either SDoc CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$
Either SDoc CoreExpr
res
where
res :: Either SDoc CoreExpr
res | [CoreBind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBind]
bnds = SDoc -> Either SDoc CoreExpr
forall a b. a -> Either a b
Left (String -> SDoc
text String
"no bindings")
| Bool
otherwise = CoreExpr -> Either SDoc CoreExpr
forall a. a -> Either SDoc a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Either SDoc CoreExpr)
-> CoreExpr -> Either SDoc CoreExpr
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags -> InScopeSet -> Bool -> CoreExpr -> CoreExpr
simplifyE HscEnv
env DynFlags
dflags (InScopeEnv -> InScopeSet
forall a b. (a, b) -> a
fst InScopeEnv
inScope) Bool
False
CoreExpr
expr
dict :: CoreExpr
dict =
case [CoreBind]
bnds of
[NonRec Var
v CoreExpr
e] | Var
i Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v -> CoreExpr
e
[CoreBind]
_ -> [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
bnds (Var -> CoreExpr
forall b. Var -> Expr b
varToCoreExpr Var
i)
expr :: CoreExpr
expr = if [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
evTypes
then CoreExpr
dict
else case [Var]
evIds of
[Var
evId] -> CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
evId CoreExpr
ev) CoreExpr
dict
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
[Var]
_ -> CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase' CoreExpr
ev Type
evType Type
goalTy [AltCon -> [Var] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Boxed ([Var] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Var]
evIds))) [Var]
evIds CoreExpr
dict]
#else
_ -> mkWildCase' ev evType goalTy [(DataAlt (tupleDataCon Boxed (length evIds)), evIds, dict)]
#endif
evVarName :: FastString
evVarName :: FastString
evVarName = String -> FastString
mkFastString String
"evidence"
extendEvVars :: DVarSet -> Var -> DVarSet
extendEvVars :: DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var =
if (() :: Constraint) => Type -> Bool
Type -> Bool
isPredTy (Var -> Type
varType Var
var)
then DVarSet -> Var -> DVarSet
extendDVarSet DVarSet
evVars Var
var
else DVarSet
evVars
extendEvVarsList :: DVarSet -> [Var] -> DVarSet
extendEvVarsList :: DVarSet -> [Var] -> DVarSet
extendEvVarsList DVarSet
evVars [Var]
vars =
DVarSet -> [Var] -> DVarSet
extendDVarSetList DVarSet
evVars ((Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isEvVar [Var]
vars)
annotateEvidence :: Id -> Id -> Int -> CoreBind -> CoreM CoreBind
annotateEvidence :: Var -> Var -> Arity -> CoreBind -> CoreM CoreBind
annotateEvidence Var
fnId Var
fnId' Arity
typeArgsCount (NonRec Var
var CoreExpr
expr) =
do let expr' :: CoreExpr
expr' = Var -> Var -> Arity -> CoreExpr -> CoreExpr
annotateExpr Var
fnId Var
fnId' Arity
typeArgsCount CoreExpr
expr
CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
var CoreExpr
expr')
annotateEvidence Var
fnId Var
fnId' Arity
typeArgsCount (Rec [(Var, CoreExpr)]
bindings) =
do [(Var, CoreExpr)]
bindings' <- ((Var, CoreExpr) -> CoreM (Var, CoreExpr))
-> [(Var, CoreExpr)] -> CoreM [(Var, CoreExpr)]
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 (\ (Var
var, CoreExpr
expr) ->
do let expr' :: CoreExpr
expr' = Var -> Var -> Arity -> CoreExpr -> CoreExpr
annotateExpr Var
fnId Var
fnId' Arity
typeArgsCount CoreExpr
expr
(Var, CoreExpr) -> CoreM (Var, CoreExpr)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
var, CoreExpr
expr'))
[(Var, CoreExpr)]
bindings
CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, CoreExpr)]
bindings')
annotateExpr :: Id -> Id -> Int -> CoreExpr -> CoreExpr
annotateExpr :: Var -> Var -> Arity -> CoreExpr -> CoreExpr
annotateExpr Var
fnId Var
fnId' Arity
typeArgsCount CoreExpr
expr0 =
DVarSet -> CoreExpr -> CoreExpr
go DVarSet
emptyDVarSet CoreExpr
expr0
where
go :: DVarSet -> CoreExpr -> CoreExpr
go DVarSet
_evVars expr :: CoreExpr
expr@(Var Var
_) = CoreExpr
expr
go DVarSet
_evVars expr :: CoreExpr
expr@(Lit Literal
_) = CoreExpr
expr
go DVarSet
evVars expr :: CoreExpr
expr@(CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs -> (Var ((Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
fnId) -> Bool
True), [CoreExpr]
args)) =
let ([CoreExpr]
tyArgs, [CoreExpr]
valArgs) = Arity -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
typeArgsCount [CoreExpr]
args
in if [CoreExpr] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CoreExpr]
tyArgs Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< Arity
typeArgsCount
then String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unsaturated call to target function" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr)
else
let evVarExp :: CoreExpr
evVarExp = [CoreExpr] -> CoreExpr
mkCoreTup ((Var -> CoreExpr) -> [Var] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Var -> CoreExpr
forall b. Var -> Expr b
Var (DVarSet -> [Var]
dVarSetElems DVarSet
evVars))
valArgs' :: [CoreExpr]
valArgs' = (CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars) [CoreExpr]
valArgs
in CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
fnId') ([CoreExpr]
tyArgs [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [Type -> CoreExpr
forall b. Type -> Expr b
Type ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
evVarExp), CoreExpr
evVarExp] [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
valArgs')
go DVarSet
evVars (App CoreExpr
fn CoreExpr
arg) =
let fn' :: CoreExpr
fn' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
fn
arg' :: CoreExpr
arg' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
arg
in CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fn' CoreExpr
arg'
go DVarSet
evVars (Lam Var
var CoreExpr
body) =
let evVars' :: DVarSet
evVars' = DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var
body' :: CoreExpr
body' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars' CoreExpr
body
in Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
var CoreExpr
body'
go DVarSet
evVars (Let (NonRec Var
var CoreExpr
rhs) CoreExpr
body) =
let rhs' :: CoreExpr
rhs' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
rhs
body' :: CoreExpr
body' = DVarSet -> CoreExpr -> CoreExpr
go (DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var) CoreExpr
body
in CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
var CoreExpr
rhs') CoreExpr
body'
go DVarSet
evVars (Let (Rec [(Var, CoreExpr)]
bindings) CoreExpr
body) =
let evVars' :: DVarSet
evVars' = DVarSet -> [Var] -> DVarSet
extendEvVarsList DVarSet
evVars (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
bindings)
bindings' :: [(Var, CoreExpr)]
bindings' = ((Var, CoreExpr) -> (Var, CoreExpr))
-> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Var
var, CoreExpr
expr) -> (Var
var, DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars' CoreExpr
expr))
[(Var, CoreExpr)]
bindings
body' :: CoreExpr
body' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars' CoreExpr
body
in CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(Var, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, CoreExpr)]
bindings') CoreExpr
body'
go DVarSet
evVars (Case CoreExpr
scrutinee Var
var Type
ty [CoreAlt]
alts) =
let evVars' :: DVarSet
evVars' = DVarSet -> Var -> DVarSet
extendEvVars DVarSet
evVars Var
var
scrutinee' :: CoreExpr
scrutinee' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
scrutinee
alts' :: [CoreAlt]
alts' = (CoreAlt -> CoreAlt) -> [CoreAlt] -> [CoreAlt]
forall a b. (a -> b) -> [a] -> [b]
map (DVarSet -> CoreAlt -> CoreAlt
annotateAlt DVarSet
evVars') [CoreAlt]
alts
in CoreExpr -> Var -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrutinee' Var
var Type
ty [CoreAlt]
alts'
go DVarSet
evVars (Cast CoreExpr
expr CoercionR
coercion) =
let expr' :: CoreExpr
expr' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
expr
in CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
expr' CoercionR
coercion
go DVarSet
evVars (Tick CoreTickish
tickish CoreExpr
expr) =
let expr' :: CoreExpr
expr' = DVarSet -> CoreExpr -> CoreExpr
go DVarSet
evVars CoreExpr
expr
in CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
expr'
go DVarSet
_evVars expr :: CoreExpr
expr@(Type Type
_) = CoreExpr
expr
go DVarSet
_evVars expr :: CoreExpr
expr@(Coercion CoercionR
_) = CoreExpr
expr
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
annotateAlt :: DVarSet -> CoreAlt -> CoreAlt
annotateAlt DVarSet
evVars (Alt AltCon
con [Var]
binders CoreExpr
rhs) =
AltCon -> [Var] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Var]
binders (CoreExpr -> CoreAlt) -> CoreExpr -> CoreAlt
forall a b. (a -> b) -> a -> b
$ DVarSet -> CoreExpr -> CoreExpr
go (DVarSet -> [Var] -> DVarSet
extendEvVarsList DVarSet
evVars [Var]
binders) CoreExpr
rhs
#else
annotateAlt evVars (con, binders, rhs) =
(con, binders, go (extendEvVarsList evVars binders) rhs)
#endif
withType :: CoreExpr -> WithType
withType :: CoreExpr -> WithType
withType CoreExpr
e = CoreExpr -> Type -> WithType
WithType CoreExpr
e ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
withExplicitType :: CoreExpr -> Type -> WithType
withExplicitType :: CoreExpr -> Type -> WithType
withExplicitType CoreExpr
e Type
ty = CoreExpr -> Type -> WithType
WithType CoreExpr
e Type
ty
varWithType :: Var -> WithType
varWithType :: Var -> WithType
varWithType = CoreExpr -> WithType
withType (CoreExpr -> WithType) -> (Var -> CoreExpr) -> Var -> WithType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> CoreExpr
forall b. Var -> Expr b
Var
data WithType = WithType CoreExpr Type
instance Outputable WithType where
ppr :: WithType -> SDoc
ppr (WithType CoreExpr
e Type
ty) = CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty
newtype WithIdInfo = WithIdInfo Id
instance Outputable WithIdInfo where
ppr :: WithIdInfo -> SDoc
ppr (WithIdInfo Var
v) = Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<+> SDoc
colon SDoc -> SDoc -> SDoc
<+> Maybe (TyCon, [Type]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (Var -> Type
varType Var
v))