{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                          2017, QBayLogic, Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.GHC.GenerateBindings
  (generateBindings)
where

import           Control.DeepSeq         (deepseq)
import           Control.Lens            ((%~),(&),view,_1)
import           Control.Monad           (unless)
import qualified Control.Monad.State     as State
import qualified Control.Monad.RWS.Lazy  as RWS
import           Data.Coerce             (coerce)
import           Data.Either             (partitionEithers, lefts, rights)
import           Data.IntMap.Strict      (IntMap)
import qualified Data.IntMap.Strict      as IMS
import qualified Data.HashMap.Strict     as HashMap
import           Data.List               (isPrefixOf)
import qualified Data.Text               as Text
import qualified Data.Time.Clock         as Clock

import qualified BasicTypes              as GHC
import qualified CoreSyn                 as GHC
import qualified Demand                  as GHC
import qualified DynFlags                as GHC
import qualified IdInfo                  as GHC
import qualified Outputable              as GHC
import qualified Name                    as GHC hiding (varName)
import qualified TyCon                   as GHC
import qualified Type                    as GHC
import qualified TysWiredIn              as GHC
import qualified Util                    as GHC
import qualified Var                     as GHC
import qualified SrcLoc                  as GHC

import           Clash.Annotations.BitRepresentation.Internal (DataRepr')
import           Clash.Annotations.TopEntity (TopEntity)
import           Clash.Annotations.Primitive (HDL, extractPrim)

import           Clash.Core.Subst        (extendGblSubstList, mkSubst, substTm)
import           Clash.Core.Term         (Term (..))
import           Clash.Core.Type         (Type (..), TypeView (..), mkFunTy, splitFunForallTy, tyView)
import           Clash.Core.TyCon        (TyConMap, TyConName, isNewTypeTc)
import           Clash.Core.TysPrim      (tysPrimMap)
import           Clash.Core.Util         (mkLams, mkTyLams)
import           Clash.Core.Var          (Var (..), Id, IdScope (..), setIdScope)
import           Clash.Core.VarEnv
  (InScopeSet, VarEnv, emptyInScopeSet, extendInScopeSet, mkInScopeSet, mkVarEnv, unionVarEnv)
import           Clash.Driver            (compilePrimitive)
import           Clash.Driver.Types      (BindingMap)
import           Clash.GHC.GHC2Core
  (C2C, GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm,
   makeAllTyCons, qualifiedNameString, emptyGHC2CoreState)
import           Clash.GHC.LoadModules   (ghcLibDir, loadModules)
import           Clash.Netlist.BlackBox.Util (usedArguments)
import           Clash.Primitives.Types
  (Primitive (..), CompiledPrimMap)
import           Clash.Primitives.Util   (generatePrimMap)
import           Clash.Rewrite.Util      (mkInternalVar, mkSelectorCase)
import           Clash.Unique
  (listToUniqMap, lookupUniqMap, mapUniqMap, unionUniqMap, uniqMapToUniqSet)
import           Clash.Util
  ((***),first,traceIf,indexMaybe,reportTimeDiff)

generateBindings
  :: GHC.OverridingBool
  -- ^ Use color
  -> [FilePath]
  -- ^ primitives (blackbox) directories
  -> [FilePath]
  -- ^ import directories (-i flag)
  -> [FilePath]
  -- ^ Package database
  -> HDL
  -- ^ HDL target
  -> String
  -> Maybe GHC.DynFlags
  -> IO ( BindingMap
        , TyConMap
        , IntMap TyConName
        , [( Id
           , Maybe TopEntity -- (maybe) TopEntity annotation
           , Maybe Id        -- (maybe) associated testbench
           )]
        , CompiledPrimMap  -- The primitives found in '.' and 'primDir'
        , [DataRepr']
        )
generateBindings :: OverridingBool
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> HDL
-> FilePath
-> Maybe DynFlags
-> IO
     (BindingMap, TyConMap, IntMap TyConName,
      [(Id, Maybe TopEntity, Maybe Id)], CompiledPrimMap, [DataRepr'])
generateBindings useColor :: OverridingBool
useColor primDirs :: [FilePath]
primDirs importDirs :: [FilePath]
importDirs dbs :: [FilePath]
dbs hdl :: HDL
hdl modName :: FilePath
modName dflagsM :: Maybe DynFlags
dflagsM = do
  (  bindings :: [CoreBind]
bindings
   , clsOps :: [(CoreBndr, Int)]
clsOps
   , unlocatable :: [CoreBndr]
unlocatable
   , fiEnvs :: FamInstEnvs
fiEnvs
   , topEntities :: [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
topEntities
   , [Either UnresolvedPrimitive FilePath]
-> ([UnresolvedPrimitive], [FilePath])
forall a b. [Either a b] -> ([a], [b])
partitionEithers -> (unresolvedPrims :: [UnresolvedPrimitive]
unresolvedPrims, pFP :: [FilePath]
pFP)
   , customBitRepresentations :: [DataRepr']
customBitRepresentations
   , primGuards :: [(Text, PrimitiveGuard ())]
primGuards ) <- OverridingBool
-> HDL
-> FilePath
-> Maybe DynFlags
-> [FilePath]
-> IO
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())])
loadModules OverridingBool
useColor HDL
hdl FilePath
modName Maybe DynFlags
dflagsM [FilePath]
importDirs
  ResolvedPrimMap
primMapR <- HasCallStack =>
[UnresolvedPrimitive]
-> [(Text, PrimitiveGuard ())] -> [FilePath] -> IO ResolvedPrimMap
[UnresolvedPrimitive]
-> [(Text, PrimitiveGuard ())] -> [FilePath] -> IO ResolvedPrimMap
generatePrimMap [UnresolvedPrimitive]
unresolvedPrims [(Text, PrimitiveGuard ())]
primGuards ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]
pFP, [FilePath]
primDirs, [FilePath]
importDirs])
  FilePath
tdir <- IO FilePath
-> (DynFlags -> IO FilePath) -> Maybe DynFlags -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
ghcLibDir (FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath)
-> (DynFlags -> FilePath) -> DynFlags -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> FilePath
GHC.topDir) Maybe DynFlags
dflagsM
  UTCTime
startTime <- IO UTCTime
Clock.getCurrentTime
  CompiledPrimMap
primMapC <-
    HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
-> IO CompiledPrimMap
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
 -> IO CompiledPrimMap)
-> HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
-> IO CompiledPrimMap
forall a b. (a -> b) -> a -> b
$ (PrimitiveGuard ResolvedPrimitive
 -> IO (PrimitiveGuard CompiledPrimitive))
-> ResolvedPrimMap
-> HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.map
                 (PrimitiveGuard (IO CompiledPrimitive)
-> IO (PrimitiveGuard CompiledPrimitive)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (PrimitiveGuard (IO CompiledPrimitive)
 -> IO (PrimitiveGuard CompiledPrimitive))
-> (PrimitiveGuard ResolvedPrimitive
    -> PrimitiveGuard (IO CompiledPrimitive))
-> PrimitiveGuard ResolvedPrimitive
-> IO (PrimitiveGuard CompiledPrimitive)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResolvedPrimitive -> IO CompiledPrimitive)
-> PrimitiveGuard ResolvedPrimitive
-> PrimitiveGuard (IO CompiledPrimitive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FilePath]
-> [FilePath]
-> FilePath
-> ResolvedPrimitive
-> IO CompiledPrimitive
compilePrimitive [FilePath]
importDirs [FilePath]
dbs FilePath
tdir))
                 ResolvedPrimMap
primMapR
  let ((bindingsMap :: BindingMap
bindingsMap,clsVMap :: VarEnv (Id, Int)
clsVMap),tcMap :: GHC2CoreState
tcMap,_) =
        RWS SrcSpan SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
-> SrcSpan
-> GHC2CoreState
-> ((BindingMap, VarEnv (Id, Int)), GHC2CoreState, SrcSpanRB)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
RWS.runRWS (CompiledPrimMap
-> [CoreBind]
-> [(CoreBndr, Int)]
-> [CoreBndr]
-> RWS
     SrcSpan SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
mkBindings CompiledPrimMap
primMapC [CoreBind]
bindings [(CoreBndr, Int)]
clsOps [CoreBndr]
unlocatable)
                   SrcSpan
GHC.noSrcSpan
                   GHC2CoreState
emptyGHC2CoreState
      (tcMap' :: GHC2CoreState
tcMap',tupTcCache :: IntMap TyConName
tupTcCache)           = GHC2CoreState -> (GHC2CoreState, IntMap TyConName)
mkTupTyCons GHC2CoreState
tcMap
      tcCache :: TyConMap
tcCache                       = GHC2CoreState -> FamInstEnvs -> TyConMap
makeAllTyCons GHC2CoreState
tcMap' FamInstEnvs
fiEnvs
      allTcCache :: TyConMap
allTcCache                    = TyConMap
tysPrimMap TyConMap -> TyConMap -> TyConMap
forall a. UniqMap a -> UniqMap a -> UniqMap a
`unionUniqMap` TyConMap
tcCache
      inScope0 :: InScopeSet
inScope0 = VarSet -> InScopeSet
mkInScopeSet (UniqMap (Var Any) -> VarSet
forall a. UniqMap a -> UniqSet a
uniqMapToUniqSet
                      ((((Id, SrcSpan, InlineSpec, Term) -> Var Any)
-> BindingMap -> UniqMap (Var Any)
forall a b. (a -> b) -> UniqMap a -> UniqMap b
mapUniqMap (Id -> Var Any
forall a b. Coercible a b => a -> b
coerce (Id -> Var Any)
-> ((Id, SrcSpan, InlineSpec, Term) -> Id)
-> (Id, SrcSpan, InlineSpec, Term)
-> Var Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Id (Id, SrcSpan, InlineSpec, Term) Id
-> (Id, SrcSpan, InlineSpec, Term) -> Id
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Id (Id, SrcSpan, InlineSpec, Term) Id
forall s t a b. Field1 s t a b => Lens s t a b
_1) BindingMap
bindingsMap) UniqMap (Var Any) -> UniqMap (Var Any) -> UniqMap (Var Any)
forall a. UniqMap a -> UniqMap a -> UniqMap a
`unionUniqMap`
                       (((Id, SrcSpan, InlineSpec, Term) -> Var Any)
-> BindingMap -> UniqMap (Var Any)
forall a b. (a -> b) -> UniqMap a -> UniqMap b
mapUniqMap (Id -> Var Any
forall a b. Coercible a b => a -> b
coerce (Id -> Var Any)
-> ((Id, SrcSpan, InlineSpec, Term) -> Id)
-> (Id, SrcSpan, InlineSpec, Term)
-> Var Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Id (Id, SrcSpan, InlineSpec, Term) Id
-> (Id, SrcSpan, InlineSpec, Term) -> Id
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Id (Id, SrcSpan, InlineSpec, Term) Id
forall s t a b. Field1 s t a b => Lens s t a b
_1) BindingMap
clsMap)))
      clsMap :: BindingMap
clsMap                        = ((Id, Int) -> (Id, SrcSpan, InlineSpec, Term))
-> VarEnv (Id, Int) -> BindingMap
forall a b. (a -> b) -> UniqMap a -> UniqMap b
mapUniqMap (\(v :: Id
v,i :: Int
i) -> (Id
v,SrcSpan
GHC.noSrcSpan,InlineSpec
GHC.Inline,InScopeSet -> TyConMap -> Type -> Int -> Term
mkClassSelector InScopeSet
inScope0 TyConMap
allTcCache (Id -> Type
forall a. Var a -> Type
varType Id
v) Int
i)) VarEnv (Id, Int)
clsVMap
      allBindings :: BindingMap
allBindings                   = BindingMap
bindingsMap BindingMap -> BindingMap -> BindingMap
forall a. UniqMap a -> UniqMap a -> UniqMap a
`unionVarEnv` BindingMap
clsMap
      topEntities' :: [(Name a, Maybe TopEntity, Maybe Id)]
topEntities'                  =
        (\m :: RWS
  SrcSpan
  SrcSpanRB
  GHC2CoreState
  [(Name a, Maybe TopEntity, Maybe Id)]
m -> ([(Name a, Maybe TopEntity, Maybe Id)], SrcSpanRB)
-> [(Name a, Maybe TopEntity, Maybe Id)]
forall a b. (a, b) -> a
fst (RWS
  SrcSpan
  SrcSpanRB
  GHC2CoreState
  [(Name a, Maybe TopEntity, Maybe Id)]
-> SrcSpan
-> GHC2CoreState
-> ([(Name a, Maybe TopEntity, Maybe Id)], SrcSpanRB)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
RWS.evalRWS RWS
  SrcSpan
  SrcSpanRB
  GHC2CoreState
  [(Name a, Maybe TopEntity, Maybe Id)]
m SrcSpan
GHC.noSrcSpan GHC2CoreState
tcMap')) (RWS
   SrcSpan
   SrcSpanRB
   GHC2CoreState
   [(Name a, Maybe TopEntity, Maybe Id)]
 -> [(Name a, Maybe TopEntity, Maybe Id)])
-> RWS
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     [(Name a, Maybe TopEntity, Maybe Id)]
-> [(Name a, Maybe TopEntity, Maybe Id)]
forall a b. (a -> b) -> a -> b
$ ((CoreBndr, Maybe TopEntity, Maybe CoreBndr)
 -> RWST
      SrcSpan
      SrcSpanRB
      GHC2CoreState
      Identity
      (Name a, Maybe TopEntity, Maybe Id))
-> [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
-> RWS
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     [(Name a, Maybe TopEntity, Maybe Id)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(topEnt :: CoreBndr
topEnt,annM :: Maybe TopEntity
annM,benchM :: Maybe CoreBndr
benchM) -> do
          Name a
topEnt' <- (CoreBndr -> Name)
-> (CoreBndr -> Unique)
-> (Name -> C2C Text)
-> CoreBndr
-> C2C (Name a)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName CoreBndr -> Name
GHC.varName CoreBndr -> Unique
GHC.varUnique Name -> C2C Text
qualifiedNameString CoreBndr
topEnt
          Maybe Id
benchM' <- (CoreBndr -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id)
-> Maybe CoreBndr
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Maybe Id)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CoreBndr -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToId Maybe CoreBndr
benchM
          (Name a, Maybe TopEntity, Maybe Id)
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     (Name a, Maybe TopEntity, Maybe Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name a
topEnt',Maybe TopEntity
annM,Maybe Id
benchM')) [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)]
topEntities
      topEntities'' :: [(Id, Maybe TopEntity, Maybe Id)]
topEntities''                 = ((Name Any, Maybe TopEntity, Maybe Id)
 -> (Id, Maybe TopEntity, Maybe Id))
-> [(Name Any, Maybe TopEntity, Maybe Id)]
-> [(Id, Maybe TopEntity, Maybe Id)]
forall a b. (a -> b) -> [a] -> [b]
map (\(topEnt :: Name Any
topEnt,annM :: Maybe TopEntity
annM,benchM :: Maybe Id
benchM) -> case Name Any -> BindingMap -> Maybe (Id, SrcSpan, InlineSpec, Term)
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap Name Any
topEnt BindingMap
allBindings of
                                              Just (v :: Id
v,_,_,_) -> (Id
v,Maybe TopEntity
annM,Maybe Id
benchM)
                                              Nothing        -> FilePath -> (Id, Maybe TopEntity, Maybe Id)
forall a. HasCallStack => FilePath -> a
error "This shouldn't happen"
                                          ) [(Name Any, Maybe TopEntity, Maybe Id)]
forall a. [(Name a, Maybe TopEntity, Maybe Id)]
topEntities'
  -- Parsing / compiling primitives:
  UTCTime
prepTime  <- UTCTime
startTime UTCTime -> CompiledPrimMap -> CompiledPrimMap
forall a b. NFData a => a -> b -> b
`deepseq` CompiledPrimMap
primMapC CompiledPrimMap -> IO UTCTime -> IO UTCTime
forall a b. a -> b -> b
`seq` IO UTCTime
Clock.getCurrentTime
  let prepStartDiff :: FilePath
prepStartDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
prepTime UTCTime
startTime
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Clash: Parsing and compiling primitives took " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
prepStartDiff

  (BindingMap, TyConMap, IntMap TyConName,
 [(Id, Maybe TopEntity, Maybe Id)], CompiledPrimMap, [DataRepr'])
-> IO
     (BindingMap, TyConMap, IntMap TyConName,
      [(Id, Maybe TopEntity, Maybe Id)], CompiledPrimMap, [DataRepr'])
forall (m :: * -> *) a. Monad m => a -> m a
return ( BindingMap
allBindings
         , TyConMap
allTcCache
         , IntMap TyConName
tupTcCache
         , [(Id, Maybe TopEntity, Maybe Id)]
topEntities''
         , CompiledPrimMap
primMapC
         , [DataRepr']
customBitRepresentations
         )

mkBindings
  :: CompiledPrimMap
  -> [GHC.CoreBind]
  -- Binders
  -> [(GHC.CoreBndr,Int)]
  -- Class operations
  -> [GHC.CoreBndr]
  -- Unlocatable Expressions
  -> C2C ( BindingMap
         , VarEnv (Id,Int)
         )
mkBindings :: CompiledPrimMap
-> [CoreBind]
-> [(CoreBndr, Int)]
-> [CoreBndr]
-> RWS
     SrcSpan SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
mkBindings primMap :: CompiledPrimMap
primMap bindings :: [CoreBind]
bindings clsOps :: [(CoreBndr, Int)]
clsOps unlocatable :: [CoreBndr]
unlocatable = do
  [[(Id, (Id, SrcSpan, InlineSpec, Term))]]
bindingsList <- (CoreBind
 -> RWST
      SrcSpan
      SrcSpanRB
      GHC2CoreState
      Identity
      [(Id, (Id, SrcSpan, InlineSpec, Term))])
-> [CoreBind]
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     [[(Id, (Id, SrcSpan, InlineSpec, Term))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\case
    GHC.NonRec v :: CoreBndr
v e :: Expr CoreBndr
e -> do
      let sp :: SrcSpan
sp = CoreBndr -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
GHC.getSrcSpan CoreBndr
v
          inl :: InlineSpec
inl = InlinePragma -> InlineSpec
GHC.inlinePragmaSpec (InlinePragma -> InlineSpec)
-> (IdInfo -> InlinePragma) -> IdInfo -> InlineSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> InlinePragma
GHC.inlinePragInfo (IdInfo -> InlineSpec) -> IdInfo -> InlineSpec
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
GHC.idInfo CoreBndr
v
      Term
tm <- (SrcSpan -> SrcSpan)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Term
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Term
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
RWS.local (SrcSpan -> SrcSpan -> SrcSpan
forall a b. a -> b -> a
const SrcSpan
sp) (CompiledPrimMap
-> [CoreBndr]
-> Expr CoreBndr
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Term
coreToTerm CompiledPrimMap
primMap [CoreBndr]
unlocatable Expr CoreBndr
e)
      Id
v' <- CoreBndr -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToId CoreBndr
v
      CompiledPrimMap -> CoreBndr -> C2C ()
checkPrimitive CompiledPrimMap
primMap CoreBndr
v
      [(Id, (Id, SrcSpan, InlineSpec, Term))]
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     [(Id, (Id, SrcSpan, InlineSpec, Term))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Id
v', (Id
v', SrcSpan
sp, InlineSpec
inl, Term
tm))]
    GHC.Rec bs :: [(CoreBndr, Expr CoreBndr)]
bs -> do
      [(Id, SrcSpan, InlineSpec, Term)]
tms <- ((CoreBndr, Expr CoreBndr)
 -> RWST
      SrcSpan
      SrcSpanRB
      GHC2CoreState
      Identity
      (Id, SrcSpan, InlineSpec, Term))
-> [(CoreBndr, Expr CoreBndr)]
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     [(Id, SrcSpan, InlineSpec, Term)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(v :: CoreBndr
v,e :: Expr CoreBndr
e) -> do
                    let sp :: SrcSpan
sp  = CoreBndr -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
GHC.getSrcSpan CoreBndr
v
                        inl :: InlineSpec
inl = InlinePragma -> InlineSpec
GHC.inlinePragmaSpec (InlinePragma -> InlineSpec)
-> (IdInfo -> InlinePragma) -> IdInfo -> InlineSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> InlinePragma
GHC.inlinePragInfo (IdInfo -> InlineSpec) -> IdInfo -> InlineSpec
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
GHC.idInfo CoreBndr
v
                    Term
tm <- (SrcSpan -> SrcSpan)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Term
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Term
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
RWS.local (SrcSpan -> SrcSpan -> SrcSpan
forall a b. a -> b -> a
const SrcSpan
sp) (CompiledPrimMap
-> [CoreBndr]
-> Expr CoreBndr
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Term
coreToTerm CompiledPrimMap
primMap [CoreBndr]
unlocatable Expr CoreBndr
e)
                    Id
v' <- CoreBndr -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToId CoreBndr
v
                    CompiledPrimMap -> CoreBndr -> C2C ()
checkPrimitive CompiledPrimMap
primMap CoreBndr
v
                    (Id, SrcSpan, InlineSpec, Term)
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     (Id, SrcSpan, InlineSpec, Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
v',SrcSpan
sp,InlineSpec
inl,Term
tm)
                  ) [(CoreBndr, Expr CoreBndr)]
bs
      case [(Id, SrcSpan, InlineSpec, Term)]
tms of
        [(v :: Id
v,sp :: SrcSpan
sp,inl :: InlineSpec
inl,tm :: Term
tm)] -> [(Id, (Id, SrcSpan, InlineSpec, Term))]
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     [(Id, (Id, SrcSpan, InlineSpec, Term))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Id
v, (Id
v, SrcSpan
sp, InlineSpec
inl, Term
tm))]
        _ -> let vsL :: [Id]
vsL   = ((Id, SrcSpan, InlineSpec, Term) -> Id)
-> [(Id, SrcSpan, InlineSpec, Term)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (IdScope -> Id -> Id
forall a. IdScope -> Var a -> Var a
setIdScope IdScope
LocalId (Id -> Id)
-> ((Id, SrcSpan, InlineSpec, Term) -> Id)
-> (Id, SrcSpan, InlineSpec, Term)
-> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Id (Id, SrcSpan, InlineSpec, Term) Id
-> (Id, SrcSpan, InlineSpec, Term) -> Id
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Id (Id, SrcSpan, InlineSpec, Term) Id
forall s t a b. Field1 s t a b => Lens s t a b
_1) [(Id, SrcSpan, InlineSpec, Term)]
tms
                 vsV :: [Term]
vsV   = (Id -> Term) -> [Id] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Term
Var [Id]
vsL
                 subst :: Subst
subst = Subst -> [(Id, Term)] -> Subst
extendGblSubstList (InScopeSet -> Subst
mkSubst InScopeSet
emptyInScopeSet) ([Id] -> [Term] -> [(Id, Term)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
vsL [Term]
vsV)
                 lbs :: [(Id, Term)]
lbs   = ((Id, SrcSpan, InlineSpec, Term) -> Id -> (Id, Term))
-> [(Id, SrcSpan, InlineSpec, Term)] -> [Id] -> [(Id, Term)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(_,_,_,e :: Term
e) vL :: Id
vL -> (Id
vL,HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "mkBindings" Subst
subst Term
e)) [(Id, SrcSpan, InlineSpec, Term)]
tms [Id]
vsL
                 tms1 :: [(Id, (Id, SrcSpan, InlineSpec, Term))]
tms1  = ((Id, SrcSpan, InlineSpec, Term)
 -> (Id, Term) -> (Id, (Id, SrcSpan, InlineSpec, Term)))
-> [(Id, SrcSpan, InlineSpec, Term)]
-> [(Id, Term)]
-> [(Id, (Id, SrcSpan, InlineSpec, Term))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(v :: Id
v,sp :: SrcSpan
sp,inl :: InlineSpec
inl,_) (_,e :: Term
e) -> (Id
v,(Id
v,SrcSpan
sp,InlineSpec
inl,[(Id, Term)] -> Term -> Term
Letrec [(Id, Term)]
lbs Term
e))) [(Id, SrcSpan, InlineSpec, Term)]
tms [(Id, Term)]
lbs
             in  [(Id, (Id, SrcSpan, InlineSpec, Term))]
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     [(Id, (Id, SrcSpan, InlineSpec, Term))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Id, (Id, SrcSpan, InlineSpec, Term))]
tms1
    ) [CoreBind]
bindings
  [(Id, (Id, Int))]
clsOpList    <- ((CoreBndr, Int)
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Id, (Id, Int)))
-> [(CoreBndr, Int)]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [(Id, (Id, Int))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(v :: CoreBndr
v,i :: Int
i) -> do
                          Id
v' <- CoreBndr -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToId CoreBndr
v
                          (Id, (Id, Int))
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Id, (Id, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
v', (Id
v',Int
i))
                       ) [(CoreBndr, Int)]
clsOps

  (BindingMap, VarEnv (Id, Int))
-> RWS
     SrcSpan SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id, (Id, SrcSpan, InlineSpec, Term))] -> BindingMap
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv ([[(Id, (Id, SrcSpan, InlineSpec, Term))]]
-> [(Id, (Id, SrcSpan, InlineSpec, Term))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Id, (Id, SrcSpan, InlineSpec, Term))]]
bindingsList), [(Id, (Id, Int))] -> VarEnv (Id, Int)
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv [(Id, (Id, Int))]
clsOpList)

-- | If this CoreBndr is a primitive, check it's Haskell definition
--   for potential problems.
--
-- Warns when a primitive:
--   * isn't marked NOINLINE
--   * produces an error when evaluating its result to WHNF
--   * isn't using all its arguments
checkPrimitive :: CompiledPrimMap -> GHC.CoreBndr -> C2C ()
checkPrimitive :: CompiledPrimMap -> CoreBndr -> C2C ()
checkPrimitive primMap :: CompiledPrimMap
primMap v :: CoreBndr
v = do
  Text
nm <- Name -> C2C Text
qualifiedNameString (CoreBndr -> Name
GHC.varName CoreBndr
v)
  case Text -> CompiledPrimMap -> Maybe (PrimitiveGuard CompiledPrimitive)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nm CompiledPrimMap
primMap of
    Just (PrimitiveGuard CompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim -> Just (BlackBox _ _ _ _ _ _ _ inc :: [((Text, Text), BlackBox)]
inc templ :: BlackBox
templ)) -> do
      let
        info :: IdInfo
info = HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
GHC.idInfo CoreBndr
v
        inline :: InlineSpec
inline = InlinePragma -> InlineSpec
GHC.inlinePragmaSpec (InlinePragma -> InlineSpec) -> InlinePragma -> InlineSpec
forall a b. (a -> b) -> a -> b
$ IdInfo -> InlinePragma
GHC.inlinePragInfo IdInfo
info
        strictness :: StrictSig
strictness = IdInfo -> StrictSig
GHC.strictnessInfo IdInfo
info
        ty :: Kind
ty = CoreBndr -> Kind
GHC.varType CoreBndr
v
        (argTys :: [Kind]
argTys,_resTy :: Kind
_resTy) = Kind -> ([Kind], Kind)
GHC.splitFunTys (Kind -> ([Kind], Kind))
-> (Kind -> Kind) -> Kind -> ([Kind], Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBndr], Kind) -> Kind
forall a b. (a, b) -> b
snd (([CoreBndr], Kind) -> Kind)
-> (Kind -> ([CoreBndr], Kind)) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> ([CoreBndr], Kind)
GHC.splitForAllTys (Kind -> ([Kind], Kind)) -> Kind -> ([Kind], Kind)
forall a b. (a -> b) -> a -> b
$ Kind
ty
        (dmdArgs :: [Demand]
dmdArgs,_dmdRes :: DmdResult
_dmdRes) = StrictSig -> ([Demand], DmdResult)
GHC.splitStrictSig StrictSig
strictness
        nrOfArgs :: Int
nrOfArgs = [Kind] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
argTys
        loc :: FilePath
loc = case CoreBndr -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
GHC.getSrcLoc CoreBndr
v of
                GHC.UnhelpfulLoc _ -> ""
                GHC.RealSrcLoc l :: RealSrcLoc
l   -> RealSrcLoc -> FilePath
forall a. Outputable a => a -> FilePath
showPpr RealSrcLoc
l FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ": "
        warnIf :: Bool -> FilePath -> m ()
warnIf cond :: Bool
cond msg :: FilePath
msg = Bool -> FilePath -> (() -> m ()) -> () -> m ()
forall a. Bool -> FilePath -> a -> a
traceIf Bool
cond ("\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
locFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"Warning: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
msg) () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      FilePath
qName <- Text -> FilePath
Text.unpack (Text -> FilePath)
-> C2C Text
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> C2C Text
qualifiedNameString (CoreBndr -> Name
GHC.varName CoreBndr
v)
      let primStr :: FilePath
primStr = "primitive " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
qName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " "
      let usedArgs :: [Int]
usedArgs = BlackBox -> [Int]
usedArguments BlackBox
templ [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (((Text, Text), BlackBox) -> [Int])
-> [((Text, Text), BlackBox)] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BlackBox -> [Int]
usedArguments (BlackBox -> [Int])
-> (((Text, Text), BlackBox) -> BlackBox)
-> ((Text, Text), BlackBox)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text), BlackBox) -> BlackBox
forall a b. (a, b) -> b
snd) [((Text, Text), BlackBox)]
inc

      let warnArgs :: [Int] -> m ()
warnArgs [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          warnArgs (x :: Int
x:xs :: [Int]
xs) = do
            Bool -> FilePath -> m ()
forall (m :: * -> *). Monad m => Bool -> FilePath -> m ()
warnIf (Bool -> (Demand -> Bool) -> Maybe Demand -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
GHC.isAbsDmd ([Demand] -> Int -> Maybe Demand
forall a. [a] -> Int -> Maybe a
indexMaybe [Demand]
dmdArgs Int
x))
              ("The Haskell implementation of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
primStr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "isn't using argument #" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
               Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ", but the corresponding primitive blackbox does.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
               "This can lead to compile failures because GHC can replace these " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
               "arguments by an undefined value.")
            [Int] -> m ()
warnArgs [Int]
xs

      Bool -> C2C () -> C2C ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
qName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.XException.errorX" Bool -> Bool -> Bool
|| "GHC." FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
qName) (C2C () -> C2C ()) -> C2C () -> C2C ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> FilePath -> C2C ()
forall (m :: * -> *). Monad m => Bool -> FilePath -> m ()
warnIf (InlineSpec
inline InlineSpec -> InlineSpec -> Bool
forall a. Eq a => a -> a -> Bool
/= InlineSpec
GHC.NoInline)
          (FilePath
primStr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "isn't marked NOINLINE."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\nThis might make Clash ignore this primitive.")
        Bool -> FilePath -> C2C ()
forall (m :: * -> *). Monad m => Bool -> FilePath -> m ()
warnIf (StrictSig -> Int -> Bool
GHC.appIsBottom StrictSig
strictness Int
nrOfArgs)
          ("The Haskell implementation of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
primStr
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "produces a result that always results in an error.\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "This can lead to compile failures because GHC can replace entire "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "calls to this primitive by an undefined value.")
        [Int] -> C2C ()
forall (m :: * -> *). Monad m => [Int] -> m ()
warnArgs [Int]
usedArgs
    _ -> () -> C2C ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    showPpr :: GHC.Outputable a => a -> String
    showPpr :: a -> FilePath
showPpr = SDoc -> FilePath
GHC.showSDocUnsafe (SDoc -> FilePath) -> (a -> SDoc) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr

mkClassSelector
  :: InScopeSet
  -> TyConMap
  -> Type
  -> Int
  -> Term
mkClassSelector :: InScopeSet -> TyConMap -> Type -> Int -> Term
mkClassSelector inScope0 :: InScopeSet
inScope0 tcm :: TyConMap
tcm ty :: Type
ty sel :: Int
sel = Term
newExpr
  where
    ((tvs :: [TyVar]
tvs,dictTy :: Type
dictTy:_),_) = (([Either TyVar Type], [Either TyVar Type]) -> ([TyVar], [Type]))
-> (([Either TyVar Type], [Either TyVar Type]), Type)
-> (([TyVar], [Type]), Type)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([Either TyVar Type] -> [TyVar]
forall a b. [Either a b] -> [a]
lefts ([Either TyVar Type] -> [TyVar])
-> ([Either TyVar Type] -> [Type])
-> ([Either TyVar Type], [Either TyVar Type])
-> ([TyVar], [Type])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [Either TyVar Type] -> [Type]
forall a b. [Either a b] -> [b]
rights)
                       ((([Either TyVar Type], [Either TyVar Type]), Type)
 -> (([TyVar], [Type]), Type))
-> (([Either TyVar Type], [Either TyVar Type]), Type)
-> (([TyVar], [Type]), Type)
forall a b. (a -> b) -> a -> b
$ ([Either TyVar Type] -> ([Either TyVar Type], [Either TyVar Type]))
-> ([Either TyVar Type], Type)
-> (([Either TyVar Type], [Either TyVar Type]), Type)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Either TyVar Type -> Bool)
-> [Either TyVar Type]
-> ([Either TyVar Type], [Either TyVar Type])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\l :: Either TyVar Type
l -> case Either TyVar Type
l of Left _ -> Bool
True
                                                      _      -> Bool
False))
                       (([Either TyVar Type], Type)
 -> (([Either TyVar Type], [Either TyVar Type]), Type))
-> ([Either TyVar Type], Type)
-> (([Either TyVar Type], [Either TyVar Type]), Type)
forall a b. (a -> b) -> a -> b
$ Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty
    newExpr :: Term
newExpr = case Type -> TypeView
tyView Type
dictTy of
      (TyConApp tcNm :: TyConName
tcNm _)
        | Just tc :: TyCon
tc <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
tcNm TyConMap
tcm
        , Bool -> Bool
not (TyCon -> Bool
isNewTypeTc TyCon
tc)
        -> (State Int Term -> Int -> Term) -> Int -> State Int Term -> Term
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int Term -> Int -> Term
forall s a. State s a -> s -> a
State.evalState (0 :: Int) (State Int Term -> Term) -> State Int Term -> Term
forall a b. (a -> b) -> a -> b
$ do
                          Id
dcId <- InScopeSet -> Text -> Type -> StateT Int Identity Id
forall (m :: * -> *).
(Monad m, MonadUnique m) =>
InScopeSet -> Text -> Type -> m Id
mkInternalVar InScopeSet
inScope0 "dict" Type
dictTy
                          let inScope1 :: InScopeSet
inScope1 = InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
inScope0 Id
dcId
                          Term
selE <- FilePath
-> InScopeSet -> TyConMap -> Term -> Int -> Int -> State Int Term
forall (m :: * -> *).
(HasCallStack, Functor m, Monad m, MonadUnique m) =>
FilePath -> InScopeSet -> TyConMap -> Term -> Int -> Int -> m Term
mkSelectorCase "mkClassSelector" InScopeSet
inScope1 TyConMap
tcm (Id -> Term
Var Id
dcId) 1 Int
sel
                          Term -> State Int Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> [TyVar] -> Term
mkTyLams (Term -> [Id] -> Term
mkLams Term
selE [Id
dcId]) [TyVar]
tvs)
      (FunTy arg :: Type
arg res :: Type
res) -> (State Int Term -> Int -> Term) -> Int -> State Int Term -> Term
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int Term -> Int -> Term
forall s a. State s a -> s -> a
State.evalState (0 :: Int) (State Int Term -> Term) -> State Int Term -> Term
forall a b. (a -> b) -> a -> b
$ do
                           Id
dcId <- InScopeSet -> Text -> Type -> StateT Int Identity Id
forall (m :: * -> *).
(Monad m, MonadUnique m) =>
InScopeSet -> Text -> Type -> m Id
mkInternalVar InScopeSet
inScope0 "dict" (Type -> Type -> Type
mkFunTy Type
arg Type
res)
                           Term -> State Int Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> [TyVar] -> Term
mkTyLams (Term -> [Id] -> Term
mkLams (Id -> Term
Var Id
dcId) [Id
dcId]) [TyVar]
tvs)
      _ -> (State Int Term -> Int -> Term) -> Int -> State Int Term -> Term
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int Term -> Int -> Term
forall s a. State s a -> s -> a
State.evalState (0 :: Int) (State Int Term -> Term) -> State Int Term -> Term
forall a b. (a -> b) -> a -> b
$ do
                           Id
dcId <- InScopeSet -> Text -> Type -> StateT Int Identity Id
forall (m :: * -> *).
(Monad m, MonadUnique m) =>
InScopeSet -> Text -> Type -> m Id
mkInternalVar InScopeSet
inScope0 "dict" Type
dictTy
                           Term -> State Int Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> [TyVar] -> Term
mkTyLams (Term -> [Id] -> Term
mkLams (Id -> Term
Var Id
dcId) [Id
dcId]) [TyVar]
tvs)

mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName)
mkTupTyCons :: GHC2CoreState -> (GHC2CoreState, IntMap TyConName)
mkTupTyCons tcMap :: GHC2CoreState
tcMap = (GHC2CoreState
tcMap'',IntMap TyConName
forall a. IntMap (Name a)
tupTcCache)
  where
    tupTyCons :: [TyCon]
tupTyCons        = TyCon
GHC.boolTyCon TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: TyCon
GHC.promotedTrueDataCon TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: TyCon
GHC.promotedFalseDataCon
                     TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: (Int -> TyCon) -> [Int] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (Boxity -> Int -> TyCon
GHC.tupleTyCon Boxity
GHC.Boxed) [2..62]
    (tcNames :: [Name a]
tcNames,tcMap' :: GHC2CoreState
tcMap',_) =
      RWS SrcSpan SrcSpanRB GHC2CoreState [Name a]
-> SrcSpan -> GHC2CoreState -> ([Name a], GHC2CoreState, SrcSpanRB)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
RWS.runRWS ((TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Name a))
-> [TyCon] -> RWS SrcSpan SrcSpanRB GHC2CoreState [Name a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\tc :: TyCon
tc -> (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Name a)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
GHC.tyConName TyCon -> Unique
GHC.tyConUnique
                                          Name -> C2C Text
qualifiedNameString TyCon
tc) [TyCon]
tupTyCons)
                 SrcSpan
GHC.noSrcSpan
                 GHC2CoreState
tcMap
    tupTcCache :: IntMap (Name a)
tupTcCache       = [(Int, Name a)] -> IntMap (Name a)
forall a. [(Int, a)] -> IntMap a
IMS.fromList ([Int] -> [Name a] -> [(Int, Name a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [2..62] (Int -> [Name a] -> [Name a]
forall a. Int -> [a] -> [a]
drop 3 [Name a]
forall a. [Name a]
tcNames))
    tupHM :: UniqMap TyCon
tupHM            = [(Name Any, TyCon)] -> UniqMap TyCon
forall a b. Uniquable a => [(a, b)] -> UniqMap b
listToUniqMap ([Name Any] -> [TyCon] -> [(Name Any, TyCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name Any]
forall a. [Name a]
tcNames [TyCon]
tupTyCons)
    tcMap'' :: GHC2CoreState
tcMap''          = GHC2CoreState
tcMap' GHC2CoreState -> (GHC2CoreState -> GHC2CoreState) -> GHC2CoreState
forall a b. a -> (a -> b) -> b
& (UniqMap TyCon -> Identity (UniqMap TyCon))
-> GHC2CoreState -> Identity GHC2CoreState
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap ((UniqMap TyCon -> Identity (UniqMap TyCon))
 -> GHC2CoreState -> Identity GHC2CoreState)
-> (UniqMap TyCon -> UniqMap TyCon)
-> GHC2CoreState
-> GHC2CoreState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
forall a. UniqMap a -> UniqMap a -> UniqMap a
`unionUniqMap` UniqMap TyCon
tupHM)