{-|
Copyright : (C) 2013-2016, University of Twente,
2016-2017, Myrtle Software Ltd,
2017-2022, Google Inc.
2021, QBayLogic B.V.,
License : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Clash.GHC.GHC2Core
( C2C
, GHC2CoreState
, GHC2CoreEnv (..)
, srcSpan
, tyConMap
, coreToTerm
, coreToId
, coreToName
, modNameM
, qualifiedNameString
, qualifiedNameString'
, makeAllTyCons
, emptyGHC2CoreState
)
where
-- External Modules
import Control.Lens ((^.), (%~), (&), (%=), (.~), view, makeLenses)
import Control.Applicative ((<|>))
import Control.Monad.Extra (ifM, andM)
import Control.Monad.RWS.Strict (RWS)
import qualified Control.Monad.RWS.Strict as RWS
import Data.Bifunctor (second)
import Data.Binary.IEEE754 (doubleToWord, floatToWord)
import qualified Data.ByteString.Char8 as Char8
import Data.Char (isDigit)
import Data.Hashable (Hashable (..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes,fromMaybe,listToMaybe)
import Data.Text (Text, pack)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Traversable as T
import Data.String.Interpolate (__i)
import qualified Text.Read as Text
#if MIN_VERSION_ghc(9,4,0)
import Data.Primitive.ByteArray (ByteArray(ByteArray))
import qualified GHC.Data.Strict as GHC
import GHC.Num.Integer (integerToBigNatClamp#)
#endif
#if MIN_VERSION_ghc(9,6,0)
import Language.Haskell.Syntax.Basic (FieldLabelString (..))
#endif
-- GHC API
#if MIN_VERSION_ghc(9,4,0)
import GHC.Core.Reduction (Reduction(Reduction))
#endif
#if MIN_VERSION_ghc(9,0,0)
import GHC.Builtin.Types (falseDataCon)
import GHC.Core.Coercion.Axiom
(CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs), fromBranches)
import GHC.Core.Coercion (Role (Nominal), coercionType, coercionKind)
import GHC.Core.FVs (exprSomeFreeVars)
import GHC.Core
(AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..),
#if MIN_VERSION_ghc(9,2,0)
Alt(..),
#else
Tickish (..),
#endif
collectArgs, rhssOfAlts, unfoldingTemplate)
#if MIN_VERSION_ghc(9,2,0)
import GHC.Types.Tickish (GenTickish (..))
#endif
import GHC.Core.DataCon
(DataCon, dataConExTyCoVars, dataConName, dataConRepArgTys, dataConTag,
dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel,
HsImplBang(..), dataConImplBangs)
import GHC.Core.FamInstEnv
(FamInst (..), FamInstEnvs, familyInstances, normaliseType, emptyFamInstEnvs)
import GHC.Data.FastString (unpackFS, bytesFS)
import GHC.Types.Id (isDataConId_maybe)
import GHC.Types.Id.Info (IdDetails (..), unfoldingInfo)
import GHC.Types.Literal (Literal (..), LitNumType (..), literalType)
import GHC.Unit.Module (moduleName, moduleNameString)
import GHC.Types.Name
(Name, nameModule_maybe, nameOccName, nameUnique, getSrcSpan)
import GHC.Builtin.Names (integerTyConKey, naturalTyConKey)
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Data.Pair (Pair (..))
import GHC.Types.SrcLoc (SrcSpan (..), isGoodSrcSpan)
import GHC.Core.TyCon
(AlgTyConRhs (..), TyCon, tyConName, algTyConRhs, isAlgTyCon, isFamilyTyCon,
isNewTyCon, isPrimTyCon, isTupleTyCon,
isClosedSynFamilyTyConWithAxiom_maybe, expandSynTyCon_maybe, tyConArity,
tyConDataCons, tyConKind, tyConName, tyConUnique, isClassTyCon, isPromotedDataCon_maybe)
#if MIN_VERSION_ghc(9,6,0)
import GHC.Core.TyCon (ExpandSynResult (..))
import GHC.Core.Type (tyConAppFunTy_maybe)
#else
import GHC.Core.TyCon (isFunTyCon)
#endif
import GHC.Core.Type (mkTvSubstPrs, substTy, coreView)
import GHC.Core.TyCo.Rep (Coercion (..), TyLit (..), Type (..), scaledThing)
import GHC.Types.Unique (Uniquable (..), Unique, getKey, hasKey)
import GHC.Types.Var
(Id, TyVar, Var, VarBndr (..), idDetails, isTyVar, varName, varType,
varUnique, idInfo, isGlobalId)
import GHC.Types.Var.Set (isEmptyVarSet)
#else
import CoAxiom (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs),
fromBranches, Role (Nominal))
import Coercion (coercionType,coercionKind)
import CoreFVs (exprSomeFreeVars)
import CoreSyn
(AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..),
collectArgs, rhssOfAlts, unfoldingTemplate)
import TysWiredIn (falseDataCon)
import DataCon (DataCon, HsImplBang(..),
#if MIN_VERSION_ghc(8,8,0)
dataConExTyCoVars,
#else
dataConExTyVars,
#endif
dataConName, dataConRepArgTys,
dataConTag, dataConTyCon,
dataConUnivTyVars, dataConWorkId,
dataConFieldLabels, flLabel, dataConImplBangs)
import FamInstEnv (FamInst (..), FamInstEnvs,
familyInstances, normaliseType, emptyFamInstEnvs)
#if MIN_VERSION_ghc(8,10,0)
import FastString (unpackFS, bytesFS)
#else
import FastString (unpackFS, fastStringToByteString)
#endif
import Id (isDataConId_maybe)
import IdInfo (IdDetails (..), unfoldingInfo)
import Literal (Literal (..), LitNumType (..))
#if MIN_VERSION_ghc(8,8,0)
import Literal (literalType)
#endif
import Module (moduleName, moduleNameString)
import Name (Name, nameModule_maybe,
nameOccName, nameUnique, getSrcSpan)
import PrelNames (integerTyConKey, naturalTyConKey)
import OccName (occNameString)
import Pair (Pair (..))
import SrcLoc (SrcSpan (..), isGoodSrcSpan)
import TyCon (AlgTyConRhs (..), TyCon, tyConName,
algTyConRhs, isAlgTyCon, isFamilyTyCon,
isFunTyCon, isNewTyCon, isPromotedDataCon_maybe,
isPrimTyCon, isTupleTyCon,
isClosedSynFamilyTyConWithAxiom_maybe,
expandSynTyCon_maybe,
tyConArity,
tyConDataCons, tyConKind,
tyConName, tyConUnique, isClassTyCon)
import Type (mkTvSubstPrs, substTy, coreView)
import TyCoRep (Coercion (..), TyLit (..), Type (..))
import Unique (Uniquable (..), Unique, getKey, hasKey)
import Var (Id, TyVar, Var, idDetails,
isTyVar, varName, varType,
varUnique, idInfo, isGlobalId)
#if MIN_VERSION_ghc(8,8,0)
import Var (VarBndr (..))
#else
import Var (TyVarBndr (..))
#endif
import VarSet (isEmptyVarSet)
#endif
-- Local imports
import Clash.Annotations.Primitive (extractPrim)
import Clash.Annotations.SynthesisAttributes (Annotate, Attr(..))
import qualified Clash.Core.DataCon as C
import qualified Clash.Core.Literal as C
import qualified Clash.Core.Name as C
import qualified Clash.Core.Pretty as C
import qualified Clash.Core.Term as C
import qualified Clash.Core.TyCon as C
import qualified Clash.Core.Type as C
import qualified Clash.Core.Util as C (undefinedTy, undefinedXPrims)
import qualified Clash.Core.Var as C
import qualified Clash.Data.UniqMap as C
import Clash.Normalize.Primitives as C
import Clash.Primitives.Types hiding (name)
import Clash.Util
import Clash.GHC.Util
instance Hashable Name where
hashWithSalt s = hashWithSalt s . getKey . nameUnique
data GHC2CoreState
= GHC2CoreState
{ _tyConMap :: C.UniqMap TyCon
, _nameMap :: HashMap Name Text
}
makeLenses ''GHC2CoreState
data GHC2CoreEnv
= GHC2CoreEnv
{ _srcSpan :: SrcSpan
, _famInstEnvs :: FamInstEnvs
}
makeLenses ''GHC2CoreEnv
emptyGHC2CoreState :: GHC2CoreState
emptyGHC2CoreState = GHC2CoreState mempty HashMap.empty
newtype SrcSpanRB = SrcSpanRB {unSrcSpanRB :: SrcSpan}
instance Semigroup SrcSpanRB where
(SrcSpanRB l) <> (SrcSpanRB r) =
if isGoodSrcSpan r
then SrcSpanRB r
else SrcSpanRB l
instance Monoid SrcSpanRB where
mempty = SrcSpanRB noSrcSpan
type C2C = RWS GHC2CoreEnv SrcSpanRB GHC2CoreState
makeAllTyCons
:: GHC2CoreState
-> FamInstEnvs
-> C.UniqMap C.TyCon
makeAllTyCons hm fiEnvs = go hm hm
where
go old new
| C.null (new ^. tyConMap) = mempty
| otherwise = tcm <> tcm'
where
(tcm,old', _) = RWS.runRWS (T.mapM makeTyCon (new ^. tyConMap))
(GHC2CoreEnv noSrcSpan fiEnvs)
old
tcm' = go old' (old' & tyConMap %~ (`C.difference` (old ^. tyConMap)))
makeTyCon :: TyCon
-> C2C C.TyCon
makeTyCon tc = tycon
where
tycon
| isFamilyTyCon tc = mkFunTyCon
| isTupleTyCon tc = mkTupleTyCon
| isAlgTyCon tc = mkAlgTyCon
| isPrimTyCon tc = mkPrimTyCon
| Just dc <- isPromotedDataCon_maybe tc = mkPromotedDataCon dc
| otherwise = mkVoidTyCon
where
tcArity = tyConArity tc
mkAlgTyCon = do
tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc
case tcRhsM of
Just tcRhs ->
return
C.AlgTyCon
{ C.tyConUniq = C.nameUniq tcName
, C.tyConName = tcName
, C.tyConKind = tcKind
, C.tyConArity = tcArity
, C.algTcRhs = tcRhs
, C.isClassTc = isClassTyCon tc
}
Nothing -> return (C.PrimTyCon (C.nameUniq tcName) tcName tcKind tcArity)
mkFunTyCon = do
tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
substs <- case isClosedSynFamilyTyConWithAxiom_maybe tc of
Nothing -> do
instances <- familyInstances <$> view famInstEnvs <*> pure tc
mapM famInstToSubst instances
Just cx -> let bx = fromBranches (co_ax_branches cx)
in mapM (\b -> (,) <$> mapM coreToType (cab_lhs b)
<*> coreToType (cab_rhs b))
bx
return
C.FunTyCon
{ C.tyConUniq = C.nameUniq tcName
, C.tyConName = tcName
, C.tyConKind = tcKind
, C.tyConArity = tcArity
, C.tyConSubst = substs
}
mkTupleTyCon = do
tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
case tyConDataCons tc of
dc:_ -> do
tcDc <- fmap (C.DataTyCon . (:[])) (coreToDataCon dc)
return
C.AlgTyCon
{ C.tyConUniq = C.nameUniq tcName
, C.tyConName = tcName
, C.tyConKind = tcKind
, C.tyConArity = tcArity
, C.algTcRhs = tcDc
, C.isClassTc = isClassTyCon tc
}
_ -> error "impossible"
mkPrimTyCon = do
tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
return
C.PrimTyCon
{ C.tyConUniq = C.nameUniq tcName
, C.tyConName = tcName
, C.tyConKind = tcKind
, C.tyConArity = tcArity
}
mkPromotedDataCon dc = do
tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
tcData <- coreToDataCon dc
return
C.PromotedDataCon
{ C.tyConUniq = C.nameUniq tcName
, C.tyConName = tcName
, C.tyConKind = tcKind
, C.tyConArity = tcArity
, C.tyConData = tcData
}
mkVoidTyCon = do
tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tcKind <- coreToType (tyConKind tc)
return (C.PrimTyCon (C.nameUniq tcName) tcName tcKind tcArity)
famInstToSubst :: FamInst -> C2C ([C.Type],C.Type)
famInstToSubst fi = do
tys <- mapM coreToType (fi_tys fi)
ty <- coreToType (fi_rhs fi)
return (tys,ty)
makeAlgTyConRhs :: AlgTyConRhs
-> C2C (Maybe C.AlgTyConRhs)
makeAlgTyConRhs algTcRhs = case algTcRhs of
DataTyCon {data_cons = dcs} -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
SumTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#if MIN_VERSION_ghc(8,10,0)
NewTyCon dc _ (rhsTvs,rhsEtad) _ _ ->
#else
NewTyCon dc _ (rhsTvs,rhsEtad) _ ->
#endif
Just <$> (C.NewTyCon <$> coreToDataCon dc
<*> ((,) <$> mapM coreToTyVar rhsTvs
<*> coreToType rhsEtad
)
)
AbstractTyCon {} -> return Nothing
TupleTyCon {} -> error "Cannot handle tuple tycons"
coreToTerm
:: CompiledPrimMap
-> [Var]
-> CoreExpr
-> C2C C.Term
coreToTerm primMap unlocs = term
where
term :: CoreExpr -> C2C C.Term
term e
| (Var x,args) <- collectArgs e
, let (nm, _) = RWS.evalRWS (qualifiedNameString (varName x))
(GHC2CoreEnv noSrcSpan emptyFamInstEnvs)
emptyGHC2CoreState
= go nm args
| otherwise
= term' e
where
-- Remove most Signal transformers
go "Clash.Signal.Internal.mapSignal#" args
| length args == 5
= term (App (args!!3) (args!!4))
go "Clash.Signal.Internal.signal#" args
| length args == 3
= term (args!!2)
go "Clash.Signal.Internal.appSignal#" args
| length args == 5
= term (App (args!!3) (args!!4))
go "Clash.Signal.Internal.joinSignal#" args
| length args == 3
= term (args!!2)
go "Clash.Signal.Bundle.vecBundle#" args
| length args == 4
= term (args!!3)
--- Remove `$`
go "GHC.Base.$" args
| length args == 5
= term (App (args!!3) (args!!4))
go "GHC.Magic.noinline" args -- noinline :: forall a. a -> a
| [_ty, x] <- args
= term x
-- Remove most CallStack logic
go "GHC.Stack.Types.PushCallStack" args = term (last args)
go "GHC.Stack.Types.FreezeCallStack" args = term (last args)
go "GHC.Stack.withFrozenCallStack" args
| length args == 3
= term (App (args!!2) (args!!1))
go "Clash.Sized.BitVector.Internal.checkUnpackUndef" args
| [_nTy,_aTy,_kn,_typ,f] <- args
= term f
go "Clash.Magic.prefixName" args
| [Type nmTy,_aTy,f] <- args
= C.Tick <$> (C.NameMod C.PrefixName <$> coreToType nmTy) <*> term f
go "Clash.Magic.suffixName" args
| [Type nmTy,_aTy,f] <- args
= C.Tick <$> (C.NameMod C.SuffixName <$> coreToType nmTy) <*> term f
go "Clash.Magic.suffixNameFromNat" args
| [Type nmTy,_aTy,f] <- args
= C.Tick <$> (C.NameMod C.SuffixName <$> coreToType nmTy) <*> term f
go "Clash.Magic.suffixNameP" args
| [Type nmTy,_aTy,f] <- args
= C.Tick <$> (C.NameMod C.SuffixNameP <$> coreToType nmTy) <*> term f
go "Clash.Magic.suffixNameFromNatP" args
| [Type nmTy,_aTy,f] <- args
= C.Tick <$> (C.NameMod C.SuffixNameP <$> coreToType nmTy) <*> term f
go "Clash.Magic.setName" args
| [Type nmTy,_aTy,f] <- args
= C.Tick <$> (C.NameMod C.SetName <$> coreToType nmTy) <*> term f
go "Clash.Magic.deDup" args
| [_aTy,f] <- args
= C.Tick C.DeDup <$> term f
go "Clash.Magic.noDeDup" args
| [_aTy,f] <- args
= C.Tick C.NoDeDup <$> term f
go "Clash.Magic.clashSimulation" _
= C.Data <$> coreToDataCon falseDataCon
go "Clash.XException.xToErrorCtx" args
-- xToErrorCtx :: forall a. String -> a -> a
| [_ty, _msg, x] <- args
= term x
go nm args
| Just n <- parseBundle "bundle" nm
-- length args = domain tyvar + signal arg + number of type vars
, length args == 2 + n
= term (last args)
go nm args
| Just n <- parseBundle "unbundle" nm
-- length args = domain tyvar + signal arg + number of type vars
, length args == 2 + n
= term (last args)
go _ _ = term' e
parseBundle :: Text -> Text -> Maybe Int
parseBundle fNm nm0 = do
nm1 <- Text.stripPrefix ("Clash.Signal.Bundle." <> fNm) nm0
nm2 <- Text.stripSuffix "#" nm1
Text.readMaybe (Text.unpack nm2)
term' (Var x) = var x
#if MIN_VERSION_ghc(8,8,0)
term' (Lit l@LitRubbish{}) = do
ty <- coreToType (literalType l)
return (C.Prim (C.PrimInfo (pack "_RUBBISH_")
ty
C.WorkNever
C.SingleResult
C.NoUnfolding))
#endif
term' (Lit l) = return $ C.Literal (coreToLiteral l)
term' (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> coreToType tyArg
term' (App eFun eArg) = C.App <$> term eFun <*> term eArg
term' (Lam x e)
| isTyVar x
= C.TyLam <$> coreToTyVar x <*> addUsefull (getSrcSpan x) (term e)
| otherwise
= do
(e',sp) <- termSP (getSrcSpan x) e
x' <- coreToIdSP sp x
return (C.Lam x' e')
term' (Let (NonRec x e1) e2) = do
(e1',sp) <- termSP (getSrcSpan x) e1
x' <- coreToIdSP sp x
e2' <- term e2
return (C.Let (C.NonRec x' e1') e2')
term' (Let (Rec xes) e) = do
xes' <- mapM go xes
e' <- term e
return (C.Let (C.Rec xes') e')
where
go (x,b) = do
(b',sp) <- termSP (getSrcSpan x) b
x' <- coreToIdSP sp x
return (x',b')
term' (Case s _ ty []) = do
s' <- term' s
ty' <- coreToType ty
case C.collectArgs s' of
(C.Prim p, _) | C.primName p `elem` C.undefinedXPrims ->
-- GHC translates things like:
--
-- xToBV (Index.pack# (errorX @TY "QQ"))
--
-- to
--
-- xToBV (case (errorX @TY "QQ") of {})
--
--
-- Here we then translate
--
-- case (errorX @TY "QQ") of {}
--
-- to
--
-- undefinedX @TY
--
-- So that the evaluator rule for 'xToBV' can recognize things that
-- would normally throw XException
return (C.TyApp (C.Prim C.undefinedX) ty')
_ ->
return (C.TyApp (C.Prim C.undefined) ty')
term' (Case e b ty alts) = do
let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (== b))
$ rhssOfAlts alts
(e',sp) <- termSP (getSrcSpan b) e
b' <- coreToIdSP sp b
ty' <- coreToType ty
let caseTerm v =
C.Case v ty' <$> mapM (addUsefull sp . alt sp) alts
if usesBndr
then do
ct <- caseTerm (C.Var b')
return (C.Let (C.NonRec b' e') ct)
else caseTerm e'
term' (Cast e co) = do
let (Pair ty1 ty2) = coercionKind co
hasPrimCoM <- hasPrimCo co
sizedCast <- isSizedCast ty1 ty2
case hasPrimCoM of
Just _ | sizedCast
-> C.Cast <$> term e <*> coreToType ty1 <*> coreToType ty2
_ -> term e
term' (Tick (SourceNote rsp _) e) =
#if MIN_VERSION_ghc(9,4,0)
C.Tick (C.SrcSpan (RealSrcSpan rsp GHC.Nothing)) <$>
addUsefull (RealSrcSpan rsp GHC.Nothing) (term e)
#elif MIN_VERSION_ghc(9,0,0)
C.Tick (C.SrcSpan (RealSrcSpan rsp Nothing)) <$>
addUsefull (RealSrcSpan rsp Nothing) (term e)
#else
C.Tick (C.SrcSpan (RealSrcSpan rsp)) <$> addUsefull (RealSrcSpan rsp) (term e)
#endif
term' (Tick _ e) = term e
term' (Type t) =
C.TyApp (C.Prim (C.PrimInfo (pack "_TY_") C.undefinedTy C.WorkNever C.SingleResult C.NoUnfolding))
<$> coreToType t
term' (Coercion co) =
C.TyApp (C.Prim (C.PrimInfo (pack "_CO_") C.undefinedTy C.WorkNever C.SingleResult C.NoUnfolding))
<$> coreToType (coercionType co)
termSP sp = fmap (second unSrcSpanRB) . RWS.listen . addUsefullR sp . term
coreToIdSP sp = RWS.local (\r@(GHC2CoreEnv _ e) ->
if isGoodSrcSpan sp then
GHC2CoreEnv sp e
else
r)
. coreToId
lookupPrim :: Text -> Maybe (Maybe CompiledPrimitive)
lookupPrim nm = extractPrim <$> HashMap.lookup nm primMap
var x = do
xPrim <- if isGlobalId x then coreToPrimVar x else coreToVar x
let xNameS = C.nameOcc xPrim
xType <- coreToType (varType x)
case isDataConId_maybe x of
Just dc -> case lookupPrim xNameS of
Just p ->
-- Primitive will be marked MultiResult in Transformations if it
-- is a multi result primitive.
return $ C.Prim (C.PrimInfo xNameS xType (maybe C.WorkVariable workInfo p) C.SingleResult C.NoUnfolding)
Nothing -> if isDataConWrapId x && not (isNewTyCon (dataConTyCon dc))
then let xInfo = idInfo x
unfolding = unfoldingInfo xInfo
in case unfolding of
CoreUnfolding {} -> do
sp <- view srcSpan
RWS.censor (const (SrcSpanRB sp)) (term (unfoldingTemplate unfolding))
NoUnfolding -> error ("No unfolding for DC wrapper: " ++ showPprUnsafe x)
_ -> error ("Unexpected unfolding for DC wrapper: " ++ showPprUnsafe x)
else C.Data <$> coreToDataCon dc
Nothing -> case lookupPrim xNameS of
Just (Just (Primitive f wi _))
| Just n <- parseBundle "bundle" f -> return (bundleUnbundleTerm (n+1) xType)
| Just n <- parseBundle "unbundle" f -> return (bundleUnbundleTerm (n+1) xType)
| f == "Clash.Signal.Internal.mapSignal#" -> return (mapSignalTerm xType)
| f == "Clash.Signal.Internal.signal#" -> return (signalTerm xType)
| f == "Clash.Signal.Internal.appSignal#" -> return (appSignalTerm xType)
| f == "Clash.Signal.Internal.traverse#" -> return (traverseTerm xType)
| f == "Clash.Signal.Internal.joinSignal#" -> return (joinTerm xType)
| f == "Clash.Signal.Bundle.vecBundle#" -> return (vecUnwrapTerm xType)
| f == "GHC.Base.$" -> return (dollarTerm xType)
| f == "GHC.Stack.withFrozenCallStack" -> return (withFrozenCallStackTerm xType)
| f == "GHC.Magic.noinline" -> return (idTerm xType)
| f == "GHC.Magic.lazy" -> return (idTerm xType)
| f == "GHC.Magic.runRW#" -> return (runRWTerm xType)
| f == "Clash.Sized.Internal.BitVector.checkUnpackUndef" -> return (checkUnpackUndefTerm xType)
| f == "Clash.Magic.prefixName"
-> return (nameModTerm C.PrefixName xType)
| f == "Clash.Magic.postfixName"
-> return (nameModTerm C.SuffixName xType)
| f == "Clash.Magic.setName"
-> return (nameModTerm C.SetName xType)
| f == "Clash.XException.xToErrorCtx"
-> return (xToErrorCtxTerm xType)
| x `elem` unlocs
-> return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult C.NoUnfolding))
| otherwise
-> do bndr <- coreToId x
return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult (C.Unfolding bndr)))
Just (Just (BlackBox {workInfo = wi}))
| x `elem` unlocs
-> return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult C.NoUnfolding)
| otherwise
-> do bndr <- coreToId x
return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult (C.Unfolding bndr)))
Just (Just (BlackBoxHaskell {workInfo = wi}))
| x `elem` unlocs
-> return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult C.NoUnfolding)
| otherwise
-> do bndr <- coreToId x
return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult (C.Unfolding bndr))
Just Nothing ->
-- Was guarded by "DontTranslate". We don't know yet if Clash will
-- actually use it later on, so we don't err here.
return $ C.Prim (C.PrimInfo xNameS xType C.WorkVariable C.SingleResult C.NoUnfolding)
Nothing
| x `elem` unlocs
-> return (C.Prim (C.PrimInfo xNameS xType C.WorkVariable C.SingleResult C.NoUnfolding))
| otherwise
-> C.Var <$> coreToId x
#if MIN_VERSION_ghc(9,2,0)
alt _ (Alt DEFAULT _ e) = (C.DefaultPat,) <$> term e
alt _ (Alt (LitAlt l) _ e) = (C.LitPat (coreToLiteral l),) <$> term e
alt sp0 (Alt (DataAlt dc) xs e) = case span isTyVar xs of
#else
alt _ (DEFAULT , _ , e) = (C.DefaultPat,) <$> term e
alt _ (LitAlt l , _ , e) = (C.LitPat (coreToLiteral l),) <$> term e
alt sp0 (DataAlt dc, xs, e) = case span isTyVar xs of
#endif
(tyvs,tmvs) -> do
(e',sp1) <- termSP sp0 e
(,) <$> (C.DataPat <$> coreToDataCon dc
<*> mapM coreToTyVar tyvs
<*> mapM (coreToIdSP sp1) tmvs)
<*> pure e'
coreToLiteral :: Literal
-> C.Literal
coreToLiteral l = case l of
#if MIN_VERSION_ghc(8,8,0)
LitString fs -> C.StringLiteral (Char8.unpack fs)
LitChar c -> C.CharLiteral c
LitRubbish{} ->
error $ "coreToTerm: Encountered LibRubbish. This is a bug in Clash. "
++ "Report on https://github.com/clash-lang/clash-compiler/issues."
#else
MachStr fs -> C.StringLiteral (Char8.unpack fs)
MachChar c -> C.CharLiteral c
#endif
#if MIN_VERSION_ghc(9,0,0)
LitNumber lt i -> case lt of
#else
LitNumber lt i _ -> case lt of
#endif
#if MIN_VERSION_ghc(9,4,0)
LitNumBigNat -> C.ByteArrayLiteral (ByteArray (integerToBigNatClamp# i))
#else
LitNumInteger -> C.IntegerLiteral i
LitNumNatural -> C.NaturalLiteral i
#endif
LitNumInt -> C.IntLiteral i
LitNumInt64 -> C.IntLiteral i
LitNumWord -> C.WordLiteral i
LitNumWord64 -> C.WordLiteral i
#if MIN_VERSION_ghc(9,2,0)
LitNumInt8 -> C.Int8Literal i
LitNumInt16 -> C.Int16Literal i
LitNumInt32 -> C.Int32Literal i
LitNumWord8 -> C.Word8Literal i
LitNumWord16 -> C.Word16Literal i
LitNumWord32 -> C.Word32Literal i
#endif
#if MIN_VERSION_ghc(8,8,0)
LitFloat r -> C.FloatLiteral . floatToWord $ fromRational r
LitDouble r -> C.DoubleLiteral . doubleToWord $ fromRational r
LitNullAddr -> C.StringLiteral []
LitLabel fs _ _ -> C.StringLiteral (unpackFS fs)
#else
MachFloat r -> C.FloatLiteral . floatToWord $ fromRational r
MachDouble r -> C.DoubleLiteral . doubleToWord $ fromRational r
MachNullAddr -> C.StringLiteral []
MachLabel fs _ _ -> C.StringLiteral (unpackFS fs)
#endif
addUsefull :: SrcSpan
-> C2C a
-> C2C a
addUsefull x m =
if isGoodSrcSpan x
then do a <- RWS.local (srcSpan .~ x) m
RWS.tell (SrcSpanRB x)
return a
else m
addUsefullR :: SrcSpan
-> C2C a
-> C2C a
addUsefullR x m =
if isGoodSrcSpan x
then RWS.local (srcSpan .~ x) m
else m
isSizedCast :: Type -> Type -> C2C Bool
isSizedCast (TyConApp tc1 _) (TyConApp tc2 _) = do
tc1Nm <- qualifiedNameString (tyConName tc1)
tc2Nm <- qualifiedNameString (tyConName tc2)
return
(or [tc1 `hasKey` integerTyConKey &&
or [tc2Nm == "Clash.Sized.Internal.Signed.Signed"
,tc2Nm == "Clash.Sized.Internal.Index.Index"]
,tc2 `hasKey` integerTyConKey &&
or [tc1Nm == "Clash.Sized.Internal.Signed.Signed"
,tc1Nm == "Clash.Sized.Internal.Index.Index"]
,tc1 `hasKey` naturalTyConKey &&
tc2Nm == "Clash.Sized.Internal.Unsigned.Unsigned"
,tc2 `hasKey` naturalTyConKey &&
tc1Nm == "Clash.Sized.Internal.Unsigned.Unsigned"
])
isSizedCast _ _ = return False
hasPrimCo :: Coercion -> C2C (Maybe Type)
hasPrimCo (TyConAppCo _ _ coers) = do
tcs <- catMaybes <$> mapM hasPrimCo coers
return (listToMaybe tcs)
hasPrimCo (AppCo co1 co2) = do
tc1M <- hasPrimCo co1
case tc1M of
Just _ -> return tc1M
_ -> hasPrimCo co2
hasPrimCo (ForAllCo _ _ co) = hasPrimCo co
hasPrimCo co@(AxiomInstCo _ _ coers) = do
let (Pair ty1 _) = coercionKind co
ty1PM <- isPrimTc ty1
if ty1PM
then return (Just ty1)
else do
tcs <- catMaybes <$> mapM hasPrimCo coers
return (listToMaybe tcs)
where
isPrimTc (TyConApp tc _) = do
tcNm <- qualifiedNameString (tyConName tc)
return (tcNm `elem` ["Clash.Sized.Internal.BitVector.Bit"
,"Clash.Sized.Internal.BitVector.BitVector"
,"Clash.Sized.Internal.Index.Index"
,"Clash.Sized.Internal.Signed.Signed"
,"Clash.Sized.Internal.Unsigned.Unsigned"
])
isPrimTc _ = return False
hasPrimCo (SymCo co) = hasPrimCo co
hasPrimCo (TransCo co1 co2) = do
tc1M <- hasPrimCo co1
case tc1M of
Just _ -> return tc1M
_ -> hasPrimCo co2
hasPrimCo (AxiomRuleCo _ coers) = do
tcs <- catMaybes <$> mapM hasPrimCo coers
return (listToMaybe tcs)
#if MIN_VERSION_ghc(9,6,0)
hasPrimCo (SelCo _ co) = hasPrimCo co
#else
hasPrimCo (NthCo _ _ co) = hasPrimCo co
#endif
hasPrimCo (LRCo _ co) = hasPrimCo co
hasPrimCo (InstCo co _) = hasPrimCo co
hasPrimCo (SubCo co) = hasPrimCo co
hasPrimCo _ = return Nothing
coreToDataCon :: DataCon
-> C2C C.DataCon
coreToDataCon dc = do
#if MIN_VERSION_ghc(9,0,0)
repTys <- mapM (coreToType . scaledThing) (dataConRepArgTys dc)
#else
repTys <- mapM coreToType (dataConRepArgTys dc)
#endif
dcTy <- coreToType (varType $ dataConWorkId dc)
mkDc dcTy repTys
where
mkDc dcTy repTys = do
#if MIN_VERSION_ghc(9,6,0)
let decLabel = decodeUtf8 . bytesFS . field_label . flLabel
#elif MIN_VERSION_ghc(8,10,0)
let decLabel = decodeUtf8 . bytesFS . flLabel
#else
let decLabel = decodeUtf8 . fastStringToByteString . flLabel
#endif
let repBangs = fmap hsImplBangToBool (dataConImplBangs dc)
let fLabels = map decLabel (dataConFieldLabels dc)
nm <- coreToName dataConName getUnique qualifiedNameString dc
uTvs <- mapM coreToTyVar (dataConUnivTyVars dc)
#if MIN_VERSION_ghc(8,8,0)
eTvs <- mapM coreToTyVar (dataConExTyCoVars dc)
#else
eTvs <- mapM coreToTyVar (dataConExTyVars dc)
#endif
return $ C.MkData
{ C.dcName = nm
, C.dcUniq = C.nameUniq nm
, C.dcTag = dataConTag dc
, C.dcType = dcTy
, C.dcArgTys = repTys
, C.dcArgStrict = repBangs
, C.dcUnivTyVars = uTvs
, C.dcExtTyVars = eTvs
, C.dcFieldLabels = fLabels
}
hsImplBangToBool :: HsImplBang -> C.DcStrictness
hsImplBangToBool HsLazy = C.Lazy
hsImplBangToBool HsStrict{} = C.Strict
hsImplBangToBool HsUnpack{} = C.Strict
typeConstructorToString
:: TyCon
-> C2C String
typeConstructorToString constructor =
Text.unpack . C.nameOcc <$> coreToName tyConName tyConUnique qualifiedNameString constructor
-- | Flatten a list type structure to a list of types.
listTypeToListOfTypes :: Type -> [Type]
-- TyConApp ': [kind, head, tail]
listTypeToListOfTypes (TyConApp _ [_, a, as]) = a : listTypeToListOfTypes as
listTypeToListOfTypes ty =
case coreView ty of
Nothing -> []
Just ty' -> listTypeToListOfTypes ty'
-- | Try to determine boolean value by looking at constructor name of type.
boolTypeToBool :: Type -> C2C Bool
boolTypeToBool (TyConApp constructor _args) = do
constructorName <- typeConstructorToString constructor
return $ case constructorName of
"GHC.Types.True" -> True
"GHC.Types.False" -> False
_ -> error $ "Expected boolean constructor, got:" ++ constructorName
boolTypeToBool s =
error $ unwords [ "Could not unpack given type to bool:"
, showPprUnsafe s ]
-- | Returns string of (LitTy (StrTyLit s)) construction.
tyLitToString :: Type -> String
tyLitToString (LitTy (StrTyLit s)) = unpackFS s
tyLitToString s = error $ unwords [ "Could not unpack given type to string:"
, showPprUnsafe s ]
-- | Returns string in Text form of (LitTy (StrTyLit s)) construction.
tyLitToText :: Type -> Text
tyLitToText = Text.pack . tyLitToString
-- | Returns integer of (LitTy (NumTyLit n)) construction.
tyLitToInteger :: Type -> Integer
tyLitToInteger (LitTy (NumTyLit n)) = n
tyLitToInteger s = error $ unwords [ "Could not unpack given type to integer:"
, showPprUnsafe s ]
-- | Try to interpret a Type as an Attr
coreToAttr :: Type -> C2C (Attr Text)
coreToAttr t0@(TyConApp ty args) = do
name <- typeConstructorToString ty
envs <- view famInstEnvs
let
-- XXX: This relies on 'value' not being evaluated if the constructor
-- doesn't have a second field.
key = args !! 1
value = args !! 2
#if MIN_VERSION_ghc(9,4,0)
let Reduction _ key1 = normaliseType envs Nominal key
Reduction _ value1 = normaliseType envs Nominal value
#else
let (_,key1) = normaliseType envs Nominal key
(_,value1) = normaliseType envs Nominal value
#endif
if
| name == show 'StringAttr ->
return $ StringAttr (tyLitToText key1) (tyLitToText value1)
| name == show 'IntegerAttr ->
return $ IntegerAttr (tyLitToText key1) (tyLitToInteger value1)
| name == show 'BoolAttr -> do
bool <- boolTypeToBool value1
return $ BoolAttr (tyLitToText key1) bool
| name == show 'Attr ->
return $ Attr (tyLitToText key1)
| otherwise ->
case coreView t0 of
Just t1 -> coreToAttr t1
Nothing -> error $ [__i|Expected constructor of Attr, got #{name}|]
coreToAttr t0 =
case coreView t0 of
Just t1 -> coreToAttr t1
Nothing -> error $ [__i|Expected constructor of Attr, got #{showPprUnsafe t0}|]
coreToAttrs' :: [Type] -> C2C [Attr Text]
coreToAttrs' [k, a, attrs] = do
-- We expect three type arguments:
--
-- k: either @Attr@ or @[Attr]@
-- a: type being annotated
-- attrs: attribute or list of attributes
--
attrs1 <- tryList
attrs2 <- tryAttr
case attrs1 <|> attrs2 of
Just theseAttrs -> do
subAttrs <- coreToAttrs a
pure (theseAttrs <> subAttrs)
Nothing ->
error [__i|
Expected either an attribute or a list of attributes, got:
#{showPprUnsafe k}
|]
where
isListTy = fmap (== show ''[]) . typeConstructorToString
isAttrTy = fmap (== show ''Attr) . typeConstructorToString
tryList = case k of
TyConApp ty0 [TyConApp ty1 _] -> do
ifM
(andM [isListTy ty0, isAttrTy ty1])
(Just <$> traverse coreToAttr (listTypeToListOfTypes attrs))
(pure Nothing)
_ -> pure Nothing
tryAttr = case k of
TyConApp ty _ -> do
ifM
(isAttrTy ty)
(Just <$> sequence [coreToAttr attrs])
(pure Nothing)
_ -> pure Nothing
coreToAttrs' illegal =
error $ "Unexpected type args to Annotate: " ++ show (map (showPprUnsafe) illegal)
-- | If this type has an annotate type synonym, return list of attributes.
coreToAttrs :: Type -> C2C [Attr Text]
coreToAttrs (TyConApp tycon kindsOrTypes) = do
name' <- typeConstructorToString tycon
if name' == show ''Annotate
then coreToAttrs' kindsOrTypes
else return []
coreToAttrs _ =
return []
-- | Wrap given type in an annotation if it is annotated using the constructs
-- defined in Clash.Annotations.SynthesisAttributes.
annotateType
:: Type
-> C.Type
-> C2C C.Type
annotateType ty cty = do
attrs <- coreToAttrs ty
case attrs of
[] -> return cty
_ -> return $ C.AnnType attrs cty
-- | Converts GHC Type to a Clash Type. Strips newtypes and signals, with the
-- exception of newtypes used as annotations (see: SynthesisAttributes).
coreToType
:: Type
-> C2C C.Type
coreToType ty = ty'' >>= annotateType ty
where
ty'' =
case coreView ty of
Just ty' -> coreToType ty'
Nothing -> coreToType' ty
coreToType'
:: Type
-> C2C C.Type
coreToType' (TyVarTy tv) = C.VarTy <$> coreToTyVar tv
coreToType' (TyConApp tc args)
#if MIN_VERSION_ghc(9,6,0)
| Just (FunTy _ _ ty1 ty2) <- tyConAppFunTy_maybe tc args = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#else
| isFunTyCon tc = foldl C.AppTy (C.ConstTy C.Arrow) <$> mapM coreToType args
#endif
| otherwise = case expandSynTyCon_maybe tc args of
#if MIN_VERSION_ghc(9,6,0)
ExpandsSyn substs synTy remArgs -> do
#else
Just (substs,synTy,remArgs) -> do
#endif
let substs' = mkTvSubstPrs substs
synTy' = substTy substs' synTy
foldl C.AppTy <$> coreToType synTy' <*> mapM coreToType remArgs
_ -> do
tcName <- coreToName tyConName tyConUnique qualifiedNameString tc
tyConMap %= (C.insert tcName tc)
C.mkTyConApp <$> (pure tcName) <*> mapM coreToType args
#if MIN_VERSION_ghc(8,8,0)
coreToType' (ForAllTy (Bndr tv _) ty) = C.ForAllTy <$> coreToTyVar tv <*> coreToType ty
#else
coreToType' (ForAllTy (TvBndr tv _) ty) = C.ForAllTy <$> coreToTyVar tv <*> coreToType ty
#endif
#if MIN_VERSION_ghc(8,10,0)
-- TODO after we drop 8.8: save the distinction between => and ->
#if MIN_VERSION_ghc(9,0,0)
coreToType' (FunTy _ _ ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#else
coreToType' (FunTy _ ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#endif
#else
coreToType' (FunTy ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#endif
coreToType' (LitTy tyLit) = return $ C.LitTy (coreToTyLit tyLit)
coreToType' (AppTy ty1 ty2) = C.AppTy <$> coreToType ty1 <*> coreToType' ty2
coreToType' (CastTy t (Refl{})) = coreToType' t
coreToType' t@(CastTy _ _) = error ("Cannot handle CastTy " ++ showPprUnsafe t)
coreToType' t@(CoercionTy _) = error ("Cannot handle CoercionTy " ++ showPprUnsafe t)
coreToTyLit :: TyLit
-> C.LitTy
coreToTyLit (NumTyLit i) = C.NumTy (fromInteger i)
coreToTyLit (StrTyLit s) = C.SymTy (unpackFS s)
#if MIN_VERSION_ghc(9,2,0)
coreToTyLit (CharTyLit c) = C.CharTy c
#endif
coreToTyVar :: TyVar
-> C2C C.TyVar
coreToTyVar tv =
C.mkTyVar <$> coreToType (varType tv) <*> coreToVar tv
coreToId :: Id
-> C2C C.Id
coreToId i = do
C.mkId <$> coreToType (varType i) <*> pure scope <*> coreToVar i
where
scope = if isGlobalId i then C.GlobalId else C.LocalId
coreToVar :: Var
-> C2C (C.Name a)
coreToVar = coreToName varName varUnique qualifiedNameStringM
coreToPrimVar :: Var
-> C2C (C.Name C.Term)
coreToPrimVar = coreToName varName varUnique qualifiedNameString
coreToName
:: (b -> Name)
-> (b -> Unique)
-> (Name -> C2C Text)
-> b
-> C2C (C.Name a)
coreToName toName toUnique toString v = do
ns <- toString (toName v)
let key = getKey (toUnique v)
locI = getSrcSpan (toName v)
-- Is it one of [ds,ds1,ds2,..]
isDSX = maybe False (maybe True (isDigit . fst) . Text.uncons) . Text.stripPrefix "ds"
sort | isDSX ns || Text.isPrefixOf "$" ns
= C.System
| otherwise
= C.User
locR <- view srcSpan
let loc = if isGoodSrcSpan locI then locI else locR
return (C.Name sort ns key loc)
qualifiedNameString'
:: Name
-> Text
qualifiedNameString' n =
fromMaybe "_INTERNAL_" (modNameM n) `Text.append` ('.' `Text.cons` occName)
where
occName = pack (occNameString (nameOccName n))
qualifiedNameString
:: Name
-> C2C Text
qualifiedNameString n =
makeCached n nameMap $
return (fromMaybe "_INTERNAL_" (modNameM n) `Text.append` ('.' `Text.cons` occName))
where
occName = pack (occNameString (nameOccName n))
qualifiedNameStringM
:: Name
-> C2C Text
qualifiedNameStringM n =
makeCached n nameMap $
return (maybe occName (\modName -> modName `Text.append` ('.' `Text.cons` occName)) (modNameM n))
where
occName = pack (occNameString (nameOccName n))
modNameM :: Name
-> Maybe Text
modNameM n = do
module_ <- nameModule_maybe n
let moduleNm = moduleName module_
return (pack (moduleNameString moduleNm))
-- | Given the type:
--
-- @
-- forall dom a0 a1 .. aN
-- . Signal dom (a0, a1, .., aN)
-- -> (Signal dom a0, Signal dom a1, .., Signal dom aN)
-- @
--
-- or the type
--
-- @
-- forall dom a0 a1 .. aN
-- . (Signal dom a0, Signal dom a1, .., Signal dom aN)
-- -> Signal dom (a0, a1, .., aN)
-- @
--
-- Generate the term:
--
-- @/\dom. /\a0. /\a1. .. /\aN. \x -> x@
--
-- In other words: treat "bundle" and "unbundle" primitives as id.
--
bundleUnbundleTerm :: Int -> C.Type -> C.Term
bundleUnbundleTerm nTyVarsExpected = go []
where
go :: [C.TyVar] -> C.Type -> C.Term
go tvs (C.ForAllTy tv typ) = go (tv:tvs) typ
go tvs (C.tyView -> C.FunTy argTy _resTy) =
if length tvs /= nTyVarsExpected then
-- Internal error: should never happen unless we change the type of
-- bundle / unbundle.
error $ $(curLoc) ++ show (length tvs) ++ " vs " ++ show nTyVarsExpected
else
let sigName = C.mkLocalId argTy (C.mkUnsafeSystemName "c$s" 0) in
foldr C.TyLam (C.Lam sigName (C.Var sigName)) (reverse tvs)
go tvs ty = error $ $(curLoc) ++ show ty ++ " " ++ show tvs
-- | Given the type:
--
-- @forall a. forall b. forall clk. (a -> b) -> Signal clk a -> Signal clk b@
--
-- Generate the term:
--
-- @
-- /\(a:*)./\(b:*)./\(clk:Clock).\(f : (Signal clk a -> Signal clk b)).
-- \(x : Signal clk a).f x
-- @
mapSignalTerm :: C.Type
-> C.Term
mapSignalTerm (C.ForAllTy aTV (C.ForAllTy bTV (C.ForAllTy clkTV funTy)))
| (C.FunTy _ funTy'') <- C.tyView funTy
, (C.FunTy aTy bTy) <- C.tyView funTy''
= let
fName = C.mkUnsafeSystemName "f" 0
xName = C.mkUnsafeSystemName "x" 1
fTy = C.mkFunTy aTy bTy
fId = C.mkLocalId fTy fName
xId = C.mkLocalId aTy xName
in
C.TyLam aTV (
C.TyLam bTV (
C.TyLam clkTV (
C.Lam fId (
C.Lam xId (
C.App (C.Var fId) (C.Var xId))))))
mapSignalTerm ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @forall a. forall dom. a -> Signal dom a@
--
-- Generate the term
--
-- @/\(a:*)./\(dom:Domain).\(x:Signal dom a).x@
signalTerm :: C.Type
-> C.Term
signalTerm (C.ForAllTy aTV (C.ForAllTy domTV funTy))
| (C.FunTy _ saTy) <- C.tyView funTy
= let
xName = C.mkUnsafeSystemName "x" 0
xId = C.mkLocalId saTy xName
in
C.TyLam aTV (
C.TyLam domTV (
C.Lam xId (
C.Var xId)))
signalTerm ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @
-- forall dom. forall a. forall b. Signal dom (a -> b) -> Signal dom a ->
-- Signal dom b
-- @
--
-- Generate the term:
--
-- @
-- /\(dom:Domain)./\(a:*)./\(b:*).\(f : (Signal dom a -> Signal dom b)).
-- \(x : Signal dom a).f x
-- @
appSignalTerm :: C.Type
-> C.Term
appSignalTerm (C.ForAllTy domTV (C.ForAllTy aTV (C.ForAllTy bTV funTy)))
| (C.FunTy _ funTy'') <- C.tyView funTy
, (C.FunTy saTy sbTy) <- C.tyView funTy''
= let
fName = C.mkUnsafeSystemName "f" 0
xName = C.mkUnsafeSystemName "x" 1
fTy = C.mkFunTy saTy sbTy
fId = C.mkLocalId fTy fName
xId = C.mkLocalId saTy xName
in
C.TyLam domTV (
C.TyLam aTV (
C.TyLam bTV (
C.Lam fId (
C.Lam xId (
C.App (C.Var fId) (C.Var xId))))))
appSignalTerm ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @
-- forall t.forall n.forall a.Vec n (Signal t a) ->
-- Signal t (Vec n a)
-- @
--
-- Generate the term:
--
-- @
-- /\(t:Domain)./\(n:Nat)./\(a:*).\(vs:Signal t (Vec n a)).vs
-- @
vecUnwrapTerm :: C.Type
-> C.Term
vecUnwrapTerm (C.ForAllTy tTV (C.ForAllTy nTV (C.ForAllTy aTV funTy)))
| (C.FunTy _ vsTy) <- C.tyView funTy
= let
vsName = C.mkUnsafeSystemName "vs" 0
vsId = C.mkLocalId vsTy vsName
in
C.TyLam tTV (
C.TyLam nTV (
C.TyLam aTV (
C.Lam vsId (
C.Var vsId))))
vecUnwrapTerm ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @
-- forall f.forall a.forall b.forall dom.Applicative f => (a -> f b) ->
-- Signal dom a -> f (Signal dom b)
-- @
--
-- Generate the term:
--
-- @
-- /\(f:* -> *)./\(a:*)./\(b:*)./\(dom:Clock).\(dict:Applicative f).
-- \(g:a -> f b).\(x:Signal dom a).g x
-- @
traverseTerm :: C.Type
-> C.Term
traverseTerm (C.ForAllTy fTV (C.ForAllTy aTV (C.ForAllTy bTV (C.ForAllTy domTV funTy))))
| (C.FunTy dictTy funTy1) <- C.tyView funTy
, (C.FunTy gTy funTy2) <- C.tyView funTy1
, (C.FunTy xTy _) <- C.tyView funTy2
= let
dictName = C.mkUnsafeSystemName "dict" 0
gName = C.mkUnsafeSystemName "g" 1
xName = C.mkUnsafeSystemName "x" 2
dictId = C.mkLocalId dictTy dictName
gId = C.mkLocalId gTy gName
xId = C.mkLocalId xTy xName
in
C.TyLam fTV (
C.TyLam aTV (
C.TyLam bTV (
C.TyLam domTV (
C.Lam dictId (
C.Lam gId (
C.Lam xId (
C.App (C.Var gId) (C.Var xId))))))))
traverseTerm ty = error $ $(curLoc) ++ show ty
-- ∀ (r :: GHC.Types.RuntimeRep)
-- (a :: GHC.Prim.TYPE GHC.Types.PtrRepLifted)
-- (b :: GHC.Prim.TYPE r).
-- (a -> b) -> a -> b
-- | Given the type:
--
-- @forall (r :: Rep) (a :: TYPE Lifted) (b :: TYPE r). (a -> b) -> a -> b@
--
-- Generate the term:
--
-- @/\(r:Rep)/\(a:TYPE Lifted)./\(b:TYPE r).\(f : (a -> b)).\(x : a).f x@
dollarTerm :: C.Type
-> C.Term
#if MIN_VERSION_ghc(9,8,0)
dollarTerm (C.ForAllTy raTV (C.ForAllTy rbTV (C.ForAllTy aTV (C.ForAllTy bTV funTy))))
| (C.FunTy fTy funTy'') <- C.tyView funTy
, (C.FunTy aTy _) <- C.tyView funTy''
= let
fName = C.mkUnsafeSystemName "f" 0
xName = C.mkUnsafeSystemName "x" 1
fId = C.mkLocalId fTy fName
xId = C.mkLocalId aTy xName
in
C.TyLam raTV (
C.TyLam rbTV (
C.TyLam aTV (
C.TyLam bTV (
C.Lam fId (
C.Lam xId (
C.App (C.Var fId) (C.Var xId)))))))
#else
dollarTerm (C.ForAllTy rTV (C.ForAllTy aTV (C.ForAllTy bTV funTy)))
| (C.FunTy fTy funTy'') <- C.tyView funTy
, (C.FunTy aTy _) <- C.tyView funTy''
= let
fName = C.mkUnsafeSystemName "f" 0
xName = C.mkUnsafeSystemName "x" 1
fId = C.mkLocalId fTy fName
xId = C.mkLocalId aTy xName
in
C.TyLam rTV (
C.TyLam aTV (
C.TyLam bTV (
C.Lam fId (
C.Lam xId (
C.App (C.Var fId) (C.Var xId))))))
#endif
dollarTerm ty = error $ $(curLoc) ++ C.showPpr ty
-- | Given the type:
--
-- @forall a. forall dom. Signal dom (Signal dom a) -> Signal dom a@
--
-- Generate the term
--
-- @/\(a:*)./\(dom:Domain).\(x:Signal dom a).x@
joinTerm :: C.Type
-> C.Term
joinTerm ty@(C.ForAllTy {}) = signalTerm ty
joinTerm ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @forall a. CallStack -> (HasCallStack => a) -> a@
--
-- Generate the term
--
-- @/\(a:*)./\(callStack:CallStack).\(f:HasCallStack => a).f callStack@
withFrozenCallStackTerm
:: C.Type
-> C.Term
withFrozenCallStackTerm (C.ForAllTy aTV funTy)
| (C.FunTy callStackTy fTy) <- C.tyView funTy
= let
callStackName = C.mkUnsafeSystemName "callStack" 0
fName = C.mkUnsafeSystemName "f" 1
callStackId = C.mkLocalId callStackTy callStackName
fId = C.mkLocalId fTy fName
in
C.TyLam aTV (
C.Lam callStackId (
C.Lam fId (
C.App (C.Var fId) (C.Var callStackId))))
withFrozenCallStackTerm ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @forall a. a -> a@
--
-- Generate the term
--
-- @/\(a:*).\(x:a).x@
idTerm
:: C.Type
-> C.Term
idTerm (C.ForAllTy aTV funTy)
| (C.FunTy xTy _) <- C.tyView funTy
= let
xName = C.mkUnsafeSystemName "x" 0
xId = C.mkLocalId xTy xName
in
C.TyLam aTV (
C.Lam xId (
C.Var xId))
idTerm ty = error $ $(curLoc) ++ show ty
-- | Given type type:
--
-- @forall (r :: RuntimeRep) (o :: TYPE r).(State# RealWorld -> o) -> o@
--
-- Generate the term:
--
-- @/\(r:RuntimeRep)./\(o:TYPE r).\(f:State# RealWord -> o) -> f realWorld#@
runRWTerm
:: C.Type
-> C.Term
runRWTerm (C.ForAllTy rTV (C.ForAllTy oTV funTy))
| (C.FunTy fTy _) <- C.tyView funTy
, (C.FunTy rwTy _) <- C.tyView fTy
= let
fName = C.mkUnsafeSystemName "f" 0
fId = C.mkLocalId fTy fName
rwNm = pack "GHC.Prim.realWorld#"
in
C.TyLam rTV (
C.TyLam oTV (
C.Lam fId (
(C.App (C.Var fId)
(C.Prim (C.PrimInfo rwNm rwTy C.WorkNever C.SingleResult C.NoUnfolding))))))
runRWTerm ty = error $ $(curLoc) ++ show ty
-- | Given type type:
--
-- @forall (n :: Nat) (a :: Type) .Knownnat n => Typeable a => (BitVector n -> a) -> BitVector n -> a@
--
-- Generate the term:
--
-- @/\(n:Nat)./\(a:TYPE r).\(kn:KnownNat n).\(f:a -> BitVector n).f@
checkUnpackUndefTerm
:: C.Type
-> C.Term
checkUnpackUndefTerm (C.ForAllTy nTV (C.ForAllTy aTV funTy))
| C.FunTy knTy r0Ty <- C.tyView funTy
, C.FunTy tpTy r1Ty <- C.tyView r0Ty
, C.FunTy fTy _ <- C.tyView r1Ty
= let
knName = C.mkUnsafeSystemName "kn" 0
tpName = C.mkUnsafeSystemName "tp" 1
fName = C.mkUnsafeSystemName "f" 2
knId = C.mkLocalId knTy knName
tpId = C.mkLocalId tpTy tpName
fId = C.mkLocalId fTy fName
in
C.TyLam nTV (
C.TyLam aTV (
C.Lam knId (
C.Lam tpId (
C.Lam fId (
C.Var fId)))))
checkUnpackUndefTerm ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @forall (name :: Symbol) (a :: Type) . a -> (name ::: a)@
--
-- Generate the term:
--
-- @/\(name:Symbol)./\(a:Type).\(x:a) -> <TICK>x@
nameModTerm
:: C.NameMod
-> C.Type
-> C.Term
nameModTerm sa (C.ForAllTy nmTV (C.ForAllTy aTV funTy))
| (C.FunTy xTy _) <- C.tyView funTy
= let
-- Safe to use `mkUnsafeSystemName` here, because we're building the
-- identity \x.x, so any shadowing of 'x' would be the desired behavior.
xName = C.mkUnsafeSystemName "x" 0
xId = C.mkLocalId xTy xName
in
C.TyLam nmTV (
C.TyLam aTV (
C.Lam xId (
(C.Tick (C.NameMod sa (C.VarTy nmTV)) (C.Var xId)))))
nameModTerm _ ty = error $ $(curLoc) ++ show ty
-- | Given the type:
--
-- @forall (a :: Type) . String -> a -> a@
--
-- Generate the term:
--
-- @/\(a:Type).\(ctx:String).\(x:a) -> x@
xToErrorCtxTerm
:: C.Type
-> C.Term
xToErrorCtxTerm (C.ForAllTy aTV funTy)
| (C.FunTy ctxTy rTy) <- C.tyView funTy
, (C.FunTy xTy _) <- C.tyView rTy
= let
-- Safe to use `mkUnsafeSystemName` here, because we're building the
-- identity \_ x.x, so any shadowing of 'x' would be the desired behavior.
ctxName = C.mkUnsafeSystemName "ctx" 0
ctxId = C.mkLocalId ctxTy ctxName
xName = C.mkUnsafeSystemName "x" 1
xId = C.mkLocalId xTy xName
in
C.TyLam aTV (
C.Lam ctxId (
C.Lam xId (
C.Var xId)))
xToErrorCtxTerm ty = error $ $(curLoc) ++ show ty
isDataConWrapId :: Id -> Bool
isDataConWrapId v = case idDetails v of
DataConWrapId {} -> True
_ -> False