{-|
  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 :: Int -> Name -> Int
hashWithSalt Int
s = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int -> Int) -> (Name -> Int) -> Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
getKey (Unique -> Int) -> (Name -> Unique) -> Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Unique
nameUnique

data GHC2CoreState
  = GHC2CoreState
  { GHC2CoreState -> UniqMap TyCon
_tyConMap :: C.UniqMap TyCon
  , GHC2CoreState -> HashMap Name Text
_nameMap  :: HashMap Name Text
  }

makeLenses ''GHC2CoreState

data GHC2CoreEnv
  = GHC2CoreEnv
  { GHC2CoreEnv -> SrcSpan
_srcSpan :: SrcSpan
  , GHC2CoreEnv -> FamInstEnvs
_famInstEnvs :: FamInstEnvs
  }

makeLenses ''GHC2CoreEnv

emptyGHC2CoreState :: GHC2CoreState
emptyGHC2CoreState :: GHC2CoreState
emptyGHC2CoreState = UniqMap TyCon -> HashMap Name Text -> GHC2CoreState
GHC2CoreState UniqMap TyCon
forall a. Monoid a => a
mempty HashMap Name Text
forall k v. HashMap k v
HashMap.empty

newtype SrcSpanRB = SrcSpanRB {SrcSpanRB -> SrcSpan
unSrcSpanRB :: SrcSpan}

instance Semigroup SrcSpanRB where
  (SrcSpanRB SrcSpan
l) <> :: SrcSpanRB -> SrcSpanRB -> SrcSpanRB
<> (SrcSpanRB SrcSpan
r) =
    if   SrcSpan -> Bool
isGoodSrcSpan SrcSpan
r
    then SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
r
    else SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
l

instance Monoid SrcSpanRB where
  mempty :: SrcSpanRB
mempty = SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
noSrcSpan

type C2C = RWS GHC2CoreEnv SrcSpanRB GHC2CoreState

makeAllTyCons
  :: GHC2CoreState
  -> FamInstEnvs
  -> C.UniqMap C.TyCon
makeAllTyCons :: GHC2CoreState -> FamInstEnvs -> UniqMap TyCon
makeAllTyCons GHC2CoreState
hm FamInstEnvs
fiEnvs = GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go GHC2CoreState
hm GHC2CoreState
hm
  where
    go :: GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go GHC2CoreState
old GHC2CoreState
new
        | UniqMap TyCon -> Bool
forall a. UniqMap a -> Bool
C.null (GHC2CoreState
new GHC2CoreState
-> Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
-> UniqMap TyCon
forall s a. s -> Getting a s a -> a
^. Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap) = UniqMap TyCon
forall a. Monoid a => a
mempty
        | Bool
otherwise                = UniqMap TyCon
tcm UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
forall a. Semigroup a => a -> a -> a
<> UniqMap TyCon
tcm'
      where
        (UniqMap TyCon
tcm,GHC2CoreState
old', SrcSpanRB
_) = RWS GHC2CoreEnv SrcSpanRB GHC2CoreState (UniqMap TyCon)
-> GHC2CoreEnv
-> GHC2CoreState
-> (UniqMap TyCon, GHC2CoreState, SrcSpanRB)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
RWS.runRWS ((TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon)
-> UniqMap TyCon
-> RWS GHC2CoreEnv SrcSpanRB GHC2CoreState (UniqMap TyCon)
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
makeTyCon (GHC2CoreState
new GHC2CoreState
-> Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
-> UniqMap TyCon
forall s a. s -> Getting a s a -> a
^. Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap))
                                   (SrcSpan -> FamInstEnvs -> GHC2CoreEnv
GHC2CoreEnv SrcSpan
noSrcSpan FamInstEnvs
fiEnvs)
                                   GHC2CoreState
old
        tcm' :: UniqMap TyCon
tcm'          = GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go GHC2CoreState
old' (GHC2CoreState
old' 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 b. UniqMap b -> UniqMap b -> UniqMap b
`C.difference` (GHC2CoreState
old GHC2CoreState
-> Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
-> UniqMap TyCon
forall s a. s -> Getting a s a -> a
^. Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap)))

makeTyCon :: TyCon
          -> C2C C.TyCon
makeTyCon :: TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
makeTyCon TyCon
tc = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
tycon
  where
    tycon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
tycon
      | TyCon -> Bool
isFamilyTyCon TyCon
tc    = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkFunTyCon
      | TyCon -> Bool
isTupleTyCon TyCon
tc     = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkTupleTyCon
      | TyCon -> Bool
isAlgTyCon TyCon
tc       = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkAlgTyCon
      | TyCon -> Bool
isPrimTyCon TyCon
tc      = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkPrimTyCon
      | Just DataCon
dc <- TyCon -> Maybe DataCon
isPromotedDataCon_maybe TyCon
tc = DataCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkPromotedDataCon DataCon
dc
      | Bool
otherwise           = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkVoidTyCon
      where
        tcArity :: Int
tcArity = TyCon -> Int
tyConArity TyCon
tc

        mkAlgTyCon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkAlgTyCon = do
          Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
          Type
tcKind <- Type -> C2C Type
coreToType (TyCon -> Type
tyConKind TyCon
tc)
          Maybe AlgTyConRhs
tcRhsM <- AlgTyConRhs -> C2C (Maybe AlgTyConRhs)
makeAlgTyConRhs (AlgTyConRhs -> C2C (Maybe AlgTyConRhs))
-> AlgTyConRhs -> C2C (Maybe AlgTyConRhs)
forall a b. (a -> b) -> a -> b
$ TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc
          case Maybe AlgTyConRhs
tcRhsM of
            Just AlgTyConRhs
tcRhs ->
              TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return
                AlgTyCon :: Int -> Name TyCon -> Type -> Int -> AlgTyConRhs -> Bool -> TyCon
C.AlgTyCon
                { tyConUniq :: Int
C.tyConUniq   = Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName
                , tyConName :: Name TyCon
C.tyConName   = Name TyCon
tcName
                , tyConKind :: Type
C.tyConKind   = Type
tcKind
                , tyConArity :: Int
C.tyConArity  = Int
tcArity
                , algTcRhs :: AlgTyConRhs
C.algTcRhs    = AlgTyConRhs
tcRhs
                , isClassTc :: Bool
C.isClassTc   = TyCon -> Bool
isClassTyCon TyCon
tc
                }
            Maybe AlgTyConRhs
Nothing -> TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Int -> Name TyCon -> Type -> Int -> TyCon
C.PrimTyCon (Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName) Name TyCon
tcName Type
tcKind Int
tcArity)

        mkFunTyCon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkFunTyCon = do
          Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
          Type
tcKind <- Type -> C2C Type
coreToType (TyCon -> Type
tyConKind TyCon
tc)
          [([Type], Type)]
substs <- case TyCon -> Maybe (CoAxiom Branched)
isClosedSynFamilyTyConWithAxiom_maybe TyCon
tc of
            Maybe (CoAxiom Branched)
Nothing -> do
                       [FamInst]
instances <- FamInstEnvs -> TyCon -> [FamInst]
familyInstances (FamInstEnvs -> TyCon -> [FamInst])
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity FamInstEnvs
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (TyCon -> [FamInst])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting FamInstEnvs GHC2CoreEnv FamInstEnvs
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity FamInstEnvs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting FamInstEnvs GHC2CoreEnv FamInstEnvs
Lens' GHC2CoreEnv FamInstEnvs
famInstEnvs RWST
  GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (TyCon -> [FamInst])
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [FamInst]
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TyCon
tc
                       (FamInst
 -> RWST
      GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type], Type))
-> [FamInst]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [([Type], Type)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FamInst
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type], Type)
famInstToSubst [FamInst]
instances
            Just CoAxiom Branched
cx -> let bx :: [CoAxBranch]
bx = Branches Branched -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches (CoAxiom Branched -> Branches Branched
forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches CoAxiom Branched
cx)
                       in  (CoAxBranch
 -> RWST
      GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type], Type))
-> [CoAxBranch]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [([Type], Type)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\CoAxBranch
b -> (,) ([Type] -> Type -> ([Type], Type))
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
-> RWST
     GHC2CoreEnv
     SrcSpanRB
     GHC2CoreState
     Identity
     (Type -> ([Type], Type))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType (CoAxBranch -> [Type]
cab_lhs CoAxBranch
b)
                                           RWST
  GHC2CoreEnv
  SrcSpanRB
  GHC2CoreState
  Identity
  (Type -> ([Type], Type))
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type], Type)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType (CoAxBranch -> Type
cab_rhs CoAxBranch
b))
                                [CoAxBranch]
bx
          TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return
            FunTyCon :: Int -> Name TyCon -> Type -> Int -> [([Type], Type)] -> TyCon
C.FunTyCon
            { tyConUniq :: Int
C.tyConUniq  = Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName
            , tyConName :: Name TyCon
C.tyConName  = Name TyCon
tcName
            , tyConKind :: Type
C.tyConKind  = Type
tcKind
            , tyConArity :: Int
C.tyConArity = Int
tcArity
            , tyConSubst :: [([Type], Type)]
C.tyConSubst = [([Type], Type)]
substs
            }

        mkTupleTyCon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkTupleTyCon = do
          Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
          Type
tcKind <- Type -> C2C Type
coreToType (TyCon -> Type
tyConKind TyCon
tc)
          case TyCon -> [DataCon]
tyConDataCons TyCon
tc of
            DataCon
dc:[DataCon]
_ -> do
              AlgTyConRhs
tcDc   <- (DataCon -> AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([DataCon] -> AlgTyConRhs
C.DataTyCon ([DataCon] -> AlgTyConRhs)
-> (DataCon -> [DataCon]) -> DataCon -> AlgTyConRhs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataCon -> [DataCon] -> [DataCon]
forall a. a -> [a] -> [a]
:[])) (DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc)
              TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return
                AlgTyCon :: Int -> Name TyCon -> Type -> Int -> AlgTyConRhs -> Bool -> TyCon
C.AlgTyCon
                { tyConUniq :: Int
C.tyConUniq   = Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName
                , tyConName :: Name TyCon
C.tyConName   = Name TyCon
tcName
                , tyConKind :: Type
C.tyConKind   = Type
tcKind
                , tyConArity :: Int
C.tyConArity  = Int
tcArity
                , algTcRhs :: AlgTyConRhs
C.algTcRhs    = AlgTyConRhs
tcDc
                , isClassTc :: Bool
C.isClassTc   = TyCon -> Bool
isClassTyCon TyCon
tc
                }
            [DataCon]
_ -> [Char] -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

        mkPrimTyCon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkPrimTyCon = do
          Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
          Type
tcKind <- Type -> C2C Type
coreToType (TyCon -> Type
tyConKind TyCon
tc)
          TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return
            PrimTyCon :: Int -> Name TyCon -> Type -> Int -> TyCon
C.PrimTyCon
            { tyConUniq :: Int
C.tyConUniq    = Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName
            , tyConName :: Name TyCon
C.tyConName    = Name TyCon
tcName
            , tyConKind :: Type
C.tyConKind    = Type
tcKind
            , tyConArity :: Int
C.tyConArity   = Int
tcArity
            }

        mkPromotedDataCon :: DataCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkPromotedDataCon DataCon
dc = do
          Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
          Type
tcKind <- Type -> C2C Type
coreToType (TyCon -> Type
tyConKind TyCon
tc)
          DataCon
tcData <- DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc

          TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return
            PromotedDataCon :: Int -> Name TyCon -> Type -> Int -> DataCon -> TyCon
C.PromotedDataCon
            { tyConUniq :: Int
C.tyConUniq   = Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName
            , tyConName :: Name TyCon
C.tyConName   = Name TyCon
tcName
            , tyConKind :: Type
C.tyConKind   = Type
tcKind
            , tyConArity :: Int
C.tyConArity  = Int
tcArity
            , tyConData :: DataCon
C.tyConData   = DataCon
tcData
            }

        mkVoidTyCon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkVoidTyCon = do
          Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
          Type
tcKind <- Type -> C2C Type
coreToType (TyCon -> Type
tyConKind TyCon
tc)
          TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Int -> Name TyCon -> Type -> Int -> TyCon
C.PrimTyCon (Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName) Name TyCon
tcName Type
tcKind Int
tcArity)

        famInstToSubst :: FamInst -> C2C ([C.Type],C.Type)
        famInstToSubst :: FamInst
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type], Type)
famInstToSubst FamInst
fi = do
          [Type]
tys <- (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType  (FamInst -> [Type]
fi_tys FamInst
fi)
          Type
ty  <- Type -> C2C Type
coreToType (FamInst -> Type
fi_rhs FamInst
fi)
          ([Type], Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type], Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Type]
tys,Type
ty)

makeAlgTyConRhs :: AlgTyConRhs
                -> C2C (Maybe C.AlgTyConRhs)
makeAlgTyConRhs :: AlgTyConRhs -> C2C (Maybe AlgTyConRhs)
makeAlgTyConRhs AlgTyConRhs
algTcRhs = case AlgTyConRhs
algTcRhs of
  DataTyCon {data_cons :: AlgTyConRhs -> [DataCon]
data_cons = [DataCon]
dcs} -> AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> ([DataCon] -> AlgTyConRhs) -> [DataCon] -> Maybe AlgTyConRhs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataCon] -> AlgTyConRhs
C.DataTyCon ([DataCon] -> Maybe AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
-> C2C (Maybe AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon)
-> [DataCon]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon [DataCon]
dcs
  SumTyCon [DataCon]
dcs Int
_ -> AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> ([DataCon] -> AlgTyConRhs) -> [DataCon] -> Maybe AlgTyConRhs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataCon] -> AlgTyConRhs
C.DataTyCon ([DataCon] -> Maybe AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
-> C2C (Maybe AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon)
-> [DataCon]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon [DataCon]
dcs

#if MIN_VERSION_ghc(8,10,0)
  NewTyCon DataCon
dc Type
_ ([TyVar]
rhsTvs,Type
rhsEtad) CoAxiom Unbranched
_ Bool
_ ->
#else
  NewTyCon dc _ (rhsTvs,rhsEtad) _ ->
#endif
                                      AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs
-> C2C (Maybe AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon -> ([TyVar], Type) -> AlgTyConRhs
C.NewTyCon (DataCon -> ([TyVar], Type) -> AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
-> RWST
     GHC2CoreEnv
     SrcSpanRB
     GHC2CoreState
     Identity
     (([TyVar], Type) -> AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc
                                                           RWST
  GHC2CoreEnv
  SrcSpanRB
  GHC2CoreState
  Identity
  (([TyVar], Type) -> AlgTyConRhs)
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([TyVar], Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ((,) ([TyVar] -> Type -> ([TyVar], Type))
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
-> RWST
     GHC2CoreEnv
     SrcSpanRB
     GHC2CoreState
     Identity
     (Type -> ([TyVar], Type))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar [TyVar]
rhsTvs
                                                                    RWST
  GHC2CoreEnv
  SrcSpanRB
  GHC2CoreState
  Identity
  (Type -> ([TyVar], Type))
-> C2C Type
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([TyVar], Type)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
rhsEtad
                                                               )
                                               )
  AbstractTyCon {} -> Maybe AlgTyConRhs -> C2C (Maybe AlgTyConRhs)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe AlgTyConRhs
forall a. Maybe a
Nothing
  TupleTyCon {}    -> [Char] -> C2C (Maybe AlgTyConRhs)
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot handle tuple tycons"

coreToTerm
  :: CompiledPrimMap
  -> [Var]
  -> CoreExpr
  -> C2C C.Term
coreToTerm :: CompiledPrimMap -> [TyVar] -> CoreExpr -> C2C Term
coreToTerm CompiledPrimMap
primMap [TyVar]
unlocs = CoreExpr -> C2C Term
term
  where
    term :: CoreExpr -> C2C C.Term
    term :: CoreExpr -> C2C Term
term CoreExpr
e
      | (Var TyVar
x,[CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e
      , let (Text
nm, SrcSpanRB
_) = C2C Text -> GHC2CoreEnv -> GHC2CoreState -> (Text, SrcSpanRB)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
RWS.evalRWS (Name -> C2C Text
qualifiedNameString (TyVar -> Name
varName TyVar
x))
                                  (SrcSpan -> FamInstEnvs -> GHC2CoreEnv
GHC2CoreEnv SrcSpan
noSrcSpan FamInstEnvs
emptyFamInstEnvs)
                                  GHC2CoreState
emptyGHC2CoreState
      = Text -> [CoreExpr] -> C2C Term
go Text
nm [CoreExpr]
args
      | Bool
otherwise
      = CoreExpr -> C2C Term
term' CoreExpr
e
      where
        -- Remove most Signal transformers
        go :: Text -> [CoreExpr] -> C2C Term
go Text
"Clash.Signal.Internal.mapSignal#"  [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
          = CoreExpr -> C2C Term
term (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
3) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
4))
        go Text
"Clash.Signal.Internal.signal#"     [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
          = CoreExpr -> C2C Term
term ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
2)
        go Text
"Clash.Signal.Internal.appSignal#"  [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
          = CoreExpr -> C2C Term
term (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
3) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
4))
        go Text
"Clash.Signal.Internal.joinSignal#" [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
          = CoreExpr -> C2C Term
term ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
2)
        go Text
"Clash.Signal.Bundle.vecBundle#"    [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
          = CoreExpr -> C2C Term
term ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
3)
        --- Remove `$`
        go Text
"GHC.Base.$"                        [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
          = CoreExpr -> C2C Term
term (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
3) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
4))
        go Text
"GHC.Magic.noinline"                [CoreExpr]
args   -- noinline :: forall a. a -> a
          | [CoreExpr
_ty, CoreExpr
x] <- [CoreExpr]
args
          = CoreExpr -> C2C Term
term CoreExpr
x
        -- Remove most CallStack logic
        go Text
"GHC.Stack.Types.PushCallStack"     [CoreExpr]
args = CoreExpr -> C2C Term
term ([CoreExpr] -> CoreExpr
forall a. [a] -> a
last [CoreExpr]
args)
        go Text
"GHC.Stack.Types.FreezeCallStack"   [CoreExpr]
args = CoreExpr -> C2C Term
term ([CoreExpr] -> CoreExpr
forall a. [a] -> a
last [CoreExpr]
args)
        go Text
"GHC.Stack.withFrozenCallStack"     [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
          = CoreExpr -> C2C Term
term (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
2) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!Int
1))
        go Text
"Clash.Sized.BitVector.Internal.checkUnpackUndef" [CoreExpr]
args
          | [CoreExpr
_nTy,CoreExpr
_aTy,CoreExpr
_kn,CoreExpr
_typ,CoreExpr
f] <- [CoreExpr]
args
          = CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.prefixName" [CoreExpr]
args
          | [Type Type
nmTy,CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick (TickInfo -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameMod -> Type -> TickInfo
C.NameMod NameMod
C.PrefixName (Type -> TickInfo)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
nmTy) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.suffixName" [CoreExpr]
args
          | [Type Type
nmTy,CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick (TickInfo -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameMod -> Type -> TickInfo
C.NameMod NameMod
C.SuffixName (Type -> TickInfo)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
nmTy) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.suffixNameFromNat" [CoreExpr]
args
          | [Type Type
nmTy,CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick (TickInfo -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameMod -> Type -> TickInfo
C.NameMod NameMod
C.SuffixName (Type -> TickInfo)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
nmTy) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.suffixNameP" [CoreExpr]
args
          | [Type Type
nmTy,CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick (TickInfo -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameMod -> Type -> TickInfo
C.NameMod NameMod
C.SuffixNameP (Type -> TickInfo)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
nmTy) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.suffixNameFromNatP" [CoreExpr]
args
          | [Type Type
nmTy,CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick (TickInfo -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameMod -> Type -> TickInfo
C.NameMod NameMod
C.SuffixNameP (Type -> TickInfo)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
nmTy) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.setName" [CoreExpr]
args
          | [Type Type
nmTy,CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick (TickInfo -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameMod -> Type -> TickInfo
C.NameMod NameMod
C.SetName (Type -> TickInfo)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TickInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
nmTy) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.deDup" [CoreExpr]
args
          | [CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick TickInfo
C.DeDup (Term -> Term) -> C2C Term -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.noDeDup" [CoreExpr]
args
          | [CoreExpr
_aTy,CoreExpr
f] <- [CoreExpr]
args
          = TickInfo -> Term -> Term
C.Tick TickInfo
C.NoDeDup (Term -> Term) -> C2C Term -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
f
        go Text
"Clash.Magic.clashSimulation" [CoreExpr]
_
          = DataCon -> Term
C.Data (DataCon -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
-> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
falseDataCon
        go Text
"Clash.XException.xToErrorCtx" [CoreExpr]
args
          -- xToErrorCtx :: forall a. String -> a -> a
          | [CoreExpr
_ty, CoreExpr
_msg, CoreExpr
x] <- [CoreExpr]
args
          = CoreExpr -> C2C Term
term CoreExpr
x
        go Text
nm [CoreExpr]
args
          | Just Int
n <- Text -> Text -> Maybe Int
parseBundle Text
"bundle" Text
nm
            -- length args = domain tyvar + signal arg + number of type vars
          , [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
          = CoreExpr -> C2C Term
term ([CoreExpr] -> CoreExpr
forall a. [a] -> a
last [CoreExpr]
args)
        go Text
nm [CoreExpr]
args
          | Just Int
n <- Text -> Text -> Maybe Int
parseBundle Text
"unbundle" Text
nm
            -- length args = domain tyvar + signal arg + number of type vars
          , [CoreExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
          = CoreExpr -> C2C Term
term ([CoreExpr] -> CoreExpr
forall a. [a] -> a
last [CoreExpr]
args)
        go Text
_ [CoreExpr]
_ = CoreExpr -> C2C Term
term' CoreExpr
e

    parseBundle :: Text -> Text -> Maybe Int
    parseBundle :: Text -> Text -> Maybe Int
parseBundle Text
fNm Text
nm0 = do
      Text
nm1 <- Text -> Text -> Maybe Text
Text.stripPrefix (Text
"Clash.Signal.Bundle." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fNm) Text
nm0
      Text
nm2 <- Text -> Text -> Maybe Text
Text.stripSuffix Text
"#" Text
nm1
      [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
Text.readMaybe (Text -> [Char]
Text.unpack Text
nm2)

    term' :: CoreExpr -> C2C Term
term' (Var TyVar
x)                 = TyVar -> C2C Term
var TyVar
x
#if MIN_VERSION_ghc(8,8,0)
    term' (Lit l :: Literal
l@LitRubbish{}) = do
      Type
ty <- Type -> C2C Type
coreToType (Literal -> Type
literalType Literal
l)
      Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo ([Char] -> Text
pack [Char]
"_RUBBISH_")
                                 Type
ty
                                 WorkInfo
C.WorkNever
                                 IsMultiPrim
C.SingleResult
                                 PrimUnfolding
C.NoUnfolding))
#endif
    term' (Lit Literal
l)                 = Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ Literal -> Term
C.Literal (Literal -> Literal
coreToLiteral Literal
l)
    term' (App CoreExpr
eFun (Type Type
tyArg)) = Term -> Type -> Term
C.TyApp (Term -> Type -> Term)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
eFun RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Term)
-> C2C Type -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
tyArg
    term' (App CoreExpr
eFun CoreExpr
eArg)         = Term -> Term -> Term
C.App   (Term -> Term -> Term)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
eFun RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
eArg
    term' (Lam TyVar
x CoreExpr
e)
      | TyVar -> Bool
isTyVar TyVar
x
      = TyVar -> Term -> Term
C.TyLam (TyVar -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
x RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SrcSpan -> C2C Term -> C2C Term
forall a. SrcSpan -> C2C a -> C2C a
addUsefull (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) (CoreExpr -> C2C Term
term CoreExpr
e)
      | Bool
otherwise
      = do
        (Term
e',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
e
        Id
x' <- SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
x
        Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id -> Term -> Term
C.Lam  Id
x' Term
e')
    term' (Let (NonRec TyVar
x CoreExpr
e1) CoreExpr
e2)  = do
      (Term
e1',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
e1
      Id
x'  <- SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
x
      Term
e2' <- CoreExpr -> C2C Term
term CoreExpr
e2
      Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bind Term -> Term -> Term
C.Let (Id -> Term -> Bind Term
forall a. Id -> a -> Bind a
C.NonRec Id
x' Term
e1') Term
e2')

    term' (Let (Rec [(TyVar, CoreExpr)]
xes) CoreExpr
e) = do
      [(Id, Term)]
xes' <- ((TyVar, CoreExpr)
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Id, Term))
-> [(TyVar, CoreExpr)]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Term)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TyVar, CoreExpr)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Id, Term)
go [(TyVar, CoreExpr)]
xes
      Term
e'   <- CoreExpr -> C2C Term
term CoreExpr
e
      Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bind Term -> Term -> Term
C.Let ([(Id, Term)] -> Bind Term
forall a. [(Id, a)] -> Bind a
C.Rec [(Id, Term)]
xes') Term
e')
     where
      go :: (TyVar, CoreExpr)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Id, Term)
go (TyVar
x,CoreExpr
b) = do
        (Term
b',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
b
        Id
x' <- SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
x
        (Id, Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Id, Term)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id
x',Term
b')

    term' (Case CoreExpr
s TyVar
_ Type
ty [])  = do
      Term
s'  <- CoreExpr -> C2C Term
term' CoreExpr
s
      Type
ty' <- Type -> C2C Type
coreToType Type
ty
      case Term -> (Term, [Either Term Type])
C.collectArgs Term
s' of
        (C.Prim PrimInfo
p, [Either Term Type]
_) | PrimInfo -> Text
C.primName PrimInfo
p Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Text]
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
          Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Type -> Term
C.TyApp (PrimInfo -> Term
C.Prim PrimInfo
C.undefinedX) Type
ty')
        (Term, [Either Term Type])
_ ->
          Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Type -> Term
C.TyApp (PrimInfo -> Term
C.Prim PrimInfo
C.undefined) Type
ty')

    term' (Case CoreExpr
e TyVar
b Type
ty [Alt TyVar]
alts) = do
     let usesBndr :: Bool
usesBndr = (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any ( Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarSet -> Bool
isEmptyVarSet (VarSet -> Bool) -> (CoreExpr -> VarSet) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVar -> Bool) -> CoreExpr -> VarSet
exprSomeFreeVars (TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
b))
                  ([CoreExpr] -> Bool) -> [CoreExpr] -> Bool
forall a b. (a -> b) -> a -> b
$ [Alt TyVar] -> [CoreExpr]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt TyVar]
alts
     (Term
e',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
b) CoreExpr
e
     Id
b'  <- SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
b
     Type
ty' <- Type -> C2C Type
coreToType Type
ty
     let caseTerm :: Term -> C2C Term
caseTerm Term
v =
             Term -> Type -> [Alt] -> Term
C.Case Term
v Type
ty' ([Alt] -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Alt]
-> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt TyVar
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt)
-> [Alt TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Alt]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall a. SrcSpan -> C2C a -> C2C a
addUsefull SrcSpan
sp (RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt)
-> (Alt TyVar
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt)
-> Alt TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> Alt TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
alt SrcSpan
sp) [Alt TyVar]
alts
     if Bool
usesBndr
      then do
        Term
ct <- Term -> C2C Term
caseTerm (Id -> Term
C.Var Id
b')
        Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bind Term -> Term -> Term
C.Let (Id -> Term -> Bind Term
forall a. Id -> a -> Bind a
C.NonRec Id
b' Term
e') Term
ct)
      else Term -> C2C Term
caseTerm Term
e'

    term' (Cast CoreExpr
e Coercion
co) = do
      let (Pair Type
ty1 Type
ty2) = Coercion -> Pair Type
coercionKind Coercion
co
      Maybe Type
hasPrimCoM <- Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
      Bool
sizedCast <- Type -> Type -> C2C Bool
isSizedCast Type
ty1 Type
ty2
      case Maybe Type
hasPrimCoM of
        Just Type
_ | Bool
sizedCast
          -> Term -> Type -> Type -> Term
C.Cast (Term -> Type -> Type -> Term)
-> C2C Term
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
e RWST
  GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type -> Term)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Term)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
ty1 RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Term)
-> C2C Type -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
ty2
        Maybe Type
_ -> CoreExpr -> C2C Term
term CoreExpr
e
    term' (Tick (SourceNote RealSrcSpan
rsp [Char]
_) CoreExpr
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
      TickInfo -> Term -> Term
C.Tick (SrcSpan -> TickInfo
C.SrcSpan (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
rsp)) (Term -> Term) -> C2C Term -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> C2C Term -> C2C Term
forall a. SrcSpan -> C2C a -> C2C a
addUsefull (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
rsp) (CoreExpr -> C2C Term
term CoreExpr
e)
#endif
    term' (Tick Tickish TyVar
_ CoreExpr
e) = CoreExpr -> C2C Term
term CoreExpr
e
    term' (Type Type
t) =
      Term -> Type -> Term
C.TyApp (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo ([Char] -> Text
pack [Char]
"_TY_") Type
C.undefinedTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding))
        (Type -> Term) -> C2C Type -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
t
    term' (Coercion Coercion
co) =
      Term -> Type -> Term
C.TyApp (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo ([Char] -> Text
pack [Char]
"_CO_") Type
C.undefinedTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding))
        (Type -> Term) -> C2C Type -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType (Coercion -> Type
coercionType Coercion
co)


    termSP :: SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP SrcSpan
sp = ((Term, SrcSpanRB) -> (Term, SrcSpan))
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SrcSpanRB -> SrcSpan) -> (Term, SrcSpanRB) -> (Term, SrcSpan)
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SrcSpanRB -> SrcSpan
unSrcSpanRB) (RWST
   GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
 -> RWST
      GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan))
-> (CoreExpr
    -> RWST
         GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB))
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C2C Term
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
RWS.listen (C2C Term
 -> RWST
      GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB))
-> (CoreExpr -> C2C Term)
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> C2C Term -> C2C Term
forall a. SrcSpan -> C2C a -> C2C a
addUsefullR SrcSpan
sp (C2C Term -> C2C Term)
-> (CoreExpr -> C2C Term) -> CoreExpr -> C2C Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> C2C Term
term
    coreToIdSP :: SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp = (GHC2CoreEnv -> GHC2CoreEnv)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
RWS.local (\r :: GHC2CoreEnv
r@(GHC2CoreEnv SrcSpan
_ FamInstEnvs
e) ->
                                  if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
sp then
                                    SrcSpan -> FamInstEnvs -> GHC2CoreEnv
GHC2CoreEnv SrcSpan
sp FamInstEnvs
e
                                  else
                                    GHC2CoreEnv
r)
                  (RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id)
-> (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id)
-> TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToId


    lookupPrim :: Text -> Maybe (Maybe CompiledPrimitive)
    lookupPrim :: Text -> Maybe (Maybe CompiledPrimitive)
lookupPrim Text
nm = PrimitiveGuard CompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim (PrimitiveGuard CompiledPrimitive -> Maybe CompiledPrimitive)
-> Maybe (PrimitiveGuard CompiledPrimitive)
-> Maybe (Maybe CompiledPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> CompiledPrimMap -> Maybe (PrimitiveGuard CompiledPrimitive)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nm CompiledPrimMap
primMap

    var :: TyVar -> C2C Term
var TyVar
x = do
        Name Term
xPrim <- if TyVar -> Bool
isGlobalId TyVar
x then TyVar -> C2C (Name Term)
coreToPrimVar TyVar
x else TyVar -> C2C (Name Term)
forall a. TyVar -> C2C (Name a)
coreToVar TyVar
x
        let xNameS :: Text
xNameS = Name Term -> Text
forall a. Name a -> Text
C.nameOcc Name Term
xPrim
        Type
xType  <- Type -> C2C Type
coreToType (TyVar -> Type
varType TyVar
x)
        case TyVar -> Maybe DataCon
isDataConId_maybe TyVar
x of
          Just DataCon
dc -> case Text -> Maybe (Maybe CompiledPrimitive)
lookupPrim Text
xNameS of
            Just Maybe CompiledPrimitive
p  ->
              -- Primitive will be marked MultiResult in Transformations if it
              -- is a multi result primitive.
              Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType (WorkInfo
-> (CompiledPrimitive -> WorkInfo)
-> Maybe CompiledPrimitive
-> WorkInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WorkInfo
C.WorkVariable CompiledPrimitive -> WorkInfo
forall a b c d. Primitive a b c d -> WorkInfo
workInfo Maybe CompiledPrimitive
p) IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding)
            Maybe (Maybe CompiledPrimitive)
Nothing -> if TyVar -> Bool
isDataConWrapId TyVar
x Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc))
              then let xInfo :: IdInfo
xInfo = HasDebugCallStack => TyVar -> IdInfo
TyVar -> IdInfo
idInfo TyVar
x
                       unfolding :: Unfolding
unfolding = IdInfo -> Unfolding
unfoldingInfo IdInfo
xInfo
                   in  case Unfolding
unfolding of
                          CoreUnfolding {} -> do
                            SrcSpan
sp <- Getting SrcSpan GHC2CoreEnv SrcSpan
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity SrcSpan
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting SrcSpan GHC2CoreEnv SrcSpan
Lens' GHC2CoreEnv SrcSpan
srcSpan
                            (SrcSpanRB -> SrcSpanRB) -> C2C Term -> C2C Term
forall w (m :: Type -> Type) a.
MonadWriter w m =>
(w -> w) -> m a -> m a
RWS.censor (SrcSpanRB -> SrcSpanRB -> SrcSpanRB
forall a b. a -> b -> a
const (SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
sp)) (CoreExpr -> C2C Term
term (Unfolding -> CoreExpr
unfoldingTemplate Unfolding
unfolding))
                          Unfolding
NoUnfolding -> [Char] -> C2C Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"No unfolding for DC wrapper: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TyVar -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe TyVar
x)
                          Unfolding
_ -> [Char] -> C2C Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"Unexpected unfolding for DC wrapper: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TyVar -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe TyVar
x)
              else DataCon -> Term
C.Data (DataCon -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
-> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc
          Maybe DataCon
Nothing -> case Text -> Maybe (Maybe CompiledPrimitive)
lookupPrim Text
xNameS of
            Just (Just (Primitive Text
f WorkInfo
wi Text
_))
              | Just Int
n <- Text -> Text -> Maybe Int
parseBundle Text
"bundle" Text
f        -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Int -> Type -> Term
bundleUnbundleTerm (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
xType)
              | Just Int
n <- Text -> Text -> Maybe Int
parseBundle Text
"unbundle" Text
f      -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Int -> Type -> Term
bundleUnbundleTerm (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Signal.Internal.mapSignal#" -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
mapSignalTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Signal.Internal.signal#"    -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
signalTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Signal.Internal.appSignal#" -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
appSignalTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Signal.Internal.traverse#"  -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
traverseTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Signal.Internal.joinSignal#" -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
joinTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Signal.Bundle.vecBundle#"   -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
vecUnwrapTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Base.$"                       -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
dollarTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Stack.withFrozenCallStack"    -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
withFrozenCallStackTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Magic.noinline"               -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
idTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Magic.lazy"                   -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
idTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Magic.runRW#"                 -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
runRWTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.BitVector.checkUnpackUndef" -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
checkUnpackUndefTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Magic.prefixName"
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (NameMod -> Type -> Term
nameModTerm NameMod
C.PrefixName Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Magic.postfixName"
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (NameMod -> Type -> Term
nameModTerm NameMod
C.SuffixName Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Magic.setName"
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (NameMod -> Type -> Term
nameModTerm NameMod
C.SetName Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.XException.xToErrorCtx"
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
xToErrorCtxTerm Type
xType)
              | TyVar
x TyVar -> [TyVar] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [TyVar]
unlocs
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding))
              | Bool
otherwise
              -> do Id
bndr <- TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToId TyVar
x
                    Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult (Id -> PrimUnfolding
C.Unfolding Id
bndr)))
            Just (Just (BlackBox {workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
workInfo = WorkInfo
wi}))
              | TyVar
x TyVar -> [TyVar] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [TyVar]
unlocs
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding)
              | Bool
otherwise
              -> do Id
bndr <- TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToId TyVar
x
                    Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult (Id -> PrimUnfolding
C.Unfolding Id
bndr)))
            Just (Just (BlackBoxHaskell {workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
workInfo = WorkInfo
wi}))
              | TyVar
x TyVar -> [TyVar] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [TyVar]
unlocs
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding)
              | Bool
otherwise
              -> do Id
bndr <- TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToId TyVar
x
                    Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult (Id -> PrimUnfolding
C.Unfolding Id
bndr))
            Just Maybe CompiledPrimitive
Nothing ->
              -- Was guarded by "DontTranslate". We don't know yet if Clash will
              -- actually use it later on, so we don't err here.
              Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
C.WorkVariable IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding)
            Maybe (Maybe CompiledPrimitive)
Nothing
              | TyVar
x TyVar -> [TyVar] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [TyVar]
unlocs
              -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
C.WorkVariable IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding))
              | Bool
otherwise
              -> Id -> Term
C.Var (Id -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToId TyVar
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 :: SrcSpan
-> Alt TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
alt SrcSpan
_   (AltCon
DEFAULT   , [TyVar]
_ , CoreExpr
e) = (Pat
C.DefaultPat,) (Term -> Alt)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
e
    alt SrcSpan
_   (LitAlt Literal
l  , [TyVar]
_ , CoreExpr
e) = (Literal -> Pat
C.LitPat (Literal -> Literal
coreToLiteral Literal
l),) (Term -> Alt)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
e
    alt SrcSpan
sp0 (DataAlt DataCon
dc, [TyVar]
xs, CoreExpr
e) = case (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span TyVar -> Bool
isTyVar [TyVar]
xs of
#endif
      ([TyVar]
tyvs,[TyVar]
tmvs) -> do
        (Term
e',SrcSpan
sp1) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP SrcSpan
sp0 CoreExpr
e
        (,) (Pat -> Term -> Alt)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Pat
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Alt)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon -> [TyVar] -> [Id] -> Pat
C.DataPat (DataCon -> [TyVar] -> [Id] -> Pat)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
-> RWST
     GHC2CoreEnv
     SrcSpanRB
     GHC2CoreState
     Identity
     ([TyVar] -> [Id] -> Pat)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc
                           RWST
  GHC2CoreEnv
  SrcSpanRB
  GHC2CoreState
  Identity
  ([TyVar] -> [Id] -> Pat)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Id] -> Pat)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar [TyVar]
tyvs
                           RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Id] -> Pat)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Id]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Pat
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id)
-> [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Id]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp1) [TyVar]
tmvs)
            RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Alt)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Term -> C2C Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Term
e'

    coreToLiteral :: Literal
                  -> C.Literal
    coreToLiteral :: Literal -> Literal
coreToLiteral Literal
l = case Literal
l of
#if MIN_VERSION_ghc(8,8,0)
      LitString  ByteString
fs  -> [Char] -> Literal
C.StringLiteral (ByteString -> [Char]
Char8.unpack ByteString
fs)
      LitChar    Char
c   -> Char -> Literal
C.CharLiteral Char
c
      LitRubbish{}   ->
        [Char] -> Literal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Literal) -> [Char] -> Literal
forall a b. (a -> b) -> a -> b
$ [Char]
"coreToTerm: Encountered LibRubbish. This is a bug in Clash. "
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"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 LitNumType
lt Integer
i Type
_ -> case LitNumType
lt of
#endif
#if MIN_VERSION_ghc(9,4,0)
        LitNumBigNat  -> C.ByteArrayLiteral (ByteArray (integerToBigNatClamp# i))
#else
        LitNumType
LitNumInteger -> Integer -> Literal
C.IntegerLiteral Integer
i
        LitNumType
LitNumNatural -> Integer -> Literal
C.NaturalLiteral Integer
i
#endif
        LitNumType
LitNumInt     -> Integer -> Literal
C.IntLiteral Integer
i
        LitNumType
LitNumInt64   -> Integer -> Literal
C.IntLiteral Integer
i
        LitNumType
LitNumWord    -> Integer -> Literal
C.WordLiteral Integer
i
        LitNumType
LitNumWord64  -> Integer -> Literal
C.WordLiteral Integer
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 Rational
r    -> Word32 -> Literal
C.FloatLiteral (Word32 -> Literal) -> (Float -> Word32) -> Float -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
floatToWord (Float -> Literal) -> Float -> Literal
forall a b. (a -> b) -> a -> b
$ Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r
      LitDouble Rational
r   -> Word64 -> Literal
C.DoubleLiteral (Word64 -> Literal) -> (Double -> Word64) -> Double -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord (Double -> Literal) -> Double -> Literal
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r
      Literal
LitNullAddr   -> [Char] -> Literal
C.StringLiteral []
      LitLabel FastString
fs Maybe Int
_ FunctionOrData
_ -> [Char] -> Literal
C.StringLiteral (FastString -> [Char]
unpackFS FastString
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 :: SrcSpan -> C2C a -> C2C a
addUsefull SrcSpan
x C2C a
m =
  if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
x
  then do a
a <- (GHC2CoreEnv -> GHC2CoreEnv) -> C2C a -> C2C a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
RWS.local ((SrcSpan -> Identity SrcSpan)
-> GHC2CoreEnv -> Identity GHC2CoreEnv
Lens' GHC2CoreEnv SrcSpan
srcSpan ((SrcSpan -> Identity SrcSpan)
 -> GHC2CoreEnv -> Identity GHC2CoreEnv)
-> SrcSpan -> GHC2CoreEnv -> GHC2CoreEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SrcSpan
x) C2C a
m
          SrcSpanRB -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
RWS.tell (SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
x)
          a -> C2C a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
a
  else C2C a
m

addUsefullR :: SrcSpan
            -> C2C a
            -> C2C a
addUsefullR :: SrcSpan -> C2C a -> C2C a
addUsefullR SrcSpan
x C2C a
m =
  if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
x
  then (GHC2CoreEnv -> GHC2CoreEnv) -> C2C a -> C2C a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
RWS.local ((SrcSpan -> Identity SrcSpan)
-> GHC2CoreEnv -> Identity GHC2CoreEnv
Lens' GHC2CoreEnv SrcSpan
srcSpan ((SrcSpan -> Identity SrcSpan)
 -> GHC2CoreEnv -> Identity GHC2CoreEnv)
-> SrcSpan -> GHC2CoreEnv -> GHC2CoreEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SrcSpan
x) C2C a
m
  else C2C a
m

isSizedCast :: Type -> Type -> C2C Bool
isSizedCast :: Type -> Type -> C2C Bool
isSizedCast (TyConApp TyCon
tc1 [Type]
_) (TyConApp TyCon
tc2 [Type]
_) = do
  Text
tc1Nm <- Name -> C2C Text
qualifiedNameString (TyCon -> Name
tyConName TyCon
tc1)
  Text
tc2Nm <- Name -> C2C Text
qualifiedNameString (TyCon -> Name
tyConName TyCon
tc2)
  Bool -> C2C Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return
    ([Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or [TyCon
tc1 TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
integerTyConKey Bool -> Bool -> Bool
&&
          [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or [Text
tc2Nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Signed.Signed"
             ,Text
tc2Nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Index.Index"]
        ,TyCon
tc2 TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
integerTyConKey Bool -> Bool -> Bool
&&
          [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or [Text
tc1Nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Signed.Signed"
             ,Text
tc1Nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Index.Index"]
        ,TyCon
tc1 TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
naturalTyConKey Bool -> Bool -> Bool
&&
          Text
tc2Nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Unsigned.Unsigned"
        ,TyCon
tc2 TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
naturalTyConKey Bool -> Bool -> Bool
&&
          Text
tc1Nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Unsigned.Unsigned"
        ])
isSizedCast Type
_ Type
_ = Bool -> C2C Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

hasPrimCo :: Coercion -> C2C (Maybe Type)
hasPrimCo :: Coercion -> C2C (Maybe Type)
hasPrimCo (TyConAppCo Role
_ TyCon
_ [Coercion]
coers) = do
  [Type]
tcs <- [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> [Type])
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Maybe Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Maybe Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Coercion -> C2C (Maybe Type)
hasPrimCo [Coercion]
coers
  Maybe Type -> C2C (Maybe Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe [Type]
tcs)

hasPrimCo (AppCo Coercion
co1 Coercion
co2) = do
  Maybe Type
tc1M <- Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co1
  case Maybe Type
tc1M of
    Just Type
_ -> Maybe Type -> C2C (Maybe Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Type
tc1M
    Maybe Type
_ -> Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co2
hasPrimCo (ForAllCo TyVar
_ Coercion
_ Coercion
co) = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co

hasPrimCo co :: Coercion
co@(AxiomInstCo CoAxiom Branched
_ Int
_ [Coercion]
coers) = do
    let (Pair Type
ty1 Type
_) = Coercion -> Pair Type
coercionKind Coercion
co
    Bool
ty1PM <- Type -> C2C Bool
isPrimTc Type
ty1
    if Bool
ty1PM
       then Maybe Type -> C2C (Maybe Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty1)
       else do
         [Type]
tcs <- [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> [Type])
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Maybe Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Maybe Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Coercion -> C2C (Maybe Type)
hasPrimCo [Coercion]
coers
         Maybe Type -> C2C (Maybe Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe [Type]
tcs)
  where
    isPrimTc :: Type -> C2C Bool
isPrimTc (TyConApp TyCon
tc [Type]
_) = do
      Text
tcNm <- Name -> C2C Text
qualifiedNameString (TyCon -> Name
tyConName TyCon
tc)
      Bool -> C2C Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
tcNm Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Text
"Clash.Sized.Internal.BitVector.Bit"
                          ,Text
"Clash.Sized.Internal.BitVector.BitVector"
                          ,Text
"Clash.Sized.Internal.Index.Index"
                          ,Text
"Clash.Sized.Internal.Signed.Signed"
                          ,Text
"Clash.Sized.Internal.Unsigned.Unsigned"
                          ])
    isPrimTc Type
_ = Bool -> C2C Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

hasPrimCo (SymCo Coercion
co) = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co

hasPrimCo (TransCo Coercion
co1 Coercion
co2) = do
  Maybe Type
tc1M <- Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co1
  case Maybe Type
tc1M of
    Just Type
_ -> Maybe Type -> C2C (Maybe Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Type
tc1M
    Maybe Type
_ -> Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co2

hasPrimCo (AxiomRuleCo CoAxiomRule
_ [Coercion]
coers) = do
  [Type]
tcs <- [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> [Type])
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Maybe Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Maybe Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Coercion -> C2C (Maybe Type)
hasPrimCo [Coercion]
coers
  Maybe Type -> C2C (Maybe Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe [Type]
tcs)

#if MIN_VERSION_ghc(9,6,0)
hasPrimCo (SelCo _ co) = hasPrimCo co
#else
hasPrimCo (NthCo Role
_ Int
_ Coercion
co)  = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
#endif
hasPrimCo (LRCo LeftOrRight
_ Coercion
co)   = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
hasPrimCo (InstCo Coercion
co Coercion
_) = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
hasPrimCo (SubCo Coercion
co)    = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co

hasPrimCo Coercion
_ = Maybe Type -> C2C (Maybe Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing

coreToDataCon :: DataCon
              -> C2C C.DataCon
coreToDataCon :: DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc = do
#if MIN_VERSION_ghc(9,0,0)
    repTys <- mapM (coreToType . scaledThing) (dataConRepArgTys dc)
#else
    [Type]
repTys <- (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType (DataCon -> [Type]
dataConRepArgTys DataCon
dc)
#endif
    Type
dcTy   <- Type -> C2C Type
coreToType (TyVar -> Type
varType (TyVar -> Type) -> TyVar -> Type
forall a b. (a -> b) -> a -> b
$ DataCon -> TyVar
dataConWorkId DataCon
dc)
    Type
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
mkDc Type
dcTy [Type]
repTys
  where
    mkDc :: Type
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
mkDc Type
dcTy [Type]
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 :: FieldLbl a -> Text
decLabel = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (FieldLbl a -> ByteString) -> FieldLbl a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
bytesFS (FastString -> ByteString)
-> (FieldLbl a -> FastString) -> FieldLbl a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLbl a -> FastString
forall a. FieldLbl a -> FastString
flLabel
#else
      let decLabel = decodeUtf8 . fastStringToByteString . flLabel
#endif
      let repBangs :: [DcStrictness]
repBangs = (HsImplBang -> DcStrictness) -> [HsImplBang] -> [DcStrictness]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap HsImplBang -> DcStrictness
hsImplBangToBool (DataCon -> [HsImplBang]
dataConImplBangs DataCon
dc)
      let fLabels :: [Text]
fLabels  = (FieldLbl Name -> Text) -> [FieldLbl Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Text
forall a. FieldLbl a -> Text
decLabel (DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
dc)

      Name DataCon
nm   <- (DataCon -> Name)
-> (DataCon -> Unique)
-> (Name -> C2C Text)
-> DataCon
-> C2C (Name DataCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName DataCon -> Name
dataConName DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name -> C2C Text
qualifiedNameString DataCon
dc
      [TyVar]
uTvs <- (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar (DataCon -> [TyVar]
dataConUnivTyVars DataCon
dc)
#if MIN_VERSION_ghc(8,8,0)
      [TyVar]
eTvs <- (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar (DataCon -> [TyVar]
dataConExTyCoVars DataCon
dc)
#else
      eTvs <- mapM coreToTyVar (dataConExTyVars dc)
#endif
      DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DataCon
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon)
-> DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
forall a b. (a -> b) -> a -> b
$ MkData :: Name DataCon
-> Int
-> Int
-> Type
-> [TyVar]
-> [TyVar]
-> [Type]
-> [DcStrictness]
-> [Text]
-> DataCon
C.MkData
             { dcName :: Name DataCon
C.dcName        = Name DataCon
nm
             , dcUniq :: Int
C.dcUniq        = Name DataCon -> Int
forall a. Name a -> Int
C.nameUniq Name DataCon
nm
             , dcTag :: Int
C.dcTag         = DataCon -> Int
dataConTag DataCon
dc
             , dcType :: Type
C.dcType        = Type
dcTy
             , dcArgTys :: [Type]
C.dcArgTys      = [Type]
repTys
             , dcArgStrict :: [DcStrictness]
C.dcArgStrict   = [DcStrictness]
repBangs
             , dcUnivTyVars :: [TyVar]
C.dcUnivTyVars  = [TyVar]
uTvs
             , dcExtTyVars :: [TyVar]
C.dcExtTyVars   = [TyVar]
eTvs
             , dcFieldLabels :: [Text]
C.dcFieldLabels = [Text]
fLabels
             }

hsImplBangToBool :: HsImplBang -> C.DcStrictness
hsImplBangToBool :: HsImplBang -> DcStrictness
hsImplBangToBool HsImplBang
HsLazy = DcStrictness
C.Lazy
hsImplBangToBool HsStrict{} = DcStrictness
C.Strict
hsImplBangToBool HsUnpack{} = DcStrictness
C.Strict

typeConstructorToString
  :: TyCon
  -> C2C String
typeConstructorToString :: TyCon -> C2C [Char]
typeConstructorToString TyCon
constructor =
   Text -> [Char]
Text.unpack (Text -> [Char]) -> (Name Any -> Text) -> Name Any -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name Any -> Text
forall a. Name a -> Text
C.nameOcc (Name Any -> [Char])
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Name Any)
-> C2C [Char]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Name Any)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
constructor

-- | Flatten a list type structure to a list of types.
listTypeToListOfTypes :: Type -> [Type]
-- TyConApp ': [kind, head, tail]
listTypeToListOfTypes :: Type -> [Type]
listTypeToListOfTypes (TyConApp TyCon
_ [Type
_, Type
a, Type
as]) = Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
listTypeToListOfTypes Type
as
listTypeToListOfTypes Type
ty                      =
  case Type -> Maybe Type
coreView Type
ty of
    Maybe Type
Nothing -> []
    Just Type
ty' -> Type -> [Type]
listTypeToListOfTypes Type
ty'

-- | Try to determine boolean value by looking at constructor name of type.
boolTypeToBool :: Type -> C2C Bool
boolTypeToBool :: Type -> C2C Bool
boolTypeToBool (TyConApp TyCon
constructor [Type]
_args) = do
  [Char]
constructorName <- TyCon -> C2C [Char]
typeConstructorToString TyCon
constructor
  Bool -> C2C Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> C2C Bool) -> Bool -> C2C Bool
forall a b. (a -> b) -> a -> b
$ case [Char]
constructorName of
    [Char]
"GHC.Types.True"  -> Bool
True
    [Char]
"GHC.Types.False" -> Bool
False
    [Char]
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected boolean constructor, got:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
constructorName
boolTypeToBool Type
s =
  [Char] -> C2C Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C Bool) -> [Char] -> C2C Bool
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Could not unpack given type to bool:"
                  , Type -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe Type
s ]

-- | Returns string of (LitTy (StrTyLit s)) construction.
tyLitToString :: Type -> String
tyLitToString :: Type -> [Char]
tyLitToString (LitTy (StrTyLit FastString
s)) = FastString -> [Char]
unpackFS FastString
s
tyLitToString Type
s = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Could not unpack given type to string:"
                                  , Type -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe Type
s ]

-- | Returns string in Text form of (LitTy (StrTyLit s)) construction.
tyLitToText :: Type -> Text
tyLitToText :: Type -> Text
tyLitToText = [Char] -> Text
Text.pack ([Char] -> Text) -> (Type -> [Char]) -> Type -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Char]
tyLitToString

-- | Returns integer of (LitTy (NumTyLit n)) construction.
tyLitToInteger :: Type -> Integer
tyLitToInteger :: Type -> Integer
tyLitToInteger (LitTy (NumTyLit Integer
n)) = Integer
n
tyLitToInteger Type
s = [Char] -> Integer
forall a. HasCallStack => [Char] -> a
error ([Char] -> Integer) -> [Char] -> Integer
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Could not unpack given type to integer:"
                                   , Type -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe Type
s ]

-- | Try to interpret a Type as an Attr
coreToAttr :: Type -> C2C (Attr Text)
coreToAttr :: Type -> C2C (Attr Text)
coreToAttr t0 :: Type
t0@(TyConApp TyCon
ty [Type]
args) = do
  [Char]
name <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty
  FamInstEnvs
envs <- Getting FamInstEnvs GHC2CoreEnv FamInstEnvs
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity FamInstEnvs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting FamInstEnvs GHC2CoreEnv FamInstEnvs
Lens' GHC2CoreEnv FamInstEnvs
famInstEnvs
  let
    -- XXX: This relies on 'value' not being evaluated if the constructor
    --      doesn't have a second field.
    key :: Type
key = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
1
    value :: Type
value = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
2
#if MIN_VERSION_ghc(9,4,0)
  let Reduction _ key1 = normaliseType envs Nominal key
      Reduction _ value1 = normaliseType envs Nominal value
#else
  let (Coercion
_,Type
key1) = FamInstEnvs -> Role -> Type -> (Coercion, Type)
normaliseType FamInstEnvs
envs Role
Nominal Type
key
      (Coercion
_,Type
value1) = FamInstEnvs -> Role -> Type -> (Coercion, Type)
normaliseType FamInstEnvs
envs Role
Nominal Type
value
#endif
  if
    | [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
forall a. Show a => a -> [Char]
show 'StringAttr ->
      Attr Text -> C2C (Attr Text)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr Text -> C2C (Attr Text)) -> Attr Text -> C2C (Attr Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Attr Text
forall a. a -> a -> Attr a
StringAttr (Type -> Text
tyLitToText Type
key1) (Type -> Text
tyLitToText Type
value1)
    | [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
forall a. Show a => a -> [Char]
show 'IntegerAttr ->
      Attr Text -> C2C (Attr Text)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr Text -> C2C (Attr Text)) -> Attr Text -> C2C (Attr Text)
forall a b. (a -> b) -> a -> b
$ Text -> Integer -> Attr Text
forall a. a -> Integer -> Attr a
IntegerAttr (Type -> Text
tyLitToText Type
key1) (Type -> Integer
tyLitToInteger Type
value1)
    | [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
forall a. Show a => a -> [Char]
show 'BoolAttr -> do
      Bool
bool <- Type -> C2C Bool
boolTypeToBool Type
value1
      Attr Text -> C2C (Attr Text)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr Text -> C2C (Attr Text)) -> Attr Text -> C2C (Attr Text)
forall a b. (a -> b) -> a -> b
$ Text -> Bool -> Attr Text
forall a. a -> Bool -> Attr a
BoolAttr (Type -> Text
tyLitToText Type
key1) Bool
bool
    | [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
forall a. Show a => a -> [Char]
show 'Attr ->
      Attr Text -> C2C (Attr Text)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr Text -> C2C (Attr Text)) -> Attr Text -> C2C (Attr Text)
forall a b. (a -> b) -> a -> b
$ Text -> Attr Text
forall a. a -> Attr a
Attr (Type -> Text
tyLitToText Type
key1)
    | Bool
otherwise ->
      case Type -> Maybe Type
coreView Type
t0 of
        Just Type
t1 -> Type -> C2C (Attr Text)
coreToAttr Type
t1
        Maybe Type
Nothing -> [Char] -> C2C (Attr Text)
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C (Attr Text)) -> [Char] -> C2C (Attr Text)
forall a b. (a -> b) -> a -> b
$ [__i|Expected constructor of Attr, got #{name}|]
coreToAttr Type
t0 =
  case Type -> Maybe Type
coreView Type
t0 of
    Just Type
t1 -> Type -> C2C (Attr Text)
coreToAttr Type
t1
    Maybe Type
Nothing -> [Char] -> C2C (Attr Text)
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C (Attr Text)) -> [Char] -> C2C (Attr Text)
forall a b. (a -> b) -> a -> b
$ [__i|Expected constructor of Attr, got #{showPprUnsafe t0}|]

coreToAttrs' :: [Type] -> C2C [Attr Text]
coreToAttrs' :: [Type] -> C2C [Attr Text]
coreToAttrs' [Type
k, Type
a, Type
attrs] = do
  -- We expect three type arguments:
  --
  --  k: either @Attr@ or @[Attr]@
  --  a: type being annotated
  --  attrs: attribute or list of attributes
  --
  Maybe [Attr Text]
attrs1 <- RWST
  GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
tryList
  Maybe [Attr Text]
attrs2 <- RWST
  GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
tryAttr
  case Maybe [Attr Text]
attrs1 Maybe [Attr Text] -> Maybe [Attr Text] -> Maybe [Attr Text]
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> Maybe [Attr Text]
attrs2 of
    Just [Attr Text]
theseAttrs -> do
      [Attr Text]
subAttrs <- Type -> C2C [Attr Text]
coreToAttrs Type
a
      [Attr Text] -> C2C [Attr Text]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Attr Text]
theseAttrs [Attr Text] -> [Attr Text] -> [Attr Text]
forall a. Semigroup a => a -> a -> a
<> [Attr Text]
subAttrs)
    Maybe [Attr Text]
Nothing ->
      [Char] -> C2C [Attr Text]
forall a. HasCallStack => [Char] -> a
error [__i|
        Expected either an attribute or a list of attributes, got:

          #{showPprUnsafe k}
      |]
 where

  isListTy :: TyCon -> C2C Bool
isListTy = ([Char] -> Bool) -> C2C [Char] -> C2C Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
forall a. Show a => a -> [Char]
show ''[]) (C2C [Char] -> C2C Bool)
-> (TyCon -> C2C [Char]) -> TyCon -> C2C Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> C2C [Char]
typeConstructorToString
  isAttrTy :: TyCon -> C2C Bool
isAttrTy = ([Char] -> Bool) -> C2C [Char] -> C2C Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
forall a. Show a => a -> [Char]
show ''Attr) (C2C [Char] -> C2C Bool)
-> (TyCon -> C2C [Char]) -> TyCon -> C2C Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> C2C [Char]
typeConstructorToString

  tryList :: RWST
  GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
tryList = case Type
k of
    TyConApp TyCon
ty0 [TyConApp TyCon
ty1 [Type]
_] -> do
      C2C Bool
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (m :: Type -> Type) a.
Monad m =>
m Bool -> m a -> m a -> m a
ifM
        ([C2C Bool] -> C2C Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
andM [TyCon -> C2C Bool
isListTy TyCon
ty0, TyCon -> C2C Bool
isAttrTy TyCon
ty1])
        ([Attr Text] -> Maybe [Attr Text]
forall a. a -> Maybe a
Just ([Attr Text] -> Maybe [Attr Text])
-> C2C [Attr Text]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> C2C (Attr Text)) -> [Type] -> C2C [Attr Text]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> C2C (Attr Text)
coreToAttr (Type -> [Type]
listTypeToListOfTypes Type
attrs))
        (Maybe [Attr Text]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Attr Text]
forall a. Maybe a
Nothing)
    Type
_ -> Maybe [Attr Text]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Attr Text]
forall a. Maybe a
Nothing

  tryAttr :: RWST
  GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
tryAttr = case Type
k of
    TyConApp TyCon
ty [Type]
_ -> do
      C2C Bool
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (m :: Type -> Type) a.
Monad m =>
m Bool -> m a -> m a -> m a
ifM
        (TyCon -> C2C Bool
isAttrTy TyCon
ty)
        ([Attr Text] -> Maybe [Attr Text]
forall a. a -> Maybe a
Just ([Attr Text] -> Maybe [Attr Text])
-> C2C [Attr Text]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [C2C (Attr Text)] -> C2C [Attr Text]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Type -> C2C (Attr Text)
coreToAttr Type
attrs])
        (Maybe [Attr Text]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Attr Text]
forall a. Maybe a
Nothing)
    Type
_ -> Maybe [Attr Text]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Maybe [Attr Text])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe [Attr Text]
forall a. Maybe a
Nothing

coreToAttrs' [Type]
illegal =
  [Char] -> C2C [Attr Text]
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr Text]) -> [Char] -> C2C [Attr Text]
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected type args to Annotate: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ((Type -> [Char]) -> [Type] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe) [Type]
illegal)

-- | If this type has an annotate type synonym, return list of attributes.
coreToAttrs :: Type -> C2C [Attr Text]
coreToAttrs :: Type -> C2C [Attr Text]
coreToAttrs (TyConApp TyCon
tycon [Type]
kindsOrTypes) = do
  [Char]
name' <- TyCon -> C2C [Char]
typeConstructorToString TyCon
tycon

  if [Char]
name' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [Char]
forall a. Show a => a -> [Char]
show ''Annotate
  then [Type] -> C2C [Attr Text]
coreToAttrs' [Type]
kindsOrTypes
  else [Attr Text] -> C2C [Attr Text]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []

coreToAttrs Type
_ =
    [Attr Text] -> C2C [Attr Text]
forall (m :: Type -> Type) a. Monad m => a -> m a
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 :: Type -> Type -> C2C Type
annotateType Type
ty Type
cty = do
  [Attr Text]
attrs <- Type -> C2C [Attr Text]
coreToAttrs Type
ty
  case [Attr Text]
attrs of
    [] -> Type -> C2C Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return Type
cty
    [Attr Text]
_  -> Type -> C2C Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> C2C Type) -> Type -> C2C Type
forall a b. (a -> b) -> a -> b
$ [Attr Text] -> Type -> Type
C.AnnType [Attr Text]
attrs Type
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 :: Type -> C2C Type
coreToType Type
ty = C2C Type
ty'' C2C Type -> (Type -> C2C Type) -> C2C Type
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Type -> C2C Type
annotateType Type
ty
  where
    ty'' :: C2C Type
ty'' =
      case Type -> Maybe Type
coreView Type
ty of
        Just Type
ty' -> Type -> C2C Type
coreToType Type
ty'
        Maybe Type
Nothing  -> Type -> C2C Type
coreToType' Type
ty

coreToType'
  :: Type
  -> C2C C.Type
coreToType' :: Type -> C2C Type
coreToType' (TyVarTy TyVar
tv) = TyVar -> Type
C.VarTy (TyVar -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
-> C2C Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv
coreToType' (TyConApp TyCon
tc [Type]
args)
#if MIN_VERSION_ghc(9,6,0)
  | Just (FunTy _ _ ty1 ty2) <- tyConAppFunTy_maybe tc args = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#else
  | TyCon -> Bool
isFunTyCon TyCon
tc = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
C.AppTy (ConstTy -> Type
C.ConstTy ConstTy
C.Arrow) ([Type] -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
-> C2C Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType [Type]
args
#endif
  | Bool
otherwise     = case TyCon -> [Type] -> Maybe ([(TyVar, Type)], Type, [Type])
forall tyco.
TyCon -> [tyco] -> Maybe ([(TyVar, tyco)], Type, [tyco])
expandSynTyCon_maybe TyCon
tc [Type]
args of
#if MIN_VERSION_ghc(9,6,0)
                      ExpandsSyn substs synTy remArgs -> do
#else
                      Just ([(TyVar, Type)]
substs,Type
synTy,[Type]
remArgs) -> do
#endif
                        let substs' :: TCvSubst
substs' = [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs [(TyVar, Type)]
substs
                            synTy' :: Type
synTy'  = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
substs' Type
synTy
                        (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
C.AppTy (Type -> [Type] -> Type)
-> C2C Type
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
synTy' RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
-> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType [Type]
remArgs
                      Maybe ([(TyVar, Type)], Type, [Type])
_ -> do
                        Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
                        (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)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Name TyCon -> TyCon -> UniqMap TyCon -> UniqMap TyCon
forall a b. Uniquable a => a -> b -> UniqMap b -> UniqMap b
C.insert Name TyCon
tcName TyCon
tc)
                        Name TyCon -> [Type] -> Type
C.mkTyConApp (Name TyCon -> [Type] -> Type)
-> C2C (Name TyCon)
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name TyCon -> C2C (Name TyCon)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Name TyCon
tcName) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
-> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType [Type]
args
#if MIN_VERSION_ghc(8,8,0)
coreToType' (ForAllTy (Bndr TyVar
tv ArgFlag
_) Type
ty)   = TyVar -> Type -> Type
C.ForAllTy (TyVar -> Type -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
-> C2C Type -> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
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 AnonArgFlag
_ Type
ty1 Type
ty2)             = Type -> Type -> Type
C.mkFunTy (Type -> Type -> Type)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
ty1 RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
-> C2C Type -> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
ty2
#endif
#else
coreToType' (FunTy ty1 ty2)             = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#endif
coreToType' (LitTy TyLit
tyLit)    = Type -> C2C Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> C2C Type) -> Type -> C2C Type
forall a b. (a -> b) -> a -> b
$ LitTy -> Type
C.LitTy (TyLit -> LitTy
coreToTyLit TyLit
tyLit)
coreToType' (AppTy Type
ty1 Type
ty2)  = Type -> Type -> Type
C.AppTy (Type -> Type -> Type)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
ty1 RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
-> C2C Type -> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType' Type
ty2
coreToType' (CastTy Type
t (Refl{})) = Type -> C2C Type
coreToType' Type
t
coreToType' t :: Type
t@(CastTy Type
_ Coercion
_)   = [Char] -> C2C Type
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot handle CastTy " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe Type
t)
coreToType' t :: Type
t@(CoercionTy Coercion
_) = [Char] -> C2C Type
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot handle CoercionTy " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Outputable a => a -> [Char]
showPprUnsafe Type
t)

coreToTyLit :: TyLit
            -> C.LitTy
coreToTyLit :: TyLit -> LitTy
coreToTyLit (NumTyLit Integer
i) = Integer -> LitTy
C.NumTy (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
i)
coreToTyLit (StrTyLit FastString
s) = [Char] -> LitTy
C.SymTy (FastString -> [Char]
unpackFS FastString
s)
#if MIN_VERSION_ghc(9,2,0)
coreToTyLit (CharTyLit c) = C.CharTy c
#endif

coreToTyVar :: TyVar
            -> C2C C.TyVar
coreToTyVar :: TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv =
  Type -> TyName -> TyVar
C.mkTyVar (Type -> TyName -> TyVar)
-> C2C Type
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (TyName -> TyVar)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType (TyVar -> Type
varType TyVar
tv) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (TyName -> TyVar)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyName
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyName
forall a. TyVar -> C2C (Name a)
coreToVar TyVar
tv

coreToId :: Id
         -> C2C C.Id
coreToId :: TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToId TyVar
i = do
  Type -> IdScope -> Name Term -> Id
C.mkId (Type -> IdScope -> Name Term -> Id)
-> C2C Type
-> RWST
     GHC2CoreEnv
     SrcSpanRB
     GHC2CoreState
     Identity
     (IdScope -> Name Term -> Id)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType (TyVar -> Type
varType TyVar
i) RWST
  GHC2CoreEnv
  SrcSpanRB
  GHC2CoreState
  Identity
  (IdScope -> Name Term -> Id)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity IdScope
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Name Term -> Id)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IdScope
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity IdScope
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure IdScope
scope RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Name Term -> Id)
-> C2C (Name Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TyVar -> C2C (Name Term)
forall a. TyVar -> C2C (Name a)
coreToVar TyVar
i
 where
  scope :: IdScope
scope = if TyVar -> Bool
isGlobalId TyVar
i then IdScope
C.GlobalId else IdScope
C.LocalId

coreToVar :: Var
          -> C2C (C.Name a)
coreToVar :: TyVar -> C2C (Name a)
coreToVar = (TyVar -> Name)
-> (TyVar -> Unique) -> (Name -> C2C Text) -> TyVar -> C2C (Name a)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyVar -> Name
varName TyVar -> Unique
varUnique Name -> C2C Text
qualifiedNameStringM

coreToPrimVar :: Var
              -> C2C (C.Name C.Term)
coreToPrimVar :: TyVar -> C2C (Name Term)
coreToPrimVar = (TyVar -> Name)
-> (TyVar -> Unique)
-> (Name -> C2C Text)
-> TyVar
-> C2C (Name Term)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyVar -> Name
varName TyVar -> Unique
varUnique Name -> C2C Text
qualifiedNameString

coreToName
  :: (b -> Name)
  -> (b -> Unique)
  -> (Name -> C2C Text)
  -> b
  -> C2C (C.Name a)
coreToName :: (b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName b -> Name
toName b -> Unique
toUnique Name -> C2C Text
toString b
v = do
  Text
ns <- Name -> C2C Text
toString (b -> Name
toName b
v)
  let key :: Int
key  = Unique -> Int
getKey (b -> Unique
toUnique b
v)
      locI :: SrcSpan
locI = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan (b -> Name
toName b
v)
      -- Is it one of [ds,ds1,ds2,..]
      isDSX :: Text -> Bool
isDSX = Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> ((Char, Text) -> Bool) -> Maybe (Char, Text) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Char -> Bool
isDigit (Char -> Bool) -> ((Char, Text) -> Char) -> (Char, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Text) -> Char
forall a b. (a, b) -> a
fst) (Maybe (Char, Text) -> Bool)
-> (Text -> Maybe (Char, Text)) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
Text.uncons) (Maybe Text -> Bool) -> (Text -> Maybe Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
Text.stripPrefix Text
"ds"
      sort :: NameSort
sort | Text -> Bool
isDSX Text
ns Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isPrefixOf Text
"$" Text
ns
           = NameSort
C.System
           | Bool
otherwise
           = NameSort
C.User
  SrcSpan
locR <- Getting SrcSpan GHC2CoreEnv SrcSpan
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity SrcSpan
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting SrcSpan GHC2CoreEnv SrcSpan
Lens' GHC2CoreEnv SrcSpan
srcSpan
  let loc :: SrcSpan
loc = if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
locI then SrcSpan
locI else SrcSpan
locR
  Name a -> C2C (Name a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (NameSort -> Text -> Int -> SrcSpan -> Name a
forall a. NameSort -> Text -> Int -> SrcSpan -> Name a
C.Name NameSort
sort Text
ns Int
key SrcSpan
loc)

qualifiedNameString'
  :: Name
  -> Text
qualifiedNameString' :: Name -> Text
qualifiedNameString' Name
n =
  Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"_INTERNAL_" (Name -> Maybe Text
modNameM Name
n) Text -> Text -> Text
`Text.append` (Char
'.' Char -> Text -> Text
`Text.cons` Text
occName)
 where
  occName :: Text
occName = [Char] -> Text
pack (OccName -> [Char]
occNameString (Name -> OccName
nameOccName Name
n))

qualifiedNameString
  :: Name
  -> C2C Text
qualifiedNameString :: Name -> C2C Text
qualifiedNameString Name
n =
  Name
-> Lens' GHC2CoreState (HashMap Name Text) -> C2C Text -> C2C Text
forall s (m :: Type -> Type) k v.
(MonadState s m, Hashable k, Eq k) =>
k -> Lens' s (HashMap k v) -> m v -> m v
makeCached Name
n Lens' GHC2CoreState (HashMap Name Text)
nameMap (C2C Text -> C2C Text) -> C2C Text -> C2C Text
forall a b. (a -> b) -> a -> b
$
  Text -> C2C Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"_INTERNAL_" (Name -> Maybe Text
modNameM Name
n) Text -> Text -> Text
`Text.append` (Char
'.' Char -> Text -> Text
`Text.cons` Text
occName))
 where
  occName :: Text
occName = [Char] -> Text
pack (OccName -> [Char]
occNameString (Name -> OccName
nameOccName Name
n))

qualifiedNameStringM
  :: Name
  -> C2C Text
qualifiedNameStringM :: Name -> C2C Text
qualifiedNameStringM Name
n =
  Name
-> Lens' GHC2CoreState (HashMap Name Text) -> C2C Text -> C2C Text
forall s (m :: Type -> Type) k v.
(MonadState s m, Hashable k, Eq k) =>
k -> Lens' s (HashMap k v) -> m v -> m v
makeCached Name
n Lens' GHC2CoreState (HashMap Name Text)
nameMap (C2C Text -> C2C Text) -> C2C Text -> C2C Text
forall a b. (a -> b) -> a -> b
$
  Text -> C2C Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
occName (\Text
modName -> Text
modName Text -> Text -> Text
`Text.append` (Char
'.' Char -> Text -> Text
`Text.cons` Text
occName)) (Name -> Maybe Text
modNameM Name
n))
 where
  occName :: Text
occName = [Char] -> Text
pack (OccName -> [Char]
occNameString (Name -> OccName
nameOccName Name
n))

modNameM :: Name
         -> Maybe Text
modNameM :: Name -> Maybe Text
modNameM Name
n = do
  Module
module_ <- Name -> Maybe Module
nameModule_maybe Name
n
  let moduleNm :: ModuleName
moduleNm = Module -> ModuleName
moduleName Module
module_
  Text -> Maybe Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Char] -> Text
pack (ModuleName -> [Char]
moduleNameString ModuleName
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 :: Int -> Type -> Term
bundleUnbundleTerm Int
nTyVarsExpected = [TyVar] -> Type -> Term
go []
 where
  go :: [C.TyVar] -> C.Type -> C.Term
  go :: [TyVar] -> Type -> Term
go [TyVar]
tvs (C.ForAllTy TyVar
tv Type
typ) = [TyVar] -> Type -> Term
go (TyVar
tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
tvs) Type
typ
  go [TyVar]
tvs (Type -> TypeView
C.tyView -> C.FunTy Type
argTy Type
_resTy) =
    if [TyVar] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TyVar]
tvs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nTyVarsExpected then
      -- Internal error: should never happen unless we change the type of
      -- bundle / unbundle.
      [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([TyVar] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TyVar]
tvs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" vs " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nTyVarsExpected
    else
      let sigName :: Id
sigName = Type -> Name Term -> Id
C.mkLocalId Type
argTy (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"c$s" Int
0) in
      (TyVar -> Term -> Term) -> Term -> [TyVar] -> Term
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVar -> Term -> Term
C.TyLam (Id -> Term -> Term
C.Lam Id
sigName (Id -> Term
C.Var Id
sigName)) ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs)
  go [TyVar]
tvs Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [TyVar] -> [Char]
forall a. Show a => a -> [Char]
show [TyVar]
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 :: Type -> Term
mapSignalTerm (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV (C.ForAllTy TyVar
clkTV Type
funTy)))
  | (C.FunTy Type
_ Type
funTy'') <- Type -> TypeView
C.tyView Type
funTy
  , (C.FunTy Type
aTy Type
bTy)   <- Type -> TypeView
C.tyView Type
funTy''
  = let
      fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
      xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
      fTy :: Type
fTy   = Type -> Type -> Type
C.mkFunTy Type
aTy Type
bTy
      fId :: Id
fId   = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
      xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
aTy Name Term
forall a. Name a
xName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      TyVar -> Term -> Term
C.TyLam TyVar
bTV (
      TyVar -> Term -> Term
C.TyLam TyVar
clkTV (
      Id -> Term -> Term
C.Lam   Id
fId (
      Id -> Term -> Term
C.Lam   Id
xId (
      Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
xId))))))

mapSignalTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
signalTerm (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
domTV Type
funTy))
  | (C.FunTy Type
_ Type
saTy) <- Type -> TypeView
C.tyView Type
funTy
  = let
      xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
0
      xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
saTy Name Term
forall a. Name a
xName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      TyVar -> Term -> Term
C.TyLam TyVar
domTV (
      Id -> Term -> Term
C.Lam   Id
xId (
      Id -> Term
C.Var   Id
xId)))

signalTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
appSignalTerm (C.ForAllTy TyVar
domTV (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV Type
funTy)))
  | (C.FunTy Type
_ Type
funTy'') <- Type -> TypeView
C.tyView Type
funTy
  , (C.FunTy Type
saTy Type
sbTy) <- Type -> TypeView
C.tyView Type
funTy''
  = let
      fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
      xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
      fTy :: Type
fTy   = Type -> Type -> Type
C.mkFunTy Type
saTy Type
sbTy
      fId :: Id
fId   = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
      xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
saTy Name Term
forall a. Name a
xName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
domTV (
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      TyVar -> Term -> Term
C.TyLam TyVar
bTV (
      Id -> Term -> Term
C.Lam   Id
fId (
      Id -> Term -> Term
C.Lam   Id
xId (
      Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
xId))))))

appSignalTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
vecUnwrapTerm (C.ForAllTy TyVar
tTV (C.ForAllTy TyVar
nTV (C.ForAllTy TyVar
aTV Type
funTy)))
  | (C.FunTy Type
_ Type
vsTy) <- Type -> TypeView
C.tyView Type
funTy
  = let
        vsName :: Name a
vsName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"vs" Int
0
        vsId :: Id
vsId   = Type -> Name Term -> Id
C.mkLocalId Type
vsTy Name Term
forall a. Name a
vsName
    in
        TyVar -> Term -> Term
C.TyLam TyVar
tTV (
        TyVar -> Term -> Term
C.TyLam TyVar
nTV (
        TyVar -> Term -> Term
C.TyLam TyVar
aTV (
        Id -> Term -> Term
C.Lam   Id
vsId (
        Id -> Term
C.Var Id
vsId))))

vecUnwrapTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
traverseTerm (C.ForAllTy TyVar
fTV (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV (C.ForAllTy TyVar
domTV Type
funTy))))
    | (C.FunTy Type
dictTy Type
funTy1) <- Type -> TypeView
C.tyView Type
funTy
    , (C.FunTy Type
gTy    Type
funTy2) <- Type -> TypeView
C.tyView Type
funTy1
    , (C.FunTy Type
xTy    Type
_)      <- Type -> TypeView
C.tyView Type
funTy2
    = let
        dictName :: Name a
dictName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"dict" Int
0
        gName :: Name a
gName    = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"g" Int
1
        xName :: Name a
xName    = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
2
        dictId :: Id
dictId   = Type -> Name Term -> Id
C.mkLocalId Type
dictTy Name Term
forall a. Name a
dictName
        gId :: Id
gId      = Type -> Name Term -> Id
C.mkLocalId Type
gTy Name Term
forall a. Name a
gName
        xId :: Id
xId      = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName
      in
        TyVar -> Term -> Term
C.TyLam TyVar
fTV (
        TyVar -> Term -> Term
C.TyLam TyVar
aTV (
        TyVar -> Term -> Term
C.TyLam TyVar
bTV (
        TyVar -> Term -> Term
C.TyLam TyVar
domTV (
        Id -> Term -> Term
C.Lam   Id
dictId (
        Id -> Term -> Term
C.Lam   Id
gId (
        Id -> Term -> Term
C.Lam   Id
xId (
        Term -> Term -> Term
C.App (Id -> Term
C.Var Id
gId) (Id -> Term
C.Var Id
xId))))))))

traverseTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
dollarTerm (C.ForAllTy TyVar
rTV (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV Type
funTy)))
  | (C.FunTy Type
fTy Type
funTy'') <- Type -> TypeView
C.tyView Type
funTy
  , (C.FunTy Type
aTy Type
_)       <- Type -> TypeView
C.tyView Type
funTy''
  = let
      fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
      xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
      fId :: Id
fId   = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
      xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
aTy Name Term
forall a. Name a
xName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
rTV (
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      TyVar -> Term -> Term
C.TyLam TyVar
bTV (
      Id -> Term -> Term
C.Lam   Id
fId (
      Id -> Term -> Term
C.Lam   Id
xId (
      Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
xId))))))
#endif

dollarTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall p. PrettyPrec p => p -> [Char]
C.showPpr Type
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 :: Type -> Term
joinTerm ty :: Type
ty@(C.ForAllTy {}) = Type -> Term
signalTerm Type
ty
joinTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
withFrozenCallStackTerm (C.ForAllTy TyVar
aTV Type
funTy)
  | (C.FunTy Type
callStackTy Type
fTy) <- Type -> TypeView
C.tyView Type
funTy
  = let
      callStackName :: Name a
callStackName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"callStack" Int
0
      fName :: Name a
fName         = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
1
      callStackId :: Id
callStackId   = Type -> Name Term -> Id
C.mkLocalId Type
callStackTy Name Term
forall a. Name a
callStackName
      fId :: Id
fId           = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
    in
      TyVar -> Term -> Term
C.TyLam  TyVar
aTV (
      Id -> Term -> Term
C.Lam    Id
callStackId (
      Id -> Term -> Term
C.Lam    Id
fId (
      Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
callStackId))))

withFrozenCallStackTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty

-- | Given the type:
--
-- @forall a. a -> a@
--
-- Generate the term
--
-- @/\(a:*).\(x:a).x@
idTerm
  :: C.Type
  -> C.Term
idTerm :: Type -> Term
idTerm (C.ForAllTy TyVar
aTV Type
funTy)
  | (C.FunTy Type
xTy Type
_) <- Type -> TypeView
C.tyView Type
funTy
  = let
      xName :: Name a
xName           = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
0
      xId :: Id
xId             = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      Id -> Term -> Term
C.Lam   Id
xId (
      Id -> Term
C.Var Id
xId))

idTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
runRWTerm (C.ForAllTy TyVar
rTV (C.ForAllTy TyVar
oTV Type
funTy))
  | (C.FunTy Type
fTy Type
_)  <- Type -> TypeView
C.tyView Type
funTy
  , (C.FunTy Type
rwTy Type
_) <- Type -> TypeView
C.tyView Type
fTy
  = let
      fName :: Name a
fName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
      fId :: Id
fId              = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
      rwNm :: Text
rwNm             = [Char] -> Text
pack [Char]
"GHC.Prim.realWorld#"
    in
      TyVar -> Term -> Term
C.TyLam TyVar
rTV (
      TyVar -> Term -> Term
C.TyLam TyVar
oTV (
      Id -> Term -> Term
C.Lam   Id
fId (
      (Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId)
             (PrimInfo -> Term
C.Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
C.PrimInfo Text
rwNm Type
rwTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult PrimUnfolding
C.NoUnfolding))))))

runRWTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
checkUnpackUndefTerm (C.ForAllTy TyVar
nTV (C.ForAllTy TyVar
aTV Type
funTy))
  | C.FunTy Type
knTy Type
r0Ty <- Type -> TypeView
C.tyView Type
funTy
  , C.FunTy Type
tpTy Type
r1Ty <- Type -> TypeView
C.tyView Type
r0Ty
  , C.FunTy Type
fTy Type
_     <- Type -> TypeView
C.tyView Type
r1Ty
  = let
      knName :: Name a
knName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"kn" Int
0
      tpName :: Name a
tpName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"tp" Int
1
      fName :: Name a
fName             = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
2
      knId :: Id
knId              = Type -> Name Term -> Id
C.mkLocalId Type
knTy Name Term
forall a. Name a
knName
      tpId :: Id
tpId              = Type -> Name Term -> Id
C.mkLocalId Type
tpTy Name Term
forall a. Name a
tpName
      fId :: Id
fId               = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
nTV (
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      Id -> Term -> Term
C.Lam Id
knId (
      Id -> Term -> Term
C.Lam Id
tpId (
      Id -> Term -> Term
C.Lam Id
fId (
      Id -> Term
C.Var Id
fId)))))

checkUnpackUndefTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: NameMod -> Type -> Term
nameModTerm NameMod
sa (C.ForAllTy TyVar
nmTV (C.ForAllTy TyVar
aTV Type
funTy))
  | (C.FunTy Type
xTy Type
_) <- Type -> TypeView
C.tyView Type
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 :: Name a
xName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
0
      xId :: Id
xId              = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
nmTV (
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      Id -> Term -> Term
C.Lam   Id
xId (
      (TickInfo -> Term -> Term
C.Tick (NameMod -> Type -> TickInfo
C.NameMod NameMod
sa (TyVar -> Type
C.VarTy TyVar
nmTV)) (Id -> Term
C.Var Id
xId)))))

nameModTerm NameMod
_ Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
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 :: Type -> Term
xToErrorCtxTerm (C.ForAllTy TyVar
aTV Type
funTy)
  | (C.FunTy Type
ctxTy Type
rTy) <- Type -> TypeView
C.tyView Type
funTy
  , (C.FunTy Type
xTy Type
_)     <- Type -> TypeView
C.tyView Type
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 :: Name a
ctxName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"ctx" Int
0
      ctxId :: Id
ctxId   = Type -> Name Term -> Id
C.mkLocalId Type
ctxTy Name Term
forall a. Name a
ctxName
      xName :: Name a
xName   = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
      xId :: Id
xId     = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName
    in
      TyVar -> Term -> Term
C.TyLam TyVar
aTV (
      Id -> Term -> Term
C.Lam Id
ctxId (
      Id -> Term -> Term
C.Lam Id
xId (
      Id -> Term
C.Var Id
xId)))

xToErrorCtxTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty

isDataConWrapId :: Id -> Bool
isDataConWrapId :: TyVar -> Bool
isDataConWrapId TyVar
v = case TyVar -> IdDetails
idDetails TyVar
v of
  DataConWrapId {} -> Bool
True
  IdDetails
_                -> Bool
False