{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
-- | The Core -> Eidos bridge: translates the -O0 desugared Core of the
--   whole home module graph into an Eidos 'Program' (doc/eidos.md §3) by
--   near-transliteration. Where the retired Crust bridge lowered lets to
--   beta-redexes (with demand-order rescheduling), crushed cases to
--   single-arm cascades, and discarded type instantiations for the
--   typechecker to re-infer, this bridge PRESERVES them: Core lets become
--   'ReWire.Eidos.Syntax.Let's (recursive groups included), join-tagged
--   binders become 'Join' binds with 'Jump's at their call sites, cases
--   stay n-ary with their case binder, and type arguments ride along as
--   'TArg's (driving the substitution-based specializer). Types are
--   bridged fail-fast: an untranslatable type is a located error at the
--   occurrence, never a silent Nothing.
--
--   Also handled here: the reachability walk
--   from the start symbol + rwPrim* roots, evidence erasure (dictionary
--   arguments\/binders\/binds erased; user-class dictionaries kept as data,
--   with single-method classes' newtype-dictionary types unwrapped to the
--   method type, matching the term level's cast erasure),
--   rwPrim* recognition, the reactive-monad class-op recognition (Bind and
--   Return at ReacT\/StateT\/Identity or at an unresolved monad type),
--   Integer\/String\/list literal folding, INLINE-pragma ride-along, and the
--   base vocabulary. Name and type classification lives in
--   "ReWire.GHC.Recognize".
--
--   Uniques: every Eidos binder gets a fresh unique from a supply threaded
--   through the translation (GHC Core does not guarantee globally unique
--   binders); occurrences resolve through the context maps.
module ReWire.GHC.ToEidos (toEidos) where

import ReWire.Annotation (Annote, noAnn)
import ReWire.Config (Config, start)
import ReWire.Error (AstError, MonadError, failAt)
import ReWire.Eidos.PrimBasis (addPrims)
import ReWire.Eidos.Types (flattenArrow, flattenTyApp)
import ReWire.GHC.Recognize (uKey, spanAnnote, varAnnote, isPrimModule, isPrimVar, homeishMod, qualName, conName, tupleName, splitStart, localOcc, erasedArg, erasedEv, userPred, tyConModule, tyConKey, tyConTable, vocabTable)

import qualified ReWire.Builtins     as B
import qualified ReWire.Eidos.Syntax as E

import Control.Lens ((^.))
import Control.Monad (unless, zipWithM)
import Control.Monad.State.Strict (StateT, evalStateT, get, put, lift)
import Data.List (elemIndex)
import Data.Text (Text, pack)

import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet        as IS
import qualified Data.Text.Encoding as TE

import GHC (ModuleName, moduleName, moduleNameString)
import GHC.Builtin.Types (integerISDataCon, integerIPDataCon, integerINDataCon, listTyCon, nilDataCon, consDataCon, unitTyCon, boolTyCon, charTyCon, integerTyCon, naturalTyCon, unboxedUnitTyCon, unboxedUnitDataCon)
import GHC.Builtin.Types.Literals (typeNatAddTyCon, typeNatSubTyCon, typeNatMulTyCon)
import GHC.Core (CoreExpr, CoreBind, Expr (..), Bind (..), Alt (..), AltCon (..), collectArgs)
import GHC.Core.Class (classAllSelIds, classTyCon)
import GHC.Core.DataCon (DataCon, dataConOrigArgTys, dataConUnivTyVars, dataConExTyCoVars, dataConTheta)
import GHC.Core.Predicate (isEvVarType)
import GHC.Core.TyCo.Rep (Type (..), TyLit (..), scaledThing)
import GHC.Core.TyCon (TyCon, tyConName, tyConKind, tyConDataCons, tyConTyVars, isClassTyCon, isAlgTyCon, isTypeSynonymTyCon, isBoxedTupleTyCon, tyConArity, isNewTyCon, tyConSingleDataCon)
import GHC.Core.TyCon.RecWalk (RecTcChecker, initRecTc, checkRecTc)
import GHC.Core.Type (expandTypeSynonyms, mkTyVarTy, mkTyVarTys, splitForAllTyCoVars, substTyWith, newTyConInstRhs)
import GHC.Core.Utils (exprType)
import GHC.Types.Basic (InlineSpec (..), inlinePragmaSpec, JoinPointHood (..))
import GHC.Types.Id (isClassOpId_maybe, idInlinePragma, isDataConId_maybe, isDFunId, idJoinPointHood)
import GHC.Types.Id.Make (voidPrimId)
import GHC.Types.Literal (Literal (..))
import GHC.Types.Name (getOccString, nameModule_maybe, nameSrcSpan)
import GHC.Types.Var (Var, varName, varType, isTyVar)
import GHC.Unit.Module.ModGuts (ModGuts (..))
import GHC.Utils.Outputable (showSDocUnsafe, ppr)

-- | The unique supply.
type BM m = StateT E.Uniq m

freshU :: Monad m => BM m E.Uniq
freshU :: forall (m :: * -> *). Monad m => BM m Uniq
freshU = do
      u <- StateT Uniq m Uniq
forall s (m :: * -> *). MonadState s m => m s
get
      put $ u + 1
      pure u

freshId :: Monad m => Text -> E.Sig -> BM m E.Id
freshId :: forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId TyConId
occ Sig
sig = do
      u <- BM m Uniq
forall (m :: * -> *). Monad m => BM m Uniq
freshU
      pure $ E.Id occ u sig

-- | Translation context.
data Ctx = Ctx
      { Ctx -> IntMap Id
ctxTops   :: IM.IntMap E.Id     -- ^ top-level GHC unique -> Eidos Id.
      , Ctx -> IntMap Id
ctxLocals :: IM.IntMap E.Id     -- ^ local GHC unique -> Eidos Id.
      , Ctx -> IntMap JoinId
ctxJoins  :: IM.IntMap E.JoinId -- ^ join-point GHC unique -> Eidos JoinId.
      , Ctx -> IntMap TyVar
ctxTyVars :: IM.IntMap E.TyVar  -- ^ in-scope GHC tyvar unique -> Eidos TyVar.
      , Ctx -> [(TyConId, Id)]
ctxVocab  :: [(Text, E.Id)]     -- ^ base-vocabulary name -> synthesized defn Id.
      }

bindLocal :: Var -> E.Id -> Ctx -> Ctx
bindLocal :: Var -> Id -> Ctx -> Ctx
bindLocal Var
v Id
x Ctx
ctx = Ctx
ctx { ctxLocals = IM.insert (uKey v) x $ ctxLocals ctx }

bindJoin :: Var -> E.JoinId -> Ctx -> Ctx
bindJoin :: Var -> JoinId -> Ctx -> Ctx
bindJoin Var
v JoinId
j Ctx
ctx = Ctx
ctx { ctxJoins = IM.insert (uKey v) j $ ctxJoins ctx }

bindTyVar :: Var -> E.TyVar -> Ctx -> Ctx
bindTyVar :: Var -> TyVar -> Ctx -> Ctx
bindTyVar Var
v TyVar
tv Ctx
ctx = Ctx
ctx { ctxTyVars = IM.insert (uKey v) tv $ ctxTyVars ctx }

toEidos :: MonadError AstError m => Config -> [ModGuts] -> m E.Program
toEidos :: forall (m :: * -> *).
MonadError AstError m =>
Config -> [ModGuts] -> m Program
toEidos Config
conf [ModGuts]
gutss = StateT Uniq m Program -> Uniq -> m Program
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT Uniq m Program
forall (m :: * -> *). MonadError AstError m => BM m Program
go Uniq
0
      where go :: MonadError AstError m => BM m E.Program
            go :: forall (m :: * -> *). MonadError AstError m => BM m Program
go = do
                  let binds :: [(Var, CoreExpr, ModuleName)]
                      binds :: [(Var, CoreExpr, ModuleName)]
binds = [ (Var
b, CoreExpr
rhs, GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModGuts -> GenModule Unit
mg_module ModGuts
g)
                              | ModGuts
g <- [ModGuts]
gutss, CoreBind
bnd <- ModGuts -> CoreProgram
mg_binds ModGuts
g, (Var
b, CoreExpr
rhs) <- CoreBind -> [(Var, CoreExpr)]
flattenBind CoreBind
bnd ]

                      bindMap :: IM.IntMap (Var, CoreExpr, ModuleName)
                      bindMap :: IntMap (Var, CoreExpr, ModuleName)
bindMap = [(Uniq, (Var, CoreExpr, ModuleName))]
-> IntMap (Var, CoreExpr, ModuleName)
forall a. [(Uniq, a)] -> IntMap a
IM.fromList [ (Var -> Uniq
uKey Var
b, (Var, CoreExpr, ModuleName)
t) | t :: (Var, CoreExpr, ModuleName)
t@(Var
b, CoreExpr
_, ModuleName
_) <- [(Var, CoreExpr, ModuleName)]
binds ]

                      (String
startMod, String
startOcc) = TyConId -> (String, String)
splitStart (TyConId -> (String, String)) -> TyConId -> (String, String)
forall a b. (a -> b) -> a -> b
$ Config
confConfig -> Getting TyConId Config TyConId -> TyConId
forall s a. s -> Getting a s a -> a
^.Getting TyConId Config TyConId
Lens' Config TyConId
start

                      isStartV :: (Var, CoreExpr, ModuleName) -> Bool
                      isStartV :: (Var, CoreExpr, ModuleName) -> Bool
isStartV (Var
b, CoreExpr
_, ModuleName
mn) = ModuleName -> String
moduleNameString ModuleName
mn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
startMod Bool -> Bool -> Bool
&& Var -> String
forall a. NamedThing a => a -> String
getOccString Var
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
startOcc

                  startV <- case ((Var, CoreExpr, ModuleName) -> Bool)
-> [(Var, CoreExpr, ModuleName)] -> [(Var, CoreExpr, ModuleName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var, CoreExpr, ModuleName) -> Bool
isStartV [(Var, CoreExpr, ModuleName)]
binds of
                        ((Var
b, CoreExpr
_, ModuleName
_) : [(Var, CoreExpr, ModuleName)]
_) -> Var -> StateT Uniq m Var
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
b
                        [(Var, CoreExpr, ModuleName)]
_               -> Annote -> TyConId -> StateT Uniq m Var
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
noAnn (TyConId -> StateT Uniq m Var) -> TyConId -> StateT Uniq m Var
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: no definition for the start symbol (" TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> Config
confConfig -> Getting TyConId Config TyConId -> TyConId
forall s a. s -> Getting a s a -> a
^.Getting TyConId Config TyConId
Lens' Config TyConId
start TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
")."

                  -- rwPrim* binds are roots besides the start symbol (their
                  -- signatures are the builtins' type assumptions).
                  let roots = Var
startV Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [ Var
b | (Var
b, CoreExpr
_, ModuleName
_) <- [(Var, CoreExpr, ModuleName)]
binds, Var -> Bool
isPrimVar Var
b ]
                      reach = IntMap (Var, CoreExpr, ModuleName) -> [Var] -> IntSet
reachable IntMap (Var, CoreExpr, ModuleName)
bindMap [Var]
roots
                      keep  = [ (Var, CoreExpr, ModuleName)
t | t :: (Var, CoreExpr, ModuleName)
t@(Var
b, CoreExpr
_, ModuleName
_) <- [(Var, CoreExpr, ModuleName)]
binds
                                  , Var -> Uniq
uKey Var
b Uniq -> IntSet -> Bool
`IS.member` IntSet
reach
                                  , Bool -> Bool
not (Type -> Bool
erasedEv (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
b) ]

                  -- Pre-mint every kept top-level Id (so use sites of
                  -- module-internal ids resolve to the same Id), and the
                  -- vocabulary definitions.
                  tops   <- IM.fromList <$> mapM (\ (Var
b, CoreExpr
_, ModuleName
mn) -> (Var -> Uniq
uKey Var
b, ) (Id -> (Uniq, Id)) -> StateT Uniq m Id -> StateT Uniq m (Uniq, Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var -> ModuleName -> StateT Uniq m Id
forall (m :: * -> *).
MonadError AstError m =>
Var -> ModuleName -> BM m Id
topId Var
b ModuleName
mn) keep
                  vocab  <- vocabDefns

                  let ctx = Ctx { ctxTops :: IntMap Id
ctxTops   = IntMap Id
tops
                                , ctxLocals :: IntMap Id
ctxLocals = IntMap Id
forall a. Monoid a => a
mempty
                                , ctxJoins :: IntMap JoinId
ctxJoins  = IntMap JoinId
forall a. Monoid a => a
mempty
                                , ctxTyVars :: IntMap TyVar
ctxTyVars = IntMap TyVar
forall a. Monoid a => a
mempty
                                , ctxVocab :: [(TyConId, Id)]
ctxVocab  = [ (Id -> TyConId
E.idOcc (Id -> TyConId) -> Id -> TyConId
forall a b. (a -> b) -> a -> b
$ Defn -> Id
E.defnId Defn
d, Defn -> Id
E.defnId Defn
d) | Defn
d <- [Defn]
vocab ]
                                }

                  defs  <- mapM (bridgeDefn ctx) keep
                  datas <- concat <$> mapM harvestDatas gutss
                  top   <- case IM.lookup (uKey startV) tops of
                        Just Id
x  -> Id -> StateT Uniq m Id
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
x
                        Maybe Id
Nothing -> Annote -> TyConId -> StateT Uniq m Id
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
noAnn TyConId
"ghc-frontend: start symbol not bridged (rwc bug)."
                  pure $ addPrims E.Program
                        { E.progDatas = datas
                        , E.progDefns = defs <> vocab
                        , E.progTop   = top
                        }

            topId :: MonadError AstError m => Var -> ModuleName -> BM m E.Id
            topId :: forall (m :: * -> *).
MonadError AstError m =>
Var -> ModuleName -> BM m Id
topId Var
b ModuleName
mn = do
                  let an :: Annote
an         = Var -> Annote
varAnnote Var
b
                      ([Var]
tvs, Type
rho) = Type -> ([Var], Type)
splitForAllTyCoVars (Type -> ([Var], Type)) -> Type -> ([Var], Type)
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
b
                  (tvs', tvm) <- Annote -> [Var] -> BM m ([TyVar], IntMap TyVar)
forall (m :: * -> *).
MonadError AstError m =>
Annote -> [Var] -> BM m ([TyVar], IntMap TyVar)
mintTyVars Annote
an ([Var] -> BM m ([TyVar], IntMap TyVar))
-> [Var] -> BM m ([TyVar], IntMap TyVar)
forall a b. (a -> b) -> a -> b
$ (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isTyVar [Var]
tvs
                  t           <- bridgeTy tvm an rho
                  freshId (qualName mn b) $ E.Sig tvs' t

-- | Mint Eidos type variables for a quantifier list, returning them plus
--   the GHC-unique-keyed map for resolving occurrences.
mintTyVars :: MonadError AstError m => Annote -> [Var] -> BM m ([E.TyVar], IM.IntMap E.TyVar)
mintTyVars :: forall (m :: * -> *).
MonadError AstError m =>
Annote -> [Var] -> BM m ([TyVar], IntMap TyVar)
mintTyVars Annote
_ [Var]
vs = do
      tvs <- (Var -> StateT Uniq m (Var, TyVar))
-> [Var] -> StateT Uniq m [(Var, TyVar)]
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
v -> do
                  u <- BM m Uniq
forall (m :: * -> *). Monad m => BM m Uniq
freshU
                  pure (v, E.TyVar (pack $ getOccString v) u (bridgeKind $ varType v)))
            [Var]
vs
      pure (map snd tvs, IM.fromList [ (uKey v, tv) | (v, tv) <- tvs ])

flattenBind :: CoreBind -> [(Var, CoreExpr)]
flattenBind :: CoreBind -> [(Var, CoreExpr)]
flattenBind = \ case
      NonRec Var
b CoreExpr
rhs -> [(Var
b, CoreExpr
rhs)]
      Rec [(Var, CoreExpr)]
bs       -> [(Var, CoreExpr)]
bs

-- | Transitive closure of top-level binds reachable from the roots, with
--   the same erasures the translation performs.
reachable :: IM.IntMap (Var, CoreExpr, ModuleName) -> [Var] -> IS.IntSet
reachable :: IntMap (Var, CoreExpr, ModuleName) -> [Var] -> IntSet
reachable IntMap (Var, CoreExpr, ModuleName)
bindMap = IntSet -> [Var] -> IntSet
go IntSet
forall a. Monoid a => a
mempty
      where go :: IS.IntSet -> [Var] -> IS.IntSet
            go :: IntSet -> [Var] -> IntSet
go IntSet
seen []       = IntSet
seen
            go IntSet
seen (Var
v : [Var]
vs)
                  | Uniq
k Uniq -> IntSet -> Bool
`IS.member` IntSet
seen = IntSet -> [Var] -> IntSet
go IntSet
seen [Var]
vs
                  | Bool
otherwise          = case Uniq
-> IntMap (Var, CoreExpr, ModuleName)
-> Maybe (Var, CoreExpr, ModuleName)
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup Uniq
k IntMap (Var, CoreExpr, ModuleName)
bindMap of
                        Just (Var
_, CoreExpr
rhs, ModuleName
_) | Bool -> Bool
not (Var -> Bool
isPrimVar Var
v) -> IntSet -> [Var] -> IntSet
go (Uniq -> IntSet -> IntSet
IS.insert Uniq
k IntSet
seen) (CoreExpr -> [Var]
refs CoreExpr
rhs [Var] -> [Var] -> [Var]
forall a. Semigroup a => a -> a -> a
<> [Var]
vs)
                        Maybe (Var, CoreExpr, ModuleName)
_                                    -> IntSet -> [Var] -> IntSet
go (Uniq -> IntSet -> IntSet
IS.insert Uniq
k IntSet
seen) [Var]
vs
                  where k :: Uniq
k = Var -> Uniq
uKey Var
v

            refs :: CoreExpr -> [Var]
            refs :: CoreExpr -> [Var]
refs = \ case
                  Var Var
v               -> [Var
v]
                  Lit Literal
_               -> []
                  App CoreExpr
f CoreExpr
a
                        | CoreExpr -> Bool
erasedArg CoreExpr
a -> CoreExpr -> [Var]
refs CoreExpr
f
                        | Bool
otherwise   -> CoreExpr -> [Var]
refs CoreExpr
f [Var] -> [Var] -> [Var]
forall a. Semigroup a => a -> a -> a
<> CoreExpr -> [Var]
refs CoreExpr
a
                  Lam Var
_ CoreExpr
e             -> CoreExpr -> [Var]
refs CoreExpr
e
                  Let (NonRec Var
x CoreExpr
r) CoreExpr
e
                        | Type -> Bool
erasedEv (Var -> Type
varType Var
x) -> CoreExpr -> [Var]
refs CoreExpr
e
                        | Bool
otherwise   -> CoreExpr -> [Var]
refs CoreExpr
r [Var] -> [Var] -> [Var]
forall a. Semigroup a => a -> a -> a
<> CoreExpr -> [Var]
refs CoreExpr
e
                  Let (Rec [(Var, CoreExpr)]
bs) CoreExpr
e      -> ((Var, CoreExpr) -> [Var]) -> [(Var, CoreExpr)] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CoreExpr -> [Var]
refs (CoreExpr -> [Var])
-> ((Var, CoreExpr) -> CoreExpr) -> (Var, CoreExpr) -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd) [(Var, CoreExpr)]
bs [Var] -> [Var] -> [Var]
forall a. Semigroup a => a -> a -> a
<> CoreExpr -> [Var]
refs CoreExpr
e
                  Case CoreExpr
s Var
_ Type
_ [Alt Var]
alts     -> CoreExpr -> [Var]
refs CoreExpr
s [Var] -> [Var] -> [Var]
forall a. Semigroup a => a -> a -> a
<> (Alt Var -> [Var]) -> [Alt Var] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ (Alt AltCon
_ [Var]
_ CoreExpr
e') -> CoreExpr -> [Var]
refs CoreExpr
e') [Alt Var]
alts
                  Cast CoreExpr
e' CoercionR
_           -> CoreExpr -> [Var]
refs CoreExpr
e'
                  Tick CoreTickish
_ CoreExpr
e'           -> CoreExpr -> [Var]
refs CoreExpr
e'
                  Type Type
_              -> []
                  Coercion CoercionR
_          -> []

---
--- Definitions.
---

bridgeDefn :: MonadError AstError m => Ctx -> (Var, CoreExpr, ModuleName) -> BM m E.Defn
bridgeDefn :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> (Var, CoreExpr, ModuleName) -> BM m Defn
bridgeDefn Ctx
ctx (Var
b, CoreExpr
rhs, ModuleName
mn) = do
      x <- StateT Uniq m Id
-> (Id -> StateT Uniq m Id) -> Maybe Id -> StateT Uniq m Id
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Annote -> TyConId -> StateT Uniq m Id
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt (Var -> Annote
varAnnote Var
b) TyConId
"ghc-frontend: unbridged top-level id (rwc bug).") Id -> StateT Uniq m Id
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Maybe Id -> StateT Uniq m Id) -> Maybe Id -> StateT Uniq m Id
forall a b. (a -> b) -> a -> b
$ Uniq -> IntMap Id -> Maybe Id
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup (Var -> Uniq
uKey Var
b) (IntMap Id -> Maybe Id) -> IntMap Id -> Maybe Id
forall a b. (a -> b) -> a -> b
$ Ctx -> IntMap Id
ctxTops Ctx
ctx
      let an              = Var -> Annote
varAnnote Var
b
          E.Sig sigTvs _  = E.idSig x
          ghcTvs          = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isTyVar ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ ([Var], Type) -> [Var]
forall a b. (a, b) -> a
fst (([Var], Type) -> [Var]) -> ([Var], Type) -> [Var]
forall a b. (a -> b) -> a -> b
$ Type -> ([Var], Type)
splitForAllTyCoVars (Type -> ([Var], Type)) -> Type -> ([Var], Type)
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
b
      -- The defn's leading type/dictionary lambdas correspond to its
      -- signature: map the type binders (positionally) onto the minted
      -- signature variables and skip the erased evidence binders. An eta-reduced
      -- wrapper (e.g. @put = rwPrimPut@) has fewer type lambdas than its
      -- signature quantifies; the leftover signature variables are
      -- type-applied to the body (type-level eta expansion), using the
      -- signature's own binders.
      (ctx', body, nPeeled) <- peelHead an ctx sigTvs rhs
      let leftoverGhc = Uniq -> [Var] -> [Var]
forall a. Uniq -> [a] -> [a]
drop Uniq
nPeeled [Var]
ghcTvs
          leftoverTvs = Uniq -> [TyVar] -> [TyVar]
forall a. Uniq -> [a] -> [a]
drop Uniq
nPeeled [TyVar]
sigTvs
          body''      = (CoreExpr -> Var -> CoreExpr) -> CoreExpr -> [Var] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ CoreExpr
acc Var
gv -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
acc (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> Type -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Var -> Type
mkTyVarTy Var
gv) CoreExpr
body [Var]
leftoverGhc
          ctx''       = ((Var, TyVar) -> Ctx -> Ctx) -> Ctx -> [(Var, TyVar)] -> Ctx
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Var -> TyVar -> Ctx -> Ctx) -> (Var, TyVar) -> Ctx -> Ctx
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Var -> TyVar -> Ctx -> Ctx
bindTyVar) Ctx
ctx' ([(Var, TyVar)] -> Ctx) -> [(Var, TyVar)] -> Ctx
forall a b. (a -> b) -> a -> b
$ [Var] -> [TyVar] -> [(Var, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
leftoverGhc [TyVar]
leftoverTvs
      body' <- if isPrimVar b
            then pure $ mkErrorE an (E.sigTy $ E.idSig x) $ "Prim: " <> qualName mn b
            else bridgeExp ctx'' an body''
      pure E.Defn
            { E.defnAnnote = an
            , E.defnId     = x
            , E.defnParams = []
            , E.defnBody   = body'
            , E.defnAttr   = if isDFunId b || userPred (snd $ splitForAllTyCoVars $ expandTypeSynonyms $ varType b)
                             then Just E.Inline
                             else inlAttr $ inlinePragmaSpec $ idInlinePragma b
            , E.defnOrigin = Nothing
            }
      where peelHead :: MonadError AstError m => Annote -> Ctx -> [E.TyVar] -> CoreExpr -> BM m (Ctx, CoreExpr, Int)
            peelHead :: forall (m :: * -> *).
MonadError AstError m =>
Annote -> Ctx -> [TyVar] -> CoreExpr -> BM m (Ctx, CoreExpr, Uniq)
peelHead Annote
an Ctx
c [TyVar]
tvs = \ case
                  Lam Var
v CoreExpr
e | Var -> Bool
isTyVar Var
v -> case [TyVar]
tvs of
                        (TyVar
tv : [TyVar]
tvs') -> do
                              (c', e', n) <- Annote -> Ctx -> [TyVar] -> CoreExpr -> BM m (Ctx, CoreExpr, Uniq)
forall (m :: * -> *).
MonadError AstError m =>
Annote -> Ctx -> [TyVar] -> CoreExpr -> BM m (Ctx, CoreExpr, Uniq)
peelHead Annote
an (Var -> TyVar -> Ctx -> Ctx
bindTyVar Var
v TyVar
tv Ctx
c) [TyVar]
tvs' CoreExpr
e
                              pure (c', e', n + 1)
                        []          -> Annote -> TyConId -> BM m (Ctx, CoreExpr, Uniq)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported nested type abstraction."
                  Lam Var
v CoreExpr
e | Type -> Bool
erasedEv (Var -> Type
varType Var
v) -> Annote -> Ctx -> [TyVar] -> CoreExpr -> BM m (Ctx, CoreExpr, Uniq)
forall (m :: * -> *).
MonadError AstError m =>
Annote -> Ctx -> [TyVar] -> CoreExpr -> BM m (Ctx, CoreExpr, Uniq)
peelHead Annote
an Ctx
c [TyVar]
tvs CoreExpr
e
                  CoreExpr
e                   -> (Ctx, CoreExpr, Uniq) -> BM m (Ctx, CoreExpr, Uniq)
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ctx
c, CoreExpr
e, Uniq
0)

            inlAttr :: InlineSpec -> Maybe E.DefnAttr
            inlAttr :: InlineSpec -> Maybe DefnAttr
inlAttr = \ case
                  Inline {}    -> DefnAttr -> Maybe DefnAttr
forall a. a -> Maybe a
Just DefnAttr
E.Inline
                  Inlinable {} -> DefnAttr -> Maybe DefnAttr
forall a. a -> Maybe a
Just DefnAttr
E.Inline
                  NoInline {}  -> DefnAttr -> Maybe DefnAttr
forall a. a -> Maybe a
Just DefnAttr
E.NoInline
                  Opaque {}    -> DefnAttr -> Maybe DefnAttr
forall a. a -> Maybe a
Just DefnAttr
E.NoInline
                  InlineSpec
_            -> Maybe DefnAttr
forall a. Maybe a
Nothing

---
--- Types (fail-fast: no Maybe slots to degrade into).
---

bridgeKind :: Type -> E.Kind
bridgeKind :: Type -> Kind
bridgeKind = Type -> Kind
go (Type -> Kind) -> (Type -> Type) -> Type -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
expandTypeSynonyms -- N.B. Nat is a synonym for Natural.
      where go :: Type -> Kind
go = \ case
                  FunTy FunTyFlag
_ Type
_ Type
a Type
r                      -> Kind -> Kind -> Kind
E.KFun (Type -> Kind
go Type
a) (Type -> Kind
go Type
r)
                  TyConApp TyCon
tc [Type]
_ | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
naturalTyCon -> Kind
E.KNat
                  Type
_                                  -> Kind
E.KStar

-- | Core Type -> Eidos Ty. Callers are expected to expandTypeSynonyms
--   first. Constraint (invisible) arrows are dropped; user-class
--   constraint arrows become value arrows (the dictionary is data);
--   single-method ("newtype-dictionary") class types unwrap to their
--   method type (the dictionary IS its method, at both levels).
bridgeTy :: MonadError AstError m => IM.IntMap E.TyVar -> Annote -> Type -> m E.Ty
bridgeTy :: forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy = RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy' RecTcChecker
initRecTc

-- | The worker: the checker bounds newtype-class unwrapping across one
--   type's whole traversal (the regress can cross recursive calls).
bridgeTy' :: MonadError AstError m => RecTcChecker -> IM.IntMap E.TyVar -> Annote -> Type -> m E.Ty
bridgeTy' :: forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy' RecTcChecker
rec IntMap TyVar
tvm Annote
an = Type -> m Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go
      where go :: MonadError AstError m => Type -> m E.Ty
            go :: forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go = \ case
                  TyVarTy Var
v            -> case Uniq -> IntMap TyVar -> Maybe TyVar
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup (Var -> Uniq
uKey Var
v) IntMap TyVar
tvm of
                        Just TyVar
tv -> Ty -> m Ty
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty -> m Ty) -> Ty -> m Ty
forall a b. (a -> b) -> a -> b
$ Annote -> TyVar -> Ty
E.TyVarT Annote
an TyVar
tv
                        Maybe TyVar
Nothing -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: out-of-scope type variable: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v)
                  AppTy Type
a Type
b            -> Annote -> Ty -> Ty -> Ty
E.TyApp Annote
an (Ty -> Ty -> Ty) -> m Ty -> m (Ty -> Ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
a m (Ty -> Ty) -> m Ty -> m Ty
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 Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
b
                  TyConApp TyCon
tc [Type]
args     -> RecTcChecker -> IntMap TyVar -> Annote -> TyCon -> [Type] -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> TyCon -> [Type] -> m Ty
bridgeTyConApp RecTcChecker
rec IntMap TyVar
tvm Annote
an TyCon
tc [Type]
args
                  ForAllTy ForAllTyBinder
_ Type
_         -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported higher-rank type."
                  FunTy FunTyFlag
_ Type
_ Type
a Type
r
                        | Type -> Bool
userPred Type
a    -> Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an (Ty -> Ty -> Ty) -> m Ty -> m (Ty -> Ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
a m (Ty -> Ty) -> m Ty -> m Ty
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 Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
r
                        | Type -> Bool
isEvVarType Type
a -> Type -> m Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
r
                        | Bool
otherwise     -> Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an (Ty -> Ty -> Ty) -> m Ty -> m (Ty -> Ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
a m (Ty -> Ty) -> m Ty -> m Ty
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 Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
r
                  LitTy (NumTyLit Integer
n)   -> Ty -> m Ty
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty -> m Ty) -> Ty -> m Ty
forall a b. (a -> b) -> a -> b
$ Annote -> Natural -> Ty
E.TyNat Annote
an (Natural -> Ty) -> Natural -> Ty
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
n
                  LitTy TyLit
l              -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unsupported type-level literal: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ TyLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyLit
l)
                  CastTy Type
t CoercionR
_           -> Type -> m Ty
forall (m :: * -> *). MonadError AstError m => Type -> m Ty
go Type
t
                  CoercionTy CoercionR
_         -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported coercion in type position."

bridgeTyConApp :: MonadError AstError m => RecTcChecker -> IM.IntMap E.TyVar -> Annote -> TyCon -> [Type] -> m E.Ty
bridgeTyConApp :: forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> TyCon -> [Type] -> m Ty
bridgeTyConApp RecTcChecker
rec IntMap TyVar
tvm Annote
an TyCon
tc [Type]
args
      -- [Char] is Eidos's String.
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon, [TyConApp TyCon
c []] <- [Type]
args, TyCon
c TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
charTyCon
                              = Ty -> m Ty
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty -> m Ty) -> Ty -> m Ty
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> Ty
E.TyCon Annote
an TyConId
"String"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon       = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"[_]"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
boolTyCon       = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"Bool"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unboxedUnitTyCon = [Type] -> TyConId -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
[Type] -> TyConId -> m Ty
appN' [] TyConId
"()"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon       = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"()"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
integerTyCon    = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"Integer"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
naturalTyCon    = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"Integer" -- Natural at the type level: treat as Integer.
      | TyCon -> Bool
isBoxedTupleTyCon TyCon
tc  = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ Uniq -> TyConId
tupleName (Uniq -> TyConId) -> Uniq -> TyConId
forall a b. (a -> b) -> a -> b
$ TyCon -> Uniq
tyConArity TyCon
tc
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
typeNatAddTyCon = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"+"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
typeNatMulTyCon = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"*"
      | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
typeNatSubTyCon = TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN TyConId
"-"
      -- The function tycon in prefix position: [mult, rep1, rep2, a, b].
      | Name -> String
forall a. NamedThing a => a -> String
getOccString (TyCon -> Name
tyConName TyCon
tc) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"FUN"
                              = case [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
args of
            (Type
b : Type
a : [Type]
_) -> Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an (Ty -> Ty -> Ty) -> m Ty -> m (Ty -> Ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy' RecTcChecker
rec IntMap TyVar
tvm Annote
an Type
a m (Ty -> Ty) -> m Ty -> m Ty
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy' RecTcChecker
rec IntMap TyVar
tvm Annote
an Type
b
            [Type]
_           -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsaturated function type constructor."
      -- A single-method (or methodless-with-superclass) user class: GHC
      -- gives it a newtype dictionary, so the predicate type IS the method
      -- (or superclass dictionary) type -- matching the term level, where
      -- the cast-erased dictionary IS the method (see bridgeClassOp).
      -- Unwrap so the class type never reaches Eidos.
      | TyCon -> Bool
isClassTyCon TyCon
tc, TyCon -> Bool
isNewTyCon TyCon
tc, Maybe ModuleName -> Bool
homeishMod (TyCon -> Maybe ModuleName
tyConModule TyCon
tc)
                              = case RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec TyCon
tc of
            Maybe RecTcChecker
Nothing   -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unsupported recursive class dictionary: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
qualTc
            Just RecTcChecker
rec'
                  | [Type] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Type]
args Uniq -> Uniq -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Uniq
tyConArity TyCon
tc
                              -> RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy' RecTcChecker
rec' IntMap TyVar
tvm Annote
an (Type -> m Ty) -> Type -> m Ty
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> Type
newTyConInstRhs TyCon
tc [Type]
args
                  | Bool
otherwise -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unsaturated class constructor: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
qualTc
      | Bool
otherwise             = case (String, String)
-> [((String, String), (TyConId, Uniq))] -> Maybe (TyConId, Uniq)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (TyCon -> (String, String)
tyConKey TyCon
tc) [((String, String), (TyConId, Uniq))]
tyConTable of
            Just (TyConId
n, Uniq
dropN) -> [Type] -> TyConId -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
[Type] -> TyConId -> m Ty
appN' (Uniq -> [Type] -> [Type]
forall a. Uniq -> [a] -> [a]
drop Uniq
dropN [Type]
args) TyConId
n
            Maybe (TyConId, Uniq)
Nothing
                  | Just ModuleName
mn <- TyCon -> Maybe ModuleName
tyConModule TyCon
tc, ModuleName -> Bool
isPrimModule ModuleName
mn
                              -> TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ String -> TyConId
pack (String -> TyConId) -> String -> TyConId
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc
                  | Just ModuleName
mn <- TyCon -> Maybe ModuleName
tyConModule TyCon
tc, Maybe ModuleName -> Bool
homeishMod (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
mn)
                              -> TyConId -> m Ty
forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ String -> TyConId
pack (ModuleName -> String
moduleNameString ModuleName
mn) TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
"." TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc)
                  | Bool
otherwise -> Annote -> TyConId -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> m Ty) -> TyConId -> m Ty
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: type not in the ReWire vocabulary: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
qualTc TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
kindHint
      where appN :: MonadError AstError m => Text -> m E.Ty
            appN :: forall (m :: * -> *). MonadError AstError m => TyConId -> m Ty
appN = [Type] -> TyConId -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
[Type] -> TyConId -> m Ty
appN' [Type]
args

            appN' :: MonadError AstError m => [Type] -> Text -> m E.Ty
            appN' :: forall (m :: * -> *).
MonadError AstError m =>
[Type] -> TyConId -> m Ty
appN' [Type]
as TyConId
n = (Ty -> Ty -> Ty) -> Ty -> [Ty] -> Ty
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Annote -> Ty -> Ty -> Ty
E.TyApp Annote
an) (Annote -> TyConId -> Ty
E.TyCon Annote
an TyConId
n) ([Ty] -> Ty) -> m [Ty] -> m Ty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> m Ty) -> [Type] -> m [Ty]
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 (RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
RecTcChecker -> IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy' RecTcChecker
rec IntMap TyVar
tvm Annote
an) [Type]
as

            qualTc :: Text
            qualTc :: TyConId
qualTc = String -> TyConId
pack (String -> (ModuleName -> String) -> Maybe ModuleName -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"?" ModuleName -> String
moduleNameString (TyCon -> Maybe ModuleName
tyConModule TyCon
tc)) TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
"." TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc)

            -- A leaked kind argument (e.g. a kind-generalized zero-method
            -- class): point at the fix rather than the leak.
            kindHint :: Text
            kindHint :: TyConId
kindHint
                  | TyConId
qualTc TyConId -> [TyConId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyConId
"GHC.Prim.TYPE", TyConId
"GHC.Prim.CONSTRAINT"]
                              = TyConId
" (kind-polymorphic definitions are unsupported; an explicit kind annotation may help, e.g. \"class C (a :: Type)\")"
                  | Bool
otherwise = TyConId
""

---
--- Expressions.
---

mkErrorE :: Annote -> E.Ty -> Text -> E.Exp
mkErrorE :: Annote -> Ty -> TyConId -> Exp
mkErrorE Annote
an Ty
t TyConId
m = Annote -> Exp -> Arg -> Exp
E.App Annote
an (Annote -> Ty -> Builtin -> Exp
E.Prim Annote
an (Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an (Annote -> TyConId -> Ty
E.TyCon Annote
an TyConId
"String") Ty
t) Builtin
B.Error) (Arg -> Exp) -> Arg -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Arg
E.EArg (Exp -> Arg) -> Exp -> Arg
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> Exp
E.LitStr Annote
an TyConId
m

mkApp :: Annote -> E.Exp -> [E.Arg] -> E.Exp
mkApp :: Annote -> Exp -> [Arg] -> Exp
mkApp Annote
an = (Exp -> Arg -> Exp) -> Exp -> [Arg] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Exp -> Arg -> Exp) -> Exp -> [Arg] -> Exp)
-> (Exp -> Arg -> Exp) -> Exp -> [Arg] -> Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Exp -> Arg -> Exp
E.App Annote
an

eargs :: [E.Exp] -> [E.Arg]
eargs :: [Exp] -> [Arg]
eargs = (Exp -> Arg) -> [Exp] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Arg
E.EArg

-- | The bridged, instantiated type of a Core expression, resolving type
--   variables in the enclosing definition's scope.
instTy :: MonadError AstError m => Ctx -> Annote -> CoreExpr -> m E.Ty
instTy :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> m Ty
instTy Ctx
ctx Annote
an CoreExpr
e = IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx) Annote
an (Type -> m Ty) -> Type -> m Ty
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e

bridgeExp :: MonadError AstError m => Ctx -> Annote -> CoreExpr -> BM m E.Exp
bridgeExp :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
e = case CoreExpr
e of
      App {}             -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeApp Ctx
ctx Annote
an CoreExpr
e
      Var {}             -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeApp Ctx
ctx Annote
an CoreExpr
e

      Lit (LitString ByteString
bs) -> Exp -> BM m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> BM m Exp) -> Exp -> BM m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> Exp
E.LitStr Annote
an (TyConId -> Exp) -> TyConId -> Exp
forall a b. (a -> b) -> a -> b
$ ByteString -> TyConId
TE.decodeUtf8 ByteString
bs
      Lit Literal
l              -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> BM m Exp) -> TyConId -> BM m Exp
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unsupported literal (" TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
l) TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
")."

      Lam Var
v CoreExpr
body
            | Var -> Bool
isTyVar Var
v            -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported nested type abstraction."
            | Type -> Bool
erasedEv (Var -> Type
varType Var
v) -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
body
            | Bool
otherwise            -> do
                  t     <- IntMap TyVar -> Annote -> Type -> StateT Uniq m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx) Annote
an (Type -> StateT Uniq m Ty) -> Type -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
v
                  x     <- freshId (localOcc v) $ E.monoSig t
                  body' <- bridgeExp (bindLocal v x ctx) an body
                  pure $ E.Lam an x body'

      -- Lets transliterate (evidence binds erased); a join-tagged binder
      -- becomes a Join bind whose call sites are Jumps.
      Let (NonRec Var
v CoreExpr
r) CoreExpr
body
            | Type -> Bool
erasedEv (Var -> Type
varType Var
v)      -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
body
            | JoinPoint Uniq
n <- Var -> JoinPointHood
idJoinPointHood Var
v -> Ctx -> Annote -> Var -> Uniq -> CoreExpr -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> Uniq -> CoreExpr -> CoreExpr -> BM m Exp
bridgeJoin Ctx
ctx Annote
an Var
v Uniq
n CoreExpr
r CoreExpr
body
            | Bool
otherwise                 -> do
                  t     <- IntMap TyVar -> Annote -> Type -> StateT Uniq m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx) Annote
an (Type -> StateT Uniq m Ty) -> Type -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
v
                  x     <- freshId (localOcc v) $ E.monoSig t
                  r'    <- bridgeExp ctx an r
                  body' <- bridgeExp (bindLocal v x ctx) an body
                  pure $ E.Let an (E.NonRec x r') body'

      Let (Rec [(Var, CoreExpr)]
bs) CoreExpr
body
            | ((Var, CoreExpr) -> Bool) -> [(Var, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ (Var
v, CoreExpr
_) -> case Var -> JoinPointHood
idJoinPointHood Var
v of { JoinPoint Uniq
_ -> Bool
True; JoinPointHood
NotJoinPoint -> Bool
False }) [(Var, CoreExpr)]
bs
                        -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported recursive join point."
            | Bool
otherwise -> do
                  xs <- ((Var, CoreExpr) -> BM m Id)
-> [(Var, CoreExpr)] -> StateT Uniq m [Id]
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
v, CoreExpr
_) -> do
                              t <- IntMap TyVar -> Annote -> Type -> StateT Uniq m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx) Annote
an (Type -> StateT Uniq m Ty) -> Type -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
v
                              freshId (localOcc v) $ E.monoSig t)
                        [(Var, CoreExpr)]
bs
                  let ctx' = (((Var, CoreExpr), Id) -> Ctx -> Ctx)
-> Ctx -> [((Var, CoreExpr), Id)] -> Ctx
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ ((Var
v, CoreExpr
_), Id
x) -> Var -> Id -> Ctx -> Ctx
bindLocal Var
v Id
x) Ctx
ctx ([((Var, CoreExpr), Id)] -> Ctx) -> [((Var, CoreExpr), Id)] -> Ctx
forall a b. (a -> b) -> a -> b
$ [(Var, CoreExpr)] -> [Id] -> [((Var, CoreExpr), Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Var, CoreExpr)]
bs [Id]
xs
                  rs <- mapM (bridgeExp ctx' an . snd) bs
                  body' <- bridgeExp ctx' an body
                  pure $ E.Let an (E.Rec $ zip xs rs) body'

      Case CoreExpr
scrut Var
b Type
ty [Alt Var]
alts -> Ctx -> Annote -> CoreExpr -> Var -> Type -> [Alt Var] -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> Var -> Type -> [Alt Var] -> BM m Exp
bridgeCase Ctx
ctx Annote
an CoreExpr
scrut Var
b Type
ty [Alt Var]
alts

      Cast CoreExpr
e' CoercionR
_            -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
e'
      Tick CoreTickish
_ CoreExpr
e'            -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
e'
      Type Type
_               -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unexpected type in expression position."
      Coercion CoercionR
_           -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unexpected coercion in expression position."

-- | A join point: the binder's arity-many leading lambdas become the
--   join's parameters; type/evidence binders among them are unsupported
--   (join points over erased binders do not survive erasure cleanly).
bridgeJoin :: MonadError AstError m => Ctx -> Annote -> Var -> Int -> CoreExpr -> CoreExpr -> BM m E.Exp
bridgeJoin :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> Uniq -> CoreExpr -> CoreExpr -> BM m Exp
bridgeJoin Ctx
ctx Annote
an Var
v Uniq
n CoreExpr
rhs CoreExpr
body = do
      (vs, jbody) <- Uniq -> CoreExpr -> BM m ([Var], CoreExpr)
forall (m :: * -> *).
MonadError AstError m =>
Uniq -> CoreExpr -> BM m ([Var], CoreExpr)
peel Uniq
n CoreExpr
rhs
      unless (all (\ Var
pv -> Bool -> Bool
not (Var -> Bool
isTyVar Var
pv) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
erasedEv (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
pv)) vs)
            $ failAt an "ghc-frontend: unsupported type- or evidence-binding join point."
      params <- mapM (\ Var
pv -> do
                  t <- IntMap TyVar -> Annote -> Type -> StateT Uniq m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx) Annote
an (Type -> StateT Uniq m Ty) -> Type -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
pv
                  freshId (localOcc pv) $ E.monoSig t)
            vs
      resT   <- bridgeTy (ctxTyVars ctx) an $ expandTypeSynonyms $ exprType jbody
      let jt = (Id -> Ty -> Ty) -> Ty -> [Id] -> Ty
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an (Ty -> Ty -> Ty) -> (Id -> Ty) -> Id -> Ty -> Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sig -> Ty
E.sigTy (Sig -> Ty) -> (Id -> Sig) -> Id -> Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Sig
E.idSig) Ty
resT [Id]
params
      jx     <- freshId (localOcc v) $ E.monoSig jt
      let j    = Id -> Uniq -> JoinId
E.JoinId Id
jx (Uniq -> JoinId) -> Uniq -> JoinId
forall a b. (a -> b) -> a -> b
$ [Id] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Id]
params
          ctxJ = Var -> JoinId -> Ctx -> Ctx
bindJoin Var
v JoinId
j Ctx
ctx
          ctxP = ((Var, Id) -> Ctx -> Ctx) -> Ctx -> [(Var, Id)] -> Ctx
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Var
pv, Id
x) -> Var -> Id -> Ctx -> Ctx
bindLocal Var
pv Id
x) Ctx
ctxJ ([(Var, Id)] -> Ctx) -> [(Var, Id)] -> Ctx
forall a b. (a -> b) -> a -> b
$ [Var] -> [Id] -> [(Var, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vs [Id]
params
      jbody' <- bridgeExp ctxP an jbody
      body'  <- bridgeExp ctxJ an body
      pure $ E.Let an (E.Join j params jbody') body'
      where peel :: MonadError AstError m => Int -> CoreExpr -> BM m ([Var], CoreExpr)
            peel :: forall (m :: * -> *).
MonadError AstError m =>
Uniq -> CoreExpr -> BM m ([Var], CoreExpr)
peel Uniq
0 CoreExpr
e' = ([Var], CoreExpr) -> StateT Uniq m ([Var], CoreExpr)
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], CoreExpr
e')
            peel Uniq
k (Lam Var
pv CoreExpr
e') = do
                  (pvs, e'') <- Uniq -> CoreExpr -> StateT Uniq m ([Var], CoreExpr)
forall (m :: * -> *).
MonadError AstError m =>
Uniq -> CoreExpr -> BM m ([Var], CoreExpr)
peel (Uniq
k Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
- Uniq
1) CoreExpr
e'
                  pure (pv : pvs, e'')
            peel Uniq
_ CoreExpr
_ = Annote -> TyConId -> StateT Uniq m ([Var], CoreExpr)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: join point of unexpected arity."

---
--- Application spines.
---

bridgeApp :: MonadError AstError m => Ctx -> Annote -> CoreExpr -> BM m E.Exp
bridgeApp :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeApp Ctx
ctx Annote
an CoreExpr
e = do
      let (CoreExpr
f, [CoreExpr]
args) = CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e
          vargs :: [CoreExpr]
vargs     = (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
erasedArg) [CoreExpr]
args
      case CoreExpr
f of
            Var Var
v -> Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeVarApp Ctx
ctx Annote
an Var
v [CoreExpr]
args [CoreExpr]
vargs
            -- A cast-headed spine (e.g. an eta-reduced newtype-class dfun
            -- type-applied by the wrapper expansion): the coercion is
            -- erased, so hoist the arguments through it -- dropping the
            -- cast first would strand the head's type arguments.
            Cast CoreExpr
f' CoercionR
_ -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeApp Ctx
ctx Annote
an (CoreExpr -> BM m Exp) -> CoreExpr -> BM m Exp
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
f' [CoreExpr]
args
            Tick CoreTickish
_ CoreExpr
f' -> Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeApp Ctx
ctx Annote
an (CoreExpr -> BM m Exp) -> CoreExpr -> BM m Exp
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
f' [CoreExpr]
args
            CoreExpr
_     -> do
                  f'  <- Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
f
                  as' <- mapM (bridgeExp ctx an) vargs
                  pure $ mkApp an f' $ eargs as'

-- | The bridged type arguments of a spine (the leading Type args), for
--   heads that keep them ('TArg's on Var heads).
spineTArgs :: MonadError AstError m => Ctx -> Annote -> [CoreExpr] -> m [E.Ty]
spineTArgs :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> [CoreExpr] -> m [Ty]
spineTArgs Ctx
ctx Annote
an [CoreExpr]
args = (Type -> m Ty) -> [Type] -> m [Ty]
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 (IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx) Annote
an (Type -> m Ty) -> (Type -> Type) -> Type -> m Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
expandTypeSynonyms)
      [ Type
t | Type Type
t <- (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile CoreExpr -> Bool
isTypeArg [CoreExpr]
args ]
      where isTypeArg :: CoreExpr -> Bool
            isTypeArg :: CoreExpr -> Bool
isTypeArg = \ case
                  Type Type
_ -> Bool
True
                  CoreExpr
_      -> Bool
False

-- | The Var-headed application dispatch: joins, locals, builtins,
--   constructors, class ops, home ids, base vocabulary.
bridgeVarApp :: MonadError AstError m => Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m E.Exp
bridgeVarApp :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeVarApp Ctx
ctx Annote
an Var
v [CoreExpr]
args [CoreExpr]
vargs
      -- The void primitive (a Void#-typed unit value): the boxed unit.
      | Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
voidPrimId = Exp -> StateT Uniq m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> StateT Uniq m Exp) -> Exp -> StateT Uniq m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Ty -> TyConId -> Exp
E.Con Annote
an (Annote -> TyConId -> Ty
E.TyCon Annote
an TyConId
"()") TyConId
"()"

      -- Join point call site: a saturated Jump.
      | Just JoinId
j <- Uniq -> IntMap JoinId -> Maybe JoinId
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup (Var -> Uniq
uKey Var
v) (IntMap JoinId -> Maybe JoinId) -> IntMap JoinId -> Maybe JoinId
forall a b. (a -> b) -> a -> b
$ Ctx -> IntMap JoinId
ctxJoins Ctx
ctx = do
            Bool -> StateT Uniq m () -> StateT Uniq m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CoreExpr] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [CoreExpr]
vargs Uniq -> Uniq -> Bool
forall a. Eq a => a -> a -> Bool
== JoinId -> Uniq
E.jpArity JoinId
j)
                  (StateT Uniq m () -> StateT Uniq m ())
-> StateT Uniq m () -> StateT Uniq m ()
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> StateT Uniq m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsaturated jump to a join point."
            Annote -> JoinId -> [Exp] -> Exp
E.Jump Annote
an JoinId
j ([Exp] -> Exp) -> StateT Uniq m [Exp] -> StateT Uniq m Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CoreExpr -> StateT Uniq m Exp)
-> [CoreExpr] -> StateT Uniq m [Exp]
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 (Ctx -> Annote -> CoreExpr -> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an) [CoreExpr]
vargs

      -- Local binder (lambda, case, let).
      | Just Id
x <- Uniq -> IntMap Id -> Maybe Id
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup (Var -> Uniq
uKey Var
v) (IntMap Id -> Maybe Id) -> IntMap Id -> Maybe Id
forall a b. (a -> b) -> a -> b
$ Ctx -> IntMap Id
ctxLocals Ctx
ctx
            = Annote -> Exp -> [Arg] -> Exp
mkApp Annote
an (Annote -> Id -> Exp
E.Var Annote
an Id
x) ([Arg] -> Exp) -> ([Exp] -> [Arg]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> [Arg]
eargs ([Exp] -> Exp) -> StateT Uniq m [Exp] -> StateT Uniq m Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CoreExpr -> StateT Uniq m Exp)
-> [CoreExpr] -> StateT Uniq m [Exp]
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 (Ctx -> Annote -> CoreExpr -> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an) [CoreExpr]
vargs

      -- rwPrim* -> Prim, by occurrence name, at its instantiated type.
      | Var -> Bool
isPrimVar Var
v = case TyConId -> [(TyConId, Builtin)] -> Maybe Builtin
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> TyConId
pack (String -> TyConId) -> String -> TyConId
forall a b. (a -> b) -> a -> b
$ Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v) [(TyConId, Builtin)]
B.builtins of
            Just Builtin
b  -> do
                  t <- BM m Ty
forall (m :: * -> *). MonadError AstError m => BM m Ty
headTy
                  mkApp an (E.Prim an t b) . eargs <$> mapM (bridgeExp ctx an) vargs
            Maybe Builtin
Nothing -> Annote -> TyConId -> StateT Uniq m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> StateT Uniq m Exp) -> TyConId -> StateT Uniq m Exp
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unknown primitive: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v)

      -- Data constructor (worker or wrapper).
      | Just DataCon
dc <- Var -> Maybe DataCon
isDataConId_maybe Var
v = Ctx
-> Annote
-> Var
-> DataCon
-> [CoreExpr]
-> [CoreExpr]
-> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx
-> Annote -> Var -> DataCon -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeConApp Ctx
ctx Annote
an Var
v DataCon
dc [CoreExpr]
args [CoreExpr]
vargs

      -- Class method selector.
      | Just Class
_ <- Var -> Maybe Class
isClassOpId_maybe Var
v = Ctx
-> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeClassOp Ctx
ctx Annote
an Var
v [CoreExpr]
args [CoreExpr]
vargs

      -- Home top-level id: reference with its type arguments.
      | Just Id
x <- Uniq -> IntMap Id -> Maybe Id
forall a. Uniq -> IntMap a -> Maybe a
IM.lookup (Var -> Uniq
uKey Var
v) (IntMap Id -> Maybe Id) -> IntMap Id -> Maybe Id
forall a b. (a -> b) -> a -> b
$ Ctx -> IntMap Id
ctxTops Ctx
ctx = do
            targs <- m [Ty] -> StateT Uniq m [Ty]
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Ty] -> StateT Uniq m [Ty]) -> m [Ty] -> StateT Uniq m [Ty]
forall a b. (a -> b) -> a -> b
$ Ctx -> Annote -> [CoreExpr] -> m [Ty]
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> [CoreExpr] -> m [Ty]
spineTArgs Ctx
ctx Annote
an [CoreExpr]
args
            as'   <- mapM (bridgeExp ctx an) vargs
            pure $ mkApp an (E.Var an x) $ map E.TArg targs <> eargs as'

      -- Base vocabulary.
      | Bool
otherwise = Ctx
-> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeBaseVocab Ctx
ctx Annote
an Var
v [CoreExpr]
args [CoreExpr]
vargs

      where headTy :: MonadError AstError m => BM m E.Ty
            headTy :: forall (m :: * -> *). MonadError AstError m => BM m Ty
headTy = m Ty -> StateT Uniq m Ty
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ty -> StateT Uniq m Ty) -> m Ty -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Ctx -> Annote -> CoreExpr -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> m Ty
instTy Ctx
ctx Annote
an (CoreExpr -> m Ty) -> CoreExpr -> m Ty
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
v) ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile CoreExpr -> Bool
erasedArg [CoreExpr]
args

-- | Data constructor applications, with the literal folds.
bridgeConApp :: MonadError AstError m => Ctx -> Annote -> Var -> DataCon -> [CoreExpr] -> [CoreExpr] -> BM m E.Exp
bridgeConApp :: forall (m :: * -> *).
MonadError AstError m =>
Ctx
-> Annote -> Var -> DataCon -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeConApp Ctx
ctx Annote
an Var
v DataCon
dc [CoreExpr]
args [CoreExpr]
vargs
      -- The unboxed unit (nullary join points take a (# #) argument): treat
      -- as the boxed unit, matching the type-level mapping.
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
unboxedUnitDataCon = Exp -> StateT Uniq m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> StateT Uniq m Exp) -> Exp -> StateT Uniq m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Ty -> TyConId -> Exp
E.Con Annote
an (Annote -> TyConId -> Ty
E.TyCon Annote
an TyConId
"()") TyConId
"()"

      -- Boxed integer literals: IS 5# / IP bigNat# / IN bigNat#.
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerISDataCon, [Lit (LitNumber LitNumType
_ Integer
n)] <- [CoreExpr]
vargs = Integer -> StateT Uniq m Exp
forall (m :: * -> *). MonadError AstError m => Integer -> BM m Exp
litInt Integer
n
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerIPDataCon, [Lit (LitNumber LitNumType
_ Integer
n)] <- [CoreExpr]
vargs = Integer -> StateT Uniq m Exp
forall (m :: * -> *). MonadError AstError m => Integer -> BM m Exp
litInt Integer
n
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerINDataCon, [Lit (LitNumber LitNumType
_ Integer
n)] <- [CoreExpr]
vargs = Integer -> StateT Uniq m Exp
forall (m :: * -> *). MonadError AstError m => Integer -> BM m Exp
litInt (Integer -> StateT Uniq m Exp) -> Integer -> StateT Uniq m Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
negate Integer
n
      | DataCon
dc DataCon -> [DataCon] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DataCon
integerISDataCon, DataCon
integerIPDataCon, DataCon
integerINDataCon]
            = Annote -> TyConId -> StateT Uniq m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: Integer constructor applied to a non-literal."

      -- List literals: cons chains and nil.
      | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
nilDataCon Bool -> Bool -> Bool
|| DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon = do
            elems <- CoreExpr -> BM m [CoreExpr]
forall (m :: * -> *).
MonadError AstError m =>
CoreExpr -> BM m [CoreExpr]
listElems (CoreExpr -> BM m [CoreExpr]) -> CoreExpr -> BM m [CoreExpr]
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
v) [CoreExpr]
args
            ty    <- lift $ instTy ctx an $ foldl App (Var v) args
            case (elems, ty) of
                  ([], E.TyCon Annote
_ TyConId
"String") -> Exp -> StateT Uniq m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> StateT Uniq m Exp) -> Exp -> StateT Uniq m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> Exp
E.LitStr Annote
an TyConId
""
                  ([CoreExpr], Ty)
_                        -> Annote -> Ty -> [Exp] -> Exp
E.LitList Annote
an Ty
ty ([Exp] -> Exp) -> StateT Uniq m [Exp] -> StateT Uniq m Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CoreExpr -> StateT Uniq m Exp)
-> [CoreExpr] -> StateT Uniq m [Exp]
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 (Ctx -> Annote -> CoreExpr -> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an) [CoreExpr]
elems

      | Bool
otherwise = do
            t <- m Ty -> StateT Uniq m Ty
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ty -> StateT Uniq m Ty) -> m Ty -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Ctx -> Annote -> CoreExpr -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> m Ty
instTy Ctx
ctx Annote
an (CoreExpr -> m Ty) -> CoreExpr -> m Ty
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
v) ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile CoreExpr -> Bool
erasedArg [CoreExpr]
args
            mkApp an (E.Con an t $ conName dc) . eargs <$> mapM (bridgeExp ctx an) vargs

      where litInt :: MonadError AstError m => Integer -> BM m E.Exp
            litInt :: forall (m :: * -> *). MonadError AstError m => Integer -> BM m Exp
litInt Integer
n = Exp -> StateT Uniq m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> StateT Uniq m Exp) -> Exp -> StateT Uniq m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Ty -> Integer -> Exp
E.LitInt Annote
an (Annote -> TyConId -> Ty
E.TyCon Annote
an TyConId
"Integer") Integer
n

            listElems :: MonadError AstError m => CoreExpr -> BM m [CoreExpr]
            listElems :: forall (m :: * -> *).
MonadError AstError m =>
CoreExpr -> BM m [CoreExpr]
listElems CoreExpr
e = case CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e of
                  (Var Var
v', [CoreExpr]
as)
                        | Just DataCon
dc' <- Var -> Maybe DataCon
isDataConId_maybe Var
v', DataCon
dc' DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
nilDataCon  -> [CoreExpr] -> BM m [CoreExpr]
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                        | Just DataCon
dc' <- Var -> Maybe DataCon
isDataConId_maybe Var
v', DataCon
dc' DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon
                        , [CoreExpr
hd, CoreExpr
tl] <- (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
erasedArg) [CoreExpr]
as              -> (CoreExpr
hd CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:) ([CoreExpr] -> [CoreExpr]) -> BM m [CoreExpr] -> BM m [CoreExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> BM m [CoreExpr]
forall (m :: * -> *).
MonadError AstError m =>
CoreExpr -> BM m [CoreExpr]
listElems CoreExpr
tl
                  (CoreExpr, [CoreExpr])
_ -> Annote -> TyConId -> BM m [CoreExpr]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported non-literal list (lists must be literal cons chains)."

-- | Class method dispatch: user-class methods project the field out of the
--   dictionary (ordinary data, via a single-alternative case; a newtype
--   dictionary IS its method, applied directly); >>=, >>,
--   return, pure at ReacT\/StateT\/Identity or at an unresolved monad type
--   become Bind/Return primitives (dictionary discarded; a concrete monad
--   off the reactive stack is rejected).
bridgeClassOp :: MonadError AstError m => Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m E.Exp
bridgeClassOp :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeClassOp Ctx
ctx Annote
an Var
v [CoreExpr]
args [CoreExpr]
vargs
      | Just Class
cls <- Var -> Maybe Class
isClassOpId_maybe Var
v
      , Maybe ModuleName -> Bool
homeishMod (TyCon -> Maybe ModuleName
tyConModule (TyCon -> Maybe ModuleName) -> TyCon -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ Class -> TyCon
classTyCon Class
cls) = case [CoreExpr]
vargs of
            (CoreExpr
d : [CoreExpr]
rest) -> do
                  d' <- Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
d
                  if isNewTyCon (classTyCon cls)
                        -- A newtype dictionary IS its method.
                        then mkApp an d' . eargs <$> mapM (bridgeExp ctx an) rest
                        else do
                              let dcls = TyCon -> DataCon
tyConSingleDataCon (TyCon -> DataCon) -> TyCon -> DataCon
forall a b. (a -> b) -> a -> b
$ Class -> TyCon
classTyCon Class
cls
                                  sels = Class -> [Var]
classAllSelIds Class
cls
                              i      <- maybe (failAt an $ "ghc-frontend: unknown class method: " <> occ) pure
                                          $ elemIndex v sels
                              -- Field types: the dictionary constructor's
                              -- theta (superclasses) and method fields,
                              -- instantiated at the class's type arguments.
                              let clsArgs = [ Type
t | Type Type
t <- (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile CoreExpr -> Bool
isTypeArg [CoreExpr]
args ]
                                  fieldTs = [Var] -> [Type] -> Type -> Type
HasDebugCallStack => [Var] -> [Type] -> Type -> Type
substTyWith (DataCon -> [Var]
dataConUnivTyVars DataCon
dcls) [Type]
clsArgs
                                            (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon -> [Type]
dataConTheta DataCon
dcls [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
dcls))
                              fieldTs' <- lift $ mapM (bridgeTy (ctxTyVars ctx) an . expandTypeSynonyms) fieldTs
                              flds     <- zipWithM (\ Uniq
k Ty
t -> TyConId -> Sig -> StateT Uniq m Id
forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId (TyConId
"dictField" TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Uniq -> String
forall a. Show a => a -> String
show (Uniq
k :: Int))) (Sig -> StateT Uniq m Id) -> Sig -> StateT Uniq m Id
forall a b. (a -> b) -> a -> b
$ Ty -> Sig
E.monoSig Ty
t)
                                                [0 ..] fieldTs'
                              fldTy    <- maybe (failAt an "ghc-frontend: class method index out of range (rwc bug).") pure
                                          $ lookup i $ zip [0 ..] fieldTs'
                              dTy      <- lift $ instTy ctx an d
                              cb       <- freshId "dict" $ E.monoSig dTy
                              let proj = Annote -> Ty -> Exp -> Id -> [Alt] -> Exp
E.Case Annote
an Ty
fldTy Exp
d' Id
cb
                                          [ Annote -> AltCon -> [Id] -> Exp -> Alt
E.Alt Annote
an (TyConId -> AltCon
E.DataAlt (TyConId -> AltCon) -> TyConId -> AltCon
forall a b. (a -> b) -> a -> b
$ DataCon -> TyConId
conName DataCon
dcls) [Id]
flds
                                              (Exp -> Alt) -> Exp -> Alt
forall a b. (a -> b) -> a -> b
$ Annote -> Id -> Exp
E.Var Annote
an (Id -> Exp) -> Id -> Exp
forall a b. (a -> b) -> a -> b
$ [Id]
flds [Id] -> Uniq -> Id
forall a. HasCallStack => [a] -> Uniq -> a
!! Uniq
i ]
                              mkApp an proj . eargs <$> mapM (bridgeExp ctx an) rest
            [CoreExpr]
_          -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> BM m Exp) -> TyConId -> BM m Exp
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unapplied class method: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
occ
      | TyConId
occ TyConId -> [TyConId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([TyConId
">>=", TyConId
">>", TyConId
"return", TyConId
"pure"] :: [Text]) = case Maybe TyConId
tyArgHead of
            Just TyConId
tcn | TyConId
tcn TyConId -> [TyConId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([TyConId
"ReacT", TyConId
"StateT", TyConId
"Identity"] :: [Text])
                     -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> BM m Exp) -> TyConId -> BM m Exp
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: monadic operator at unsupported monad: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
tcn
            -- A reactive-stack monad or one not yet resolved (e.g., a type
            -- variable in the body of a monad-polymorphic helper): emit the
            -- polymorphic primitive; the specializer resolves it.
            Maybe TyConId
_        -> case TyConId
occ of
                  TyConId
">>=" -> do
                        t <- StateT Uniq m Ty
forall (m :: * -> *). MonadError AstError m => BM m Ty
opTy
                        mkApp an (E.Prim an t B.Bind) . eargs <$> mapM (bridgeExp ctx an) vargs
                  TyConId
">>"  -> case [CoreExpr]
vargs of
                        [CoreExpr
e1, CoreExpr
e2] -> do
                              -- e1 >> e2 becomes bind e1 (\ _ -> e2): the
                              -- primitive's type is built from (>>)'s
                              -- instantiated m a -> m b -> m b.
                              t <- StateT Uniq m Ty
forall (m :: * -> *). MonadError AstError m => BM m Ty
opTy
                              (ma, mb) <- case flattenArrow t of
                                    ([Ty
ta, Ty
tb], Ty
_) -> (Ty, Ty) -> StateT Uniq m (Ty, Ty)
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty
ta, Ty
tb)
                                    ([Ty], Ty)
_             -> Annote -> TyConId -> StateT Uniq m (Ty, Ty)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unexpected type for (>>)."
                              a <- case flattenTyApp ma of
                                    (Ty
_, [Ty]
as) | Bool -> Bool
not ([Ty] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ty]
as) -> Ty -> StateT Uniq m Ty
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty -> StateT Uniq m Ty) -> Ty -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ [Ty] -> Ty
forall a. HasCallStack => [a] -> a
last [Ty]
as
                                    (Ty, [Ty])
_                       -> Annote -> TyConId -> StateT Uniq m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unexpected monadic type for (>>)."
                              let bindT = Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an Ty
ma (Ty -> Ty) -> Ty -> Ty
forall a b. (a -> b) -> a -> b
$ Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an (Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an Ty
a Ty
mb) Ty
mb
                              e1' <- bridgeExp ctx an e1
                              e2' <- bridgeExp ctx an e2
                              k   <- freshId "_unused" $ E.monoSig a
                              pure $ mkApp an (E.Prim an bindT B.Bind) $ eargs [e1', E.Lam an k e2']
                        [CoreExpr]
_        -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsaturated (>>)."
                  TyConId
_     -> do -- return/pure
                        t <- StateT Uniq m Ty
forall (m :: * -> *). MonadError AstError m => BM m Ty
opTy
                        mkApp an (E.Prim an t B.Return) . eargs <$> mapM (bridgeExp ctx an) vargs
      | Bool
otherwise = Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> BM m Exp) -> TyConId -> BM m Exp
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unsupported use of a type class method: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
clsOcc TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
"." TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
occ
            TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
" (" TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
clsOcc TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
" is an external class; methods of external classes cannot be compiled)."
      where occ :: Text
            occ :: TyConId
occ = String -> TyConId
pack (String -> TyConId) -> String -> TyConId
forall a b. (a -> b) -> a -> b
$ Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v

            clsOcc :: Text
            clsOcc :: TyConId
clsOcc = TyConId -> (Class -> TyConId) -> Maybe Class -> TyConId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TyConId
"?" (String -> TyConId
pack (String -> TyConId) -> (Class -> String) -> Class -> TyConId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> (Class -> Name) -> Class -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
tyConName (TyCon -> Name) -> (Class -> TyCon) -> Class -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> TyCon
classTyCon) (Maybe Class -> TyConId) -> Maybe Class -> TyConId
forall a b. (a -> b) -> a -> b
$ Var -> Maybe Class
isClassOpId_maybe Var
v

            -- The op's instantiated type (constraint arrows dropped by the
            -- type bridge).
            opTy :: MonadError AstError m => BM m E.Ty
            opTy :: forall (m :: * -> *). MonadError AstError m => BM m Ty
opTy = m Ty -> StateT Uniq m Ty
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ty -> StateT Uniq m Ty) -> m Ty -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Ctx -> Annote -> CoreExpr -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> m Ty
instTy Ctx
ctx Annote
an (CoreExpr -> m Ty) -> CoreExpr -> m Ty
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
v) ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile CoreExpr -> Bool
erasedArg [CoreExpr]
args

            isTypeArg :: CoreExpr -> Bool
            isTypeArg :: CoreExpr -> Bool
isTypeArg = \ case
                  Type Type
_ -> Bool
True
                  CoreExpr
_      -> Bool
False

            -- The head tycon of the first type argument.
            tyArgHead :: Maybe Text
            tyArgHead :: Maybe TyConId
tyArgHead = case [ Type
t | Type Type
t <- [CoreExpr]
args ] of
                  (Type
t : [Type]
_) -> case Type -> Type
expandTypeSynonyms Type
t of
                        TyConApp TyCon
tc [Type]
_ | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
integerTyCon -> TyConId -> Maybe TyConId
forall a. a -> Maybe a
Just TyConId
"Integer"
                                      | Bool
otherwise          -> TyConId -> Maybe TyConId
forall a. a -> Maybe a
Just (TyConId -> Maybe TyConId) -> TyConId -> Maybe TyConId
forall a b. (a -> b) -> a -> b
$ TyCon -> TyConId
headName TyCon
tc
                        Type
_             -> Maybe TyConId
forall a. Maybe a
Nothing
                  [Type]
_       -> Maybe TyConId
forall a. Maybe a
Nothing

            headName :: TyCon -> Text
            headName :: TyCon -> TyConId
headName TyCon
tc = case (String, String)
-> [((String, String), (TyConId, Uniq))] -> Maybe (TyConId, Uniq)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (TyCon -> (String, String)
tyConKey TyCon
tc) [((String, String), (TyConId, Uniq))]
tyConTable of
                  Just (TyConId
n, Uniq
_) -> TyConId
n
                  Maybe (TyConId, Uniq)
Nothing     -> String -> TyConId
pack (String -> TyConId) -> String -> TyConId
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc

-- | The base vocabulary: error functions map to the Error primitive;
--   string unpacking folds to LitStr; the small closed set of Prelude
--   combinators maps to the synthesized vocabulary definitions.
bridgeBaseVocab :: MonadError AstError m => Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m E.Exp
bridgeBaseVocab :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> Var -> [CoreExpr] -> [CoreExpr] -> BM m Exp
bridgeBaseVocab Ctx
ctx Annote
an Var
v [CoreExpr]
args [CoreExpr]
vargs
      | TyConId
occ TyConId -> [TyConId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([TyConId
"unpackCString#", TyConId
"unpackCStringUtf8#"] :: [Text]) = case [CoreExpr]
vargs of
            [Lit (LitString ByteString
bs)] -> Exp -> BM m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> BM m Exp) -> Exp -> BM m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> Exp
E.LitStr Annote
an (TyConId -> Exp) -> TyConId -> Exp
forall a b. (a -> b) -> a -> b
$ ByteString -> TyConId
TE.decodeUtf8 ByteString
bs
            [CoreExpr]
_                    -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unpackCString# applied to a non-literal."

      | TyConId
occ TyConId -> [TyConId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([TyConId
"error", TyConId
"errorWithoutStackTrace", TyConId
"undefined"] :: [Text]) = do
            t   <- m Ty -> StateT Uniq m Ty
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ty -> StateT Uniq m Ty) -> m Ty -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Ctx -> Annote -> CoreExpr -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> m Ty
instTy Ctx
ctx Annote
an (CoreExpr -> m Ty) -> CoreExpr -> m Ty
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
v) [CoreExpr]
args
            as' <- mapM (bridgeExp ctx an) vargs
            case (occ, as') of
                  (TyConId
"undefined", [Exp]
_) -> Exp -> BM m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> BM m Exp) -> Exp -> BM m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Ty -> TyConId -> Exp
mkErrorE Annote
an Ty
t TyConId
"Prelude.undefined"
                  (TyConId
_, [Exp
s])         -> Exp -> BM m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> BM m Exp) -> Exp -> BM m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Exp -> Arg -> Exp
E.App Annote
an (Annote -> Ty -> Builtin -> Exp
E.Prim Annote
an (Annote -> Ty -> Ty -> Ty
E.Arrow Annote
an (Annote -> TyConId -> Ty
E.TyCon Annote
an TyConId
"String") Ty
t) Builtin
B.Error) (Arg -> Exp) -> Arg -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Arg
E.EArg Exp
s
                  (TyConId, [Exp])
_                -> Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported use of error."

      | TyConId
occ TyConId -> [TyConId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([ TyConId
"patError", TyConId
"absentError", TyConId
"nonExhaustiveGuardsError"
                    , TyConId
"noMethodBindingError", TyConId
"recSelError", TyConId
"typeError" ] :: [Text]) = do
            t <- m Ty -> StateT Uniq m Ty
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Ty -> StateT Uniq m Ty) -> m Ty -> StateT Uniq m Ty
forall a b. (a -> b) -> a -> b
$ Ctx -> Annote -> CoreExpr -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> m Ty
instTy Ctx
ctx Annote
an (CoreExpr -> m Ty) -> CoreExpr -> m Ty
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
v) [CoreExpr]
args
            pure $ mkErrorE an t "Pattern match failure: non-exhaustive patterns in case"

      | Just TyConId
n <- TyConId -> [(TyConId, TyConId)] -> Maybe TyConId
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TyConId
occ ([(TyConId, TyConId)] -> Maybe TyConId)
-> Maybe [(TyConId, TyConId)] -> Maybe TyConId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TyConId
 -> [(TyConId, [(TyConId, TyConId)])] -> Maybe [(TyConId, TyConId)])
-> [(TyConId, [(TyConId, TyConId)])]
-> TyConId
-> Maybe [(TyConId, TyConId)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip TyConId
-> [(TyConId, [(TyConId, TyConId)])] -> Maybe [(TyConId, TyConId)]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(TyConId, [(TyConId, TyConId)])]
vocabTable (TyConId -> Maybe [(TyConId, TyConId)])
-> Maybe TyConId -> Maybe [(TyConId, TyConId)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe TyConId
modName
      , Just Id
x <- TyConId -> [(TyConId, Id)] -> Maybe Id
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TyConId
n ([(TyConId, Id)] -> Maybe Id) -> [(TyConId, Id)] -> Maybe Id
forall a b. (a -> b) -> a -> b
$ Ctx -> [(TyConId, Id)]
ctxVocab Ctx
ctx = do
            -- Drop leading runtime-rep/levity type arguments BEFORE bridging
            -- (they are not in the Eidos vocabulary): the vocabulary
            -- signatures quantify only the value type variables (the last k
            -- type arguments).
            let rawTs :: [Type]
rawTs       = [ Type
t | Type Type
t <- (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile CoreExpr -> Bool
isTypeArgV [CoreExpr]
args ]
                E.Sig [TyVar]
tvs Ty
_ = Id -> Sig
E.idSig Id
x
                k :: Uniq
k           = [TyVar] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [TyVar]
tvs
            Bool -> StateT Uniq m () -> StateT Uniq m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Type]
rawTs Uniq -> Uniq -> Bool
forall a. Ord a => a -> a -> Bool
>= Uniq
k)
                  (StateT Uniq m () -> StateT Uniq m ())
-> StateT Uniq m () -> StateT Uniq m ()
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> StateT Uniq m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> StateT Uniq m ()) -> TyConId -> StateT Uniq m ()
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: under-instantiated vocabulary reference: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
occ
            targs <- m [Ty] -> StateT Uniq m [Ty]
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Ty] -> StateT Uniq m [Ty]) -> m [Ty] -> StateT Uniq m [Ty]
forall a b. (a -> b) -> a -> b
$ (Type -> m Ty) -> [Type] -> m [Ty]
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 (IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx) Annote
an (Type -> m Ty) -> (Type -> Type) -> Type -> m Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
expandTypeSynonyms) ([Type] -> m [Ty]) -> [Type] -> m [Ty]
forall a b. (a -> b) -> a -> b
$ Uniq -> [Type] -> [Type]
forall a. Uniq -> [a] -> [a]
drop ([Type] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Type]
rawTs Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
- Uniq
k) [Type]
rawTs
            as' <- mapM (bridgeExp ctx an) vargs
            pure $ mkApp an (E.Var an x) $ map E.TArg targs <> eargs as'

      | Bool
otherwise = Annote -> TyConId -> BM m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> BM m Exp) -> TyConId -> BM m Exp
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: not in the ReWire vocabulary: "
            TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId -> (TyConId -> TyConId) -> Maybe TyConId -> TyConId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TyConId
"?" TyConId -> TyConId
forall a. a -> a
id Maybe TyConId
modName TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
"." TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
occ

      where occ :: Text
            occ :: TyConId
occ = String -> TyConId
pack (String -> TyConId) -> String -> TyConId
forall a b. (a -> b) -> a -> b
$ Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v

            isTypeArgV :: CoreExpr -> Bool
            isTypeArgV :: CoreExpr -> Bool
isTypeArgV = \ case
                  Type Type
_ -> Bool
True
                  CoreExpr
_      -> Bool
False

            modName :: Maybe Text
            modName :: Maybe TyConId
modName = String -> TyConId
pack (String -> TyConId)
-> (GenModule Unit -> String) -> GenModule Unit -> TyConId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString (ModuleName -> String)
-> (GenModule Unit -> ModuleName) -> GenModule Unit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> TyConId)
-> Maybe (GenModule Unit) -> Maybe TyConId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe (GenModule Unit)
nameModule_maybe (Var -> Name
varName Var
v)

---
--- Case expressions (n-ary, transliterated; Core orders DEFAULT first).
---

bridgeCase :: MonadError AstError m => Ctx -> Annote -> CoreExpr -> Var -> Type -> [Alt Var] -> BM m E.Exp
bridgeCase :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> Var -> Type -> [Alt Var] -> BM m Exp
bridgeCase Ctx
ctx Annote
an CoreExpr
scrut Var
b Type
ty [Alt Var]
alts = do
      scrut'  <- Ctx -> Annote -> CoreExpr -> BM m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx Annote
an CoreExpr
scrut
      resTy   <- lift $ bridgeTy (ctxTyVars ctx) an $ expandTypeSynonyms ty
      scrutTy <- lift $ instTy ctx an scrut
      case alts of
            -- Zero-alt case: the scrutinee is bottom (e.g. patError).
            [] -> Exp -> BM m Exp
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> BM m Exp) -> Exp -> BM m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Ty -> TyConId -> Exp
mkErrorE Annote
an Ty
resTy TyConId
"Pattern match failure: non-exhaustive patterns in case"
            [Alt Var]
_  -> do
                  cb    <- TyConId -> Sig -> BM m Id
forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId (Var -> TyConId
localOcc Var
b) (Sig -> BM m Id) -> Sig -> BM m Id
forall a b. (a -> b) -> a -> b
$ Ty -> Sig
E.monoSig Ty
scrutTy
                  let ctx' = Var -> Id -> Ctx -> Ctx
bindLocal Var
b Id
cb Ctx
ctx
                  alts' <- mapM (bridgeAlt ctx') alts
                  pure $ E.Case an resTy scrut' cb alts'
      where bridgeAlt :: MonadError AstError m => Ctx -> Alt Var -> BM m E.Alt
            bridgeAlt :: forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Alt Var -> BM m Alt
bridgeAlt Ctx
ctx' (Alt AltCon
con [Var]
vs CoreExpr
rhs) = case AltCon
con of
                  AltCon
DEFAULT    -> Annote -> AltCon -> [Id] -> Exp -> Alt
E.Alt Annote
an AltCon
E.DefaultAlt [] (Exp -> Alt) -> StateT Uniq m Exp -> BM m Alt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ctx -> Annote -> CoreExpr -> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx' Annote
an CoreExpr
rhs
                  LitAlt (LitNumber LitNumType
_ Integer
n) -> Annote -> AltCon -> [Id] -> Exp -> Alt
E.Alt Annote
an (Integer -> AltCon
E.LitAlt Integer
n) [] (Exp -> Alt) -> StateT Uniq m Exp -> BM m Alt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ctx -> Annote -> CoreExpr -> StateT Uniq m Exp
forall (m :: * -> *).
MonadError AstError m =>
Ctx -> Annote -> CoreExpr -> BM m Exp
bridgeExp Ctx
ctx' Annote
an CoreExpr
rhs
                  LitAlt Literal
l   -> Annote -> TyConId -> BM m Alt
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> BM m Alt) -> TyConId -> BM m Alt
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unsupported literal pattern (" TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
l) TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
")."
                  DataAlt DataCon
dc -> do
                        let flds :: [Var]
flds = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ Var
pv -> Bool -> Bool
not (Var -> Bool
isTyVar Var
pv) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
erasedEv (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
pv)) [Var]
vs
                            -- Field types: instantiate at the scrutinee's
                            -- type arguments.
                            scrutArgs :: [Type]
scrutArgs = case Type -> Type
expandTypeSynonyms (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
scrut of
                                  TyConApp TyCon
_ [Type]
as -> [Type]
as
                                  Type
_             -> []
                            fieldTs :: [Type]
fieldTs   = [Var] -> [Type] -> Type -> Type
HasDebugCallStack => [Var] -> [Type] -> Type -> Type
substTyWith (DataCon -> [Var]
dataConUnivTyVars DataCon
dc) [Type]
scrutArgs
                                        (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon -> [Type]
dataConTheta DataCon
dc [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
dc))
                        Bool -> StateT Uniq m () -> StateT Uniq m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Type]
fieldTs Uniq -> Uniq -> Bool
forall a. Eq a => a -> a -> Bool
== [Var] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Var]
flds)
                              (StateT Uniq m () -> StateT Uniq m ())
-> StateT Uniq m () -> StateT Uniq m ()
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> StateT Uniq m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> StateT Uniq m ()) -> TyConId -> StateT Uniq m ()
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: constructor field arity mismatch in case alternative: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> DataCon -> TyConId
conName DataCon
dc
                              TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
" (" TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Uniq -> String
forall a. Show a => a -> String
show ([Var] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Var]
flds)) TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
" binders, " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Uniq -> String
forall a. Show a => a -> String
show ([Type] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Type]
fieldTs)) TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
" fields)."
                        fieldTs' <- m [Ty] -> StateT Uniq m [Ty]
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Ty] -> StateT Uniq m [Ty]) -> m [Ty] -> StateT Uniq m [Ty]
forall a b. (a -> b) -> a -> b
$ (Type -> m Ty) -> [Type] -> m [Ty]
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 (IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy (Ctx -> IntMap TyVar
ctxTyVars Ctx
ctx') Annote
an (Type -> m Ty) -> (Type -> Type) -> Type -> m Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
expandTypeSynonyms) [Type]
fieldTs
                        xs       <- zipWithM (\ Var
pv Ty
t -> TyConId -> Sig -> StateT Uniq m Id
forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId (Var -> TyConId
localOcc Var
pv) (Sig -> StateT Uniq m Id) -> Sig -> StateT Uniq m Id
forall a b. (a -> b) -> a -> b
$ Ty -> Sig
E.monoSig Ty
t) flds fieldTs'
                        let ctx'' = ((Var, Id) -> Ctx -> Ctx) -> Ctx -> [(Var, Id)] -> Ctx
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Var
pv, Id
x) -> Var -> Id -> Ctx -> Ctx
bindLocal Var
pv Id
x) Ctx
ctx' ([(Var, Id)] -> Ctx) -> [(Var, Id)] -> Ctx
forall a b. (a -> b) -> a -> b
$ [Var] -> [Id] -> [(Var, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
flds [Id]
xs
                        E.Alt an (E.DataAlt $ conName dc) xs <$> bridgeExp ctx'' an rhs

---
--- Datatypes.
---

-- | User DataDefns from a module's tycons; RWC.Primitives' tycons are
--   supplied by the primitive basis and skipped here.
harvestDatas :: MonadError AstError m => ModGuts -> BM m [E.DataDefn]
harvestDatas :: forall (m :: * -> *).
MonadError AstError m =>
ModGuts -> BM m [DataDefn]
harvestDatas ModGuts
g
      | ModuleName -> Bool
isPrimModule ModuleName
mn = [DataDefn] -> StateT Uniq m [DataDefn]
forall a. a -> StateT Uniq m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise       = (TyCon -> StateT Uniq m DataDefn)
-> [TyCon] -> StateT Uniq m [DataDefn]
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 TyCon -> StateT Uniq m DataDefn
forall (m :: * -> *).
MonadError AstError m =>
TyCon -> BM m DataDefn
harvest ([TyCon] -> StateT Uniq m [DataDefn])
-> [TyCon] -> StateT Uniq m [DataDefn]
forall a b. (a -> b) -> a -> b
$ (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
wanted ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$ ModGuts -> [TyCon]
mg_tcs ModGuts
g
      where mn :: ModuleName
mn = GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModGuts -> GenModule Unit
mg_module ModGuts
g

            wanted :: TyCon -> Bool
            wanted :: TyCon -> Bool
wanted TyCon
tc = TyCon -> Bool
isAlgTyCon TyCon
tc Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
isTypeSynonymTyCon TyCon
tc) Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
isBoxedTupleTyCon TyCon
tc)
                  Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
isClassTyCon TyCon
tc Bool -> Bool -> Bool
&& TyCon -> Bool
isNewTyCon TyCon
tc)

            harvest :: MonadError AstError m => TyCon -> BM m E.DataDefn
            harvest :: forall (m :: * -> *).
MonadError AstError m =>
TyCon -> BM m DataDefn
harvest TyCon
tc = do
                  -- The datatype's parameters are minted once and shared by
                  -- every constructor signature (the lint requires the same
                  -- quantifiers across a datatype's constructors).
                  (tvs, _) <- Annote -> [Var] -> BM m ([TyVar], IntMap TyVar)
forall (m :: * -> *).
MonadError AstError m =>
Annote -> [Var] -> BM m ([TyVar], IntMap TyVar)
mintTyVars Annote
an ([Var] -> BM m ([TyVar], IntMap TyVar))
-> [Var] -> BM m ([TyVar], IntMap TyVar)
forall a b. (a -> b) -> a -> b
$ TyCon -> [Var]
tyConTyVars TyCon
tc
                  E.DataDefn an name (bridgeKind $ tyConKind tc) <$> mapM (dataCon tvs) (tyConDataCons tc)
                  where an :: Annote
an   = SrcSpan -> Annote
spanAnnote (SrcSpan -> Annote) -> SrcSpan -> Annote
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc
                        name :: TyConId
name = String -> TyConId
pack (ModuleName -> String
moduleNameString ModuleName
mn) TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> TyConId
"." TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> String -> TyConId
pack (Name -> String
forall a. NamedThing a => a -> String
getOccString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
tyConName TyCon
tc)

                        dataCon :: MonadError AstError m => [E.TyVar] -> DataCon -> BM m E.DataCon
                        dataCon :: forall (m :: * -> *).
MonadError AstError m =>
[TyVar] -> DataCon -> BM m DataCon
dataCon [TyVar]
tvs DataCon
dc | Bool -> Bool
not ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Var] -> Bool) -> [Var] -> Bool
forall a b. (a -> b) -> a -> b
$ DataCon -> [Var]
dataConExTyCoVars DataCon
dc) = Annote -> TyConId -> StateT Uniq m DataCon
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an TyConId
"ghc-frontend: unsupported existential data constructor."
                                       | Bool
otherwise = do
                              -- A vanilla constructor's universals coincide
                              -- with the datatype's parameters; map them
                              -- positionally onto the shared variables.
                              let univs :: [Var]
univs = DataCon -> [Var]
dataConUnivTyVars DataCon
dc
                              Bool -> StateT Uniq m () -> StateT Uniq m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Var] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [Var]
univs Uniq -> Uniq -> Bool
forall a. Eq a => a -> a -> Bool
== [TyVar] -> Uniq
forall a. [a] -> Uniq
forall (t :: * -> *) a. Foldable t => t a -> Uniq
length [TyVar]
tvs)
                                    (StateT Uniq m () -> StateT Uniq m ())
-> StateT Uniq m () -> StateT Uniq m ()
forall a b. (a -> b) -> a -> b
$ Annote -> TyConId -> StateT Uniq m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> TyConId -> m a
failAt Annote
an (TyConId -> StateT Uniq m ()) -> TyConId -> StateT Uniq m ()
forall a b. (a -> b) -> a -> b
$ TyConId
"ghc-frontend: unsupported non-vanilla data constructor: " TyConId -> TyConId -> TyConId
forall a. Semigroup a => a -> a -> a
<> DataCon -> TyConId
conName DataCon
dc
                              let tvm :: IntMap TyVar
tvm = [(Uniq, TyVar)] -> IntMap TyVar
forall a. [(Uniq, a)] -> IntMap a
IM.fromList ([(Uniq, TyVar)] -> IntMap TyVar)
-> [(Uniq, TyVar)] -> IntMap TyVar
forall a b. (a -> b) -> a -> b
$ [Uniq] -> [TyVar] -> [(Uniq, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Var -> Uniq) -> [Var] -> [Uniq]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Uniq
uKey [Var]
univs) [TyVar]
tvs
                              argTys <- m [Ty] -> StateT Uniq m [Ty]
forall (m :: * -> *) a. Monad m => m a -> StateT Uniq m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Ty] -> StateT Uniq m [Ty]) -> m [Ty] -> StateT Uniq m [Ty]
forall a b. (a -> b) -> a -> b
$ (Type -> m Ty) -> [Type] -> m [Ty]
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 (IntMap TyVar -> Annote -> Type -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
IntMap TyVar -> Annote -> Type -> m Ty
bridgeTy IntMap TyVar
tvm Annote
an (Type -> m Ty) -> (Type -> Type) -> Type -> m Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
expandTypeSynonyms)
                                            ([Type] -> m [Ty]) -> [Type] -> m [Ty]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type]
dataConTheta DataCon
dc [Type] -> [Type] -> [Type]
forall a. Semigroup a => a -> a -> a
<> (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
dc)
                              resTy  <- lift $ bridgeTy tvm an $ TyConApp tc $ mkTyVarTys univs
                              pure $ E.DataCon an (conName dc) $ E.Sig tvs $ foldr (E.Arrow an) resTy argTys

---
--- The base vocabulary's synthesized definitions ($, ., id, not, &&, ||,
--- fst, snd): INLINE Eidos definitions bridged in place of the base
--- originals.
---

vocabDefns :: MonadError AstError m => BM m [E.Defn]
vocabDefns :: forall (m :: * -> *). MonadError AstError m => BM m [Defn]
vocabDefns = [StateT Uniq m Defn] -> StateT Uniq m [Defn]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ do -- ($) :: forall a b. (a -> b) -> a -> b
            (a, b, _) <- BM m (TyVar, TyVar, TyVar)
forall (m :: * -> *). Monad m => BM m (TyVar, TyVar, TyVar)
tvs3
            let ta = TyVar -> Ty
tv TyVar
a; tb = TyVar -> Ty
tv TyVar
b
            f <- freshId "f" $ E.monoSig $ E.Arrow va ta tb
            x <- freshId "x" $ E.monoSig ta
            mkVocab "GHC.Internal.Base.$" [a, b] (E.Arrow va (E.Arrow va ta tb) $ E.Arrow va ta tb)
                  $ E.Lam va f $ E.Lam va x $ E.App va (E.Var va f) $ E.EArg $ E.Var va x
      , do -- (.) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
            (a, b, c) <- BM m (TyVar, TyVar, TyVar)
forall (m :: * -> *). Monad m => BM m (TyVar, TyVar, TyVar)
tvs3
            let ta = TyVar -> Ty
tv TyVar
a; tb = TyVar -> Ty
tv TyVar
b; tc = TyVar -> Ty
tv TyVar
c
            f <- freshId "f" $ E.monoSig $ E.Arrow va tb tc
            g <- freshId "g" $ E.monoSig $ E.Arrow va ta tb
            x <- freshId "x" $ E.monoSig ta
            -- N.B. GHC's (.) quantifies forall b c a. — the vocabulary
            -- signature must match that instantiation order.
            mkVocab "GHC.Internal.Base.." [b, c, a] (E.Arrow va (E.Arrow va tb tc) $ E.Arrow va (E.Arrow va ta tb) $ E.Arrow va ta tc)
                  $ E.Lam va f $ E.Lam va g $ E.Lam va x
                  $ E.App va (E.Var va f) $ E.EArg $ E.App va (E.Var va g) $ E.EArg $ E.Var va x
      , do -- id :: forall a. a -> a
            (a, _, _) <- BM m (TyVar, TyVar, TyVar)
forall (m :: * -> *). Monad m => BM m (TyVar, TyVar, TyVar)
tvs3
            let ta = TyVar -> Ty
tv TyVar
a
            x <- freshId "x" $ E.monoSig ta
            mkVocab "GHC.Internal.Base.id" [a] (E.Arrow va ta ta)
                  $ E.Lam va x $ E.Var va x
      , do -- not :: Bool -> Bool
            b <- TyConId -> Sig -> BM m Id
forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId TyConId
"b" (Sig -> BM m Id) -> Sig -> BM m Id
forall a b. (a -> b) -> a -> b
$ Ty -> Sig
E.monoSig Ty
boolT
            cb <- freshId "s" $ E.monoSig boolT
            mkVocab "GHC.Classes.not" [] (E.Arrow va boolT boolT)
                  $ E.Lam va b $ E.Case va boolT (E.Var va b) cb
                        [ E.Alt va E.DefaultAlt [] $ conE "True"
                        , E.Alt va (E.DataAlt "True") [] $ conE "False" ]
      , do -- (&&) :: Bool -> Bool -> Bool
            x <- TyConId -> Sig -> BM m Id
forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId TyConId
"x" (Sig -> BM m Id) -> Sig -> BM m Id
forall a b. (a -> b) -> a -> b
$ Ty -> Sig
E.monoSig Ty
boolT
            y <- freshId "y" $ E.monoSig boolT
            cb <- freshId "s" $ E.monoSig boolT
            mkVocab "GHC.Classes.&&" [] (E.Arrow va boolT $ E.Arrow va boolT boolT)
                  $ E.Lam va x $ E.Lam va y $ E.Case va boolT (E.Var va x) cb
                        [ E.Alt va E.DefaultAlt [] $ conE "False"
                        , E.Alt va (E.DataAlt "True") [] $ E.Var va y ]
      , do -- (||) :: Bool -> Bool -> Bool
            x <- TyConId -> Sig -> BM m Id
forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId TyConId
"x" (Sig -> BM m Id) -> Sig -> BM m Id
forall a b. (a -> b) -> a -> b
$ Ty -> Sig
E.monoSig Ty
boolT
            y <- freshId "y" $ E.monoSig boolT
            cb <- freshId "s" $ E.monoSig boolT
            mkVocab "GHC.Classes.||" [] (E.Arrow va boolT $ E.Arrow va boolT boolT)
                  $ E.Lam va x $ E.Lam va y $ E.Case va boolT (E.Var va x) cb
                        [ E.Alt va E.DefaultAlt [] $ E.Var va y
                        , E.Alt va (E.DataAlt "True") [] $ conE "True" ]
      , do -- fst :: forall a b. (a, b) -> a
            (a, b, _) <- BM m (TyVar, TyVar, TyVar)
forall (m :: * -> *). Monad m => BM m (TyVar, TyVar, TyVar)
tvs3
            let ta = TyVar -> Ty
tv TyVar
a; tb = TyVar -> Ty
tv TyVar
b; pt = Ty -> Ty -> Ty
pairT Ty
ta Ty
tb
            p  <- freshId "p" $ E.monoSig pt
            cb <- freshId "s" $ E.monoSig pt
            xa <- freshId "x" $ E.monoSig ta
            xb <- freshId "y" $ E.monoSig tb
            mkVocab "GHC.Internal.Data.Tuple.fst" [a, b] (E.Arrow va pt ta)
                  $ E.Lam va p $ E.Case va ta (E.Var va p) cb
                        [ E.Alt va (E.DataAlt "(,)") [xa, xb] $ E.Var va xa ]
      , do -- snd :: forall a b. (a, b) -> b
            (a, b, _) <- BM m (TyVar, TyVar, TyVar)
forall (m :: * -> *). Monad m => BM m (TyVar, TyVar, TyVar)
tvs3
            let ta = TyVar -> Ty
tv TyVar
a; tb = TyVar -> Ty
tv TyVar
b; pt = Ty -> Ty -> Ty
pairT Ty
ta Ty
tb
            p  <- freshId "p" $ E.monoSig pt
            cb <- freshId "s" $ E.monoSig pt
            xa <- freshId "x" $ E.monoSig ta
            xb <- freshId "y" $ E.monoSig tb
            mkVocab "GHC.Internal.Data.Tuple.snd" [a, b] (E.Arrow va pt tb)
                  $ E.Lam va p $ E.Case va tb (E.Var va p) cb
                        [ E.Alt va (E.DataAlt "(,)") [xa, xb] $ E.Var va xb ]
      ]
      where va :: Annote
            va :: Annote
va = Annote
noAnn

            boolT :: E.Ty
            boolT :: Ty
boolT = Annote -> TyConId -> Ty
E.TyCon Annote
va TyConId
"Bool"

            tv :: E.TyVar -> E.Ty
            tv :: TyVar -> Ty
tv = Annote -> TyVar -> Ty
E.TyVarT Annote
va

            pairT :: E.Ty -> E.Ty -> E.Ty
            pairT :: Ty -> Ty -> Ty
pairT Ty
a Ty
b = Annote -> Ty -> Ty -> Ty
E.TyApp Annote
va (Annote -> Ty -> Ty -> Ty
E.TyApp Annote
va (Annote -> TyConId -> Ty
E.TyCon Annote
va TyConId
"(,)") Ty
a) Ty
b

            conE :: E.DataConId -> E.Exp
            conE :: TyConId -> Exp
conE TyConId
c = Annote -> Ty -> TyConId -> Exp
E.Con Annote
va Ty
boolT TyConId
c

            tvs3 :: Monad m => BM m (E.TyVar, E.TyVar, E.TyVar)
            tvs3 :: forall (m :: * -> *). Monad m => BM m (TyVar, TyVar, TyVar)
tvs3 = do
                  ua <- BM m Uniq
forall (m :: * -> *). Monad m => BM m Uniq
freshU
                  ub <- freshU
                  uc <- freshU
                  pure ( E.TyVar "a" ua E.KStar
                       , E.TyVar "b" ub E.KStar
                       , E.TyVar "c" uc E.KStar )

            mkVocab :: Monad m => Text -> [E.TyVar] -> E.Ty -> E.Exp -> BM m E.Defn
            mkVocab :: forall (m :: * -> *).
Monad m =>
TyConId -> [TyVar] -> Ty -> Exp -> BM m Defn
mkVocab TyConId
n [TyVar]
tvs' Ty
t Exp
body = do
                  x <- TyConId -> Sig -> BM m Id
forall (m :: * -> *). Monad m => TyConId -> Sig -> BM m Id
freshId TyConId
n (Sig -> BM m Id) -> Sig -> BM m Id
forall a b. (a -> b) -> a -> b
$ [TyVar] -> Ty -> Sig
E.Sig [TyVar]
tvs' Ty
t
                  pure E.Defn
                        { E.defnAnnote = va
                        , E.defnId     = x
                        , E.defnParams = []
                        , E.defnBody   = body
                        , E.defnAttr   = Just E.Inline
                        , E.defnOrigin = Nothing
                        }