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

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Clash.GHC.GHC2Core
  ( C2C
  , GHC2CoreState
  , tyConMap
  , coreToTerm
  , coreToId
  , coreToName
  , modNameM
  , qualifiedNameString
  , qualifiedNameString'
  , makeAllTyCons
  , emptyGHC2CoreState
  )
where

-- External Modules
import           Control.Lens                ((^.), (%~), (&), (%=))
import           Control.Monad.RWS.Strict    (RWS)
import qualified Control.Monad.RWS.Strict    as RWS
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)
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif
import           Data.Text                   (Text, pack)
import qualified Data.Text                   as Text
import           Data.Text.Encoding          (decodeUtf8)
import qualified Data.Traversable            as T
import qualified Text.Read                   as Text

-- GHC API
#if MIN_VERSION_ghc(9,0,0)
import GHC.Core.Coercion.Axiom
  (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs), fromBranches)
import GHC.Core.Coercion (coercionType,coercionKind)
import GHC.Core.FVs  (exprSomeFreeVars)
import GHC.Core
  (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..),
   collectArgs, rhssOfAlts, unfoldingTemplate)
import GHC.Core.DataCon
  (DataCon, dataConExTyCoVars, dataConName, dataConRepArgTys, dataConTag,
   dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel)
import GHC.Driver.Session (unsafeGlobalDynFlags)
import GHC.Core.FamInstEnv (FamInst (..), FamInstEnvs, familyInstances)
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 (..))
import GHC.Unit.Module (moduleName, moduleNameString)
import GHC.Types.Name
  (Name, nameModule_maybe, nameOccName, nameUnique, getSrcSpan)
import GHC.Builtin.Names  (tYPETyConKey, integerTyConKey, naturalTyConKey)
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Utils.Outputable (showPpr)
import GHC.Data.Pair (Pair (..))
import GHC.Types.SrcLoc (SrcSpan (..), isGoodSrcSpan)
import GHC.Core.TyCon
  (AlgTyConRhs (..), TyCon, tyConName, algTyConRhs, isAlgTyCon, isFamilyTyCon,
   isFunTyCon, isNewTyCon, isPrimTyCon, isTupleTyCon,
   isClosedSynFamilyTyConWithAxiom_maybe, expandSynTyCon_maybe, tyConArity,
   tyConDataCons, tyConKind, tyConName, tyConUnique, isClassTyCon)
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)
import Coercion   (coercionType,coercionKind)
import CoreFVs    (exprSomeFreeVars)
import CoreSyn
  (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..),
   collectArgs, rhssOfAlts, unfoldingTemplate)
import DataCon    (DataCon,
#if MIN_VERSION_ghc(8,8,0)
                   dataConExTyCoVars,
#else
                   dataConExTyVars,
#endif
                   dataConName, dataConRepArgTys,
                   dataConTag, dataConTyCon,
                   dataConUnivTyVars, dataConWorkId,
                   dataConFieldLabels, flLabel)
import DynFlags   (unsafeGlobalDynFlags)
import FamInstEnv (FamInst (..), FamInstEnvs,
                   familyInstances)

#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 (..))
#if MIN_VERSION_ghc(8,6,0)
import Literal    (LitNumType (..))
#endif
import Module     (moduleName, moduleNameString)
import Name       (Name, nameModule_maybe,
                   nameOccName, nameUnique, getSrcSpan)
import PrelNames  (tYPETyConKey, integerTyConKey, naturalTyConKey)
import OccName    (occNameString)
import Outputable (showPpr)
import Pair       (Pair (..))
import SrcLoc     (SrcSpan (..), isGoodSrcSpan)
import TyCon      (AlgTyConRhs (..), TyCon, tyConName,
                   algTyConRhs, isAlgTyCon, isFamilyTyCon,
                   isFunTyCon, isNewTyCon,
                   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 qualified Clash.Core.DataCon          as C
import qualified Clash.Core.Literal          as C
import qualified Clash.Core.Name             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.Var              as C
import           Clash.Primitives.Types
import qualified Clash.Unique                as C
import           Clash.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

emptyGHC2CoreState :: GHC2CoreState
emptyGHC2CoreState :: GHC2CoreState
emptyGHC2CoreState = UniqMap TyCon -> HashMap Name Text -> GHC2CoreState
GHC2CoreState UniqMap TyCon
forall a. UniqMap a
C.emptyUniqMap 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
#if !MIN_VERSION_base(4,11,0)
  mappend = (<>)
#endif

type C2C = RWS SrcSpan 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.nullUniqMap (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. UniqMap a
C.emptyUniqMap
        | Bool
otherwise                       = UniqMap TyCon
tcm UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
forall a. UniqMap a -> UniqMap a -> UniqMap a
`C.unionUniqMap` UniqMap TyCon
tcm'
      where
        (UniqMap TyCon
tcm,GHC2CoreState
old', SrcSpanRB
_) = RWS SrcSpan SrcSpanRB GHC2CoreState (UniqMap TyCon)
-> SrcSpan
-> GHC2CoreState
-> (UniqMap TyCon, GHC2CoreState, SrcSpanRB)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
RWS.runRWS ((TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon)
-> UniqMap TyCon
-> RWS SrcSpan 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 (FamInstEnvs
-> TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
makeTyCon FamInstEnvs
fiEnvs) (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
noSrcSpan 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 a. UniqMap a -> UniqMap a -> UniqMap a
`C.differenceUniqMap` (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 :: FamInstEnvs
          -> TyCon
          -> C2C C.TyCon
makeTyCon :: FamInstEnvs
-> TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
makeTyCon FamInstEnvs
fiEnvs TyCon
tc = RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
tycon
  where
    tycon :: RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
tycon
      | TyCon -> Bool
isFamilyTyCon TyCon
tc    = RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
mkFunTyCon
      | TyCon -> Bool
isTupleTyCon TyCon
tc     = RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
mkTupleTyCon
      | TyCon -> Bool
isAlgTyCon TyCon
tc       = RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
mkAlgTyCon
      | TyCon -> Bool
isPrimTyCon TyCon
tc      = RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
mkPrimTyCon
      | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tYPETyConKey = RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
mkSuperKindTyCon
      | Bool
otherwise           = RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
mkVoidTyCon
      where
        tcArity :: Int
tcArity = TyCon -> Int
tyConArity TyCon
tc

        mkAlgTyCon :: RWST SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan 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 -> let instances :: [FamInst]
instances = FamInstEnvs -> TyCon -> [FamInst]
familyInstances FamInstEnvs
fiEnvs TyCon
tc
                       in  (FamInst
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity ([Type], Type))
-> [FamInst]
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity ([Type], Type))
-> [CoAxBranch]
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
-> RWST
     SrcSpan 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 SrcSpan 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
  SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> ([Type], Type))
-> C2C Type
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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)
          AlgTyConRhs
tcDc   <- (DataCon -> AlgTyConRhs)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
-> RWST SrcSpan 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]
:[])) (RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity AlgTyConRhs)
-> (TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon)
-> TyCon
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon (DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon)
-> (TyCon -> DataCon)
-> TyCon
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataCon] -> DataCon
forall a. [a] -> a
head ([DataCon] -> DataCon) -> (TyCon -> [DataCon]) -> TyCon -> DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons (TyCon
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity AlgTyConRhs)
-> TyCon
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall a b. (a -> b) -> a -> b
$ TyCon
tc
          TyCon -> RWST SrcSpan 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
            }

        mkPrimTyCon :: RWST SrcSpan 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 SrcSpan 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
            }

        mkSuperKindTyCon :: RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
mkSuperKindTyCon = 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
          TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return SuperKindTyCon :: Int -> Name TyCon -> TyCon
C.SuperKindTyCon
                   { 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
                   }

        mkVoidTyCon :: RWST SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity ([Type], Type)
famInstToSubst FamInst
fi = do
          [Type]
tys <- (Type -> C2C Type)
-> [Type] -> RWST SrcSpan 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 SrcSpan 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
#if MIN_VERSION_ghc(8,6,0)
  DataTyCon [DataCon]
dcs Int
_ Bool
_ -> 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 SrcSpan SrcSpanRB GHC2CoreState Identity [DataCon]
-> C2C (Maybe AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon)
-> [DataCon]
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon [DataCon]
dcs
#else
  DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#endif
#if MIN_VERSION_ghc(8,6,0)
  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 SrcSpan SrcSpanRB GHC2CoreState Identity [DataCon]
-> C2C (Maybe AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon)
-> [DataCon]
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon [DataCon]
dcs
#else
  SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#endif

#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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
-> RWST
     SrcSpan
     SrcSpanRB
     GHC2CoreState
     Identity
     (([TyVar], Type) -> AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc
                                                           RWST
  SrcSpan
  SrcSpanRB
  GHC2CoreState
  Identity
  (([TyVar], Type) -> AlgTyConRhs)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity ([TyVar], Type)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ((,) ([TyVar] -> Type -> ([TyVar], Type))
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [TyVar]
-> RWST
     SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> ([TyVar], Type))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar] -> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar [TyVar]
rhsTvs
                                                                    RWST
  SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> ([TyVar], Type))
-> C2C Type
-> RWST SrcSpan 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 -> SrcSpan -> 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
noSrcSpan
                                  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.Class.BitPack.packXWith" [CoreExpr]
args
          | [CoreExpr
_nTy,CoreExpr
_aTy,CoreExpr
_kn,CoreExpr
f] <- [CoreExpr]
args
          = CoreExpr -> C2C Term
term CoreExpr
f
        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 SrcSpan SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TickInfo
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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.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
    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 SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
x RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
e
        Id
x' <- SrcSpan
-> TyVar -> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
e1
      Id
x'  <- SrcSpan
-> TyVar -> RWST SrcSpan 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 ([LetBinding] -> Term -> Term
C.Letrec [(Id
x', Term
e1')] Term
e2')

    term' (Let (Rec [(TyVar, CoreExpr)]
xes) CoreExpr
e) = do
      [LetBinding]
xes' <- ((TyVar, CoreExpr)
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity LetBinding)
-> [(TyVar, CoreExpr)]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [LetBinding]
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 SrcSpan SrcSpanRB GHC2CoreState Identity LetBinding
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 ([LetBinding] -> Term -> Term
C.Letrec [LetBinding]
xes' Term
e')
     where
      go :: (TyVar, CoreExpr)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity LetBinding
go (TyVar
x,CoreExpr
b) = do
        (Term
b',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
b
        Id
x' <- SrcSpan
-> TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
x
        LetBinding
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity LetBinding
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id
x',Term
b')

    term' (Case CoreExpr
_ TyVar
_ Type
ty [])  =
      Term -> Type -> Term
C.TyApp (PrimInfo -> Term
C.Prim (Text -> Type -> WorkInfo -> IsMultiPrim -> PrimInfo
C.PrimInfo ([Char] -> Text
pack [Char]
"EmptyCase") Type
C.undefinedTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult))
        (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
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 SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
b) CoreExpr
e
     Id
b'  <- SrcSpan
-> TyVar -> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity [Alt] -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt)
-> [Alt TyVar]
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity Alt
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt
forall a. SrcSpan -> C2C a -> C2C a
addUsefull SrcSpan
sp (RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt)
-> (Alt TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt)
-> Alt TyVar
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> Alt TyVar -> RWST SrcSpan 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 ([LetBinding] -> Term -> Term
C.Letrec [(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
     SrcSpan 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
  SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> Type -> Term)
-> C2C Type
-> RWST SrcSpan 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 SrcSpan 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,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 -> PrimInfo
C.PrimInfo ([Char] -> Text
pack [Char]
"_TY_") Type
C.undefinedTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult))
        (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 -> PrimInfo
C.PrimInfo ([Char] -> Text
pack [Char]
"_CO_") Type
C.undefinedTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult))
        (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 SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP SrcSpan
sp = ((Term, SrcSpanRB) -> (Term, SrcSpan))
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
-> RWST SrcSpan 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 (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second SrcSpanRB -> SrcSpan
unSrcSpanRB) (RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan))
-> (CoreExpr
    -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB))
-> CoreExpr
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C2C Term
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
RWS.listen (C2C Term
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB))
-> (CoreExpr -> C2C Term)
-> CoreExpr
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp = (SrcSpan -> SrcSpan)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
RWS.local (\SrcSpan
r -> if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
sp then SrcSpan
sp else SrcSpan
r) (RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id)
-> (TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id)
-> TyVar
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> RWST SrcSpan 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 -> 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)
            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 <- RWST SrcSpan SrcSpanRB GHC2CoreState Identity SrcSpan
forall r (m :: Type -> Type). MonadReader r m => m r
RWS.ask
                            (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]
++ DynFlags -> TyVar -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags 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]
++ DynFlags -> TyVar -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags TyVar
x)
              else DataCon -> Term
C.Data (DataCon -> Term)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
-> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> RWST SrcSpan 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.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.Class.BitPack.packXWith"    -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> Term
packXWithTerm 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)
              | Bool
otherwise -> Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (PrimInfo -> Term
C.Prim (Text -> Type -> WorkInfo -> IsMultiPrim -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult))
            Just (Just (BlackBox {workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
workInfo = WorkInfo
wi})) ->
              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 -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult)
            Just (Just (BlackBoxHaskell {workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
workInfo = WorkInfo
wi})) ->
              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 -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
wi IsMultiPrim
C.SingleResult)
            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 -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
C.WorkVariable IsMultiPrim
C.SingleResult)
            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 -> PrimInfo
C.PrimInfo Text
xNameS Type
xType WorkInfo
C.WorkVariable IsMultiPrim
C.SingleResult))
              | Bool
otherwise
              -> Id -> Term
C.Var (Id -> Term)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToId TyVar
x

    alt :: SrcSpan
-> Alt TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt
alt SrcSpan
_   (AltCon
DEFAULT   , [TyVar]
_ , CoreExpr
e) = (Pat
C.DefaultPat,) (Term -> Alt)
-> C2C Term -> RWST SrcSpan 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 SrcSpan 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
      ([TyVar]
tyvs,[TyVar]
tmvs) -> do
        (Term
e',SrcSpan
sp1) <- SrcSpan
-> CoreExpr
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP SrcSpan
sp0 CoreExpr
e
        (,) (Pat -> Term -> Alt)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Pat
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
-> RWST
     SrcSpan SrcSpanRB GHC2CoreState Identity ([TyVar] -> [Id] -> Pat)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc
                           RWST
  SrcSpan SrcSpanRB GHC2CoreState Identity ([TyVar] -> [Id] -> Pat)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [TyVar]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity ([Id] -> Pat)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar] -> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar [TyVar]
tyvs
                           RWST SrcSpan SrcSpanRB GHC2CoreState Identity ([Id] -> Pat)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Id]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Pat
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id)
-> [TyVar] -> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp1) [TyVar]
tmvs)
            RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term -> Alt)
-> C2C Term -> RWST SrcSpan 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
      Literal
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(8,6,0)
#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
        LitNumType
LitNumInteger -> Integer -> Literal
C.IntegerLiteral Integer
i
        LitNumType
LitNumNatural -> Integer -> Literal
C.NaturalLiteral Integer
i
        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
#else
      MachInt    i   -> C.IntLiteral i
      MachInt64  i   -> C.IntLiteral i
      MachWord   i   -> C.WordLiteral i
      MachWord64 i   -> C.WordLiteral i
      LitInteger i _ -> C.IntegerLiteral i
#endif
#if MIN_VERSION_ghc(8,8,0)
      LitFloat Rational
r    -> Rational -> Literal
C.FloatLiteral Rational
r
      LitDouble Rational
r   -> Rational -> Literal
C.DoubleLiteral 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 r
      MachDouble r   -> C.DoubleLiteral 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 <- (SrcSpan -> SrcSpan) -> C2C a -> C2C a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
RWS.local (SrcSpan -> SrcSpan -> SrcSpan
forall a b. a -> b -> a
const SrcSpan
x) C2C a
m
          SrcSpanRB -> RWST SrcSpan 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 (SrcSpan -> SrcSpan) -> C2C a -> C2C a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
RWS.local (SrcSpan -> SrcSpan -> SrcSpan
forall a b. a -> b -> a
const 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 SrcSpan SrcSpanRB GHC2CoreState Identity [Maybe Type]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity [Maybe Type]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity [Maybe Type]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST SrcSpan 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(8,6,0)
hasPrimCo (NthCo Role
_ Int
_ Coercion
co)  = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
#else
hasPrimCo (NthCo _ co)  = hasPrimCo 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 SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
mkDc Type
dcTy [Type]
repTys
  where
    mkDc :: Type
-> [Type] -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
mkDc Type
dcTy [Type]
repTys = do
#if 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 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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar] -> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar (DataCon -> [TyVar]
dataConUnivTyVars DataCon
dc)
#if MIN_VERSION_ghc(8,8,0)
      [TyVar]
eTvs <- (TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar] -> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar (DataCon -> [TyVar]
dataConExTyCoVars DataCon
dc)
#else
      eTvs <- mapM coreToTyVar (dataConExTyVars dc)
#endif
      DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon)
-> DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
forall a b. (a -> b) -> a -> b
$ MkData :: Name DataCon
-> Int
-> Int
-> Type
-> [TyVar]
-> [TyVar]
-> [Type]
-> [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
             , dcUnivTyVars :: [TyVar]
C.dcUnivTyVars  = [TyVar]
uTvs
             , dcExtTyVars :: [TyVar]
C.dcExtTyVars   = [TyVar]
eTvs
             , dcFieldLabels :: [Text]
C.dcFieldLabels = [Text]
fLabels
             }

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 SrcSpan 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 SrcSpan 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

_ATTR_NAME :: String
_ATTR_NAME :: [Char]
_ATTR_NAME = [Char]
"Clash.Annotations.SynthesisAttributes.Attr"

-- | Flatten a list type structure to a list of types.
listTypeToListOfTypes :: Type -> [Type]
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
_                       = []

-- | 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:"
                  , DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags 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:"
                                  , DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags Type
s ]

-- | 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:"
                                   , DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags Type
s ]

-- | Try to interpret a Type as an Attr
coreToAttr
  :: Type
  -> C2C C.Attr'
coreToAttr :: Type -> C2C Attr'
coreToAttr (TyConApp TyCon
ty [Type]
args) = do
  let key :: Type
key   = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
0
  let value :: Type
value = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
1
  [Char]
name' <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty
  case [Char]
name' of
    [Char]
"Clash.Annotations.SynthesisAttributes.StringAttr" ->
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Attr'
C.StringAttr' (Type -> [Char]
tyLitToString Type
key) (Type -> [Char]
tyLitToString Type
value)
    [Char]
"Clash.Annotations.SynthesisAttributes.IntegerAttr" ->
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> Integer -> Attr'
C.IntegerAttr' (Type -> [Char]
tyLitToString Type
key) (Type -> Integer
tyLitToInteger Type
value)
    [Char]
"Clash.Annotations.SynthesisAttributes.BoolAttr" -> do
        Bool
bool <- Type -> C2C Bool
boolTypeToBool Type
value
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool -> Attr'
C.BoolAttr' (Type -> [Char]
tyLitToString Type
key) Bool
bool
    [Char]
"Clash.Annotations.SynthesisAttributes.Attr" ->
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> Attr'
C.Attr' (Type -> [Char]
tyLitToString Type
key)
    [Char]
_ ->
        [Char] -> C2C Attr'
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C Attr') -> [Char] -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Expected StringAttr, IntegerAttr, BoolAttr or Attr"
                        , [Char]
"constructor, got:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name' ]

coreToAttr Type
t =
  [Char] -> C2C Attr'
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C Attr') -> [Char] -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Expected type constructor (TyConApp), but got:"
                  , DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags Type
t ]

coreToAttrs'
    :: [Type]
    -> C2C [C.Attr']
coreToAttrs' :: [Type] -> C2C [Attr']
coreToAttrs' [Type
annotationType, Type
realType, Type
attributes] = C2C [Attr']
allAttrs
 where
  allAttrs :: C2C [Attr']
allAttrs = [Attr'] -> [Attr'] -> [Attr']
forall a. [a] -> [a] -> [a]
(++) ([Attr'] -> [Attr'] -> [Attr'])
-> C2C [Attr']
-> RWST
     SrcSpan SrcSpanRB GHC2CoreState Identity ([Attr'] -> [Attr'])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> C2C [Attr']
attrs RWST SrcSpan SrcSpanRB GHC2CoreState Identity ([Attr'] -> [Attr'])
-> C2C [Attr'] -> C2C [Attr']
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> C2C [Attr']
subAttrs

  subAttrs :: C2C [Attr']
subAttrs =
    Type -> C2C [Attr']
coreToAttrs Type
realType

  attrs :: C2C [Attr']
attrs =
    case Type
annotationType of
      TyConApp TyCon
ty [TyConApp TyCon
ty' [Type]
_args'] -> do
        [Char]
name'  <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty
        [Char]
name'' <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty'

        let result :: C2C [Attr']
result | [Char]
name' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"GHC.Types.[]" Bool -> Bool -> Bool
&& [Char]
name'' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
_ATTR_NAME =
                      -- List of attributes
                      [C2C Attr'] -> C2C [Attr']
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([C2C Attr'] -> C2C [Attr']) -> [C2C Attr'] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ (Type -> C2C Attr') -> [Type] -> [C2C Attr']
forall a b. (a -> b) -> [a] -> [b]
map Type -> C2C Attr'
coreToAttr (Type -> [Type]
listTypeToListOfTypes Type
attributes)
                   | [Char]
name' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"GHC.Types.[]" =
                      -- List, but unknown types
                      [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [ [Char]
"Annotate expects an"
                                                   , [Char]
"Attr or a list of"
                                                   , [Char]
"Attr's, but got a list"
                                                   , [Char]
"of:", [Char]
name'']
                   | Bool
otherwise =
                        -- Some unknown nested type
                      [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [ [Char]
"Annotate expects an"
                                                   , [Char]
"Attr or a list of"
                                                   , [Char]
"Attr's, but got:"
                                                   , [Char]
name' ]

        C2C [Attr']
result

      TyConApp TyCon
ty [Type]
_args -> do
        [Char]
name' <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty
        if [Char]
name' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
_ATTR_NAME
          then
            -- Single annotation
            [C2C Attr'] -> C2C [Attr']
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Type -> C2C Attr'
coreToAttr Type
attributes]
          else do
            -- Annotation to something we don't recognize (not a list,
            -- nor an Attr)
            [Char]
tystr <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty
            [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Annotate expects an Attr or a list of Attr's,"
                            , [Char]
"but got:", [Char]
tystr ]
      Type
_ ->
        [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [ [Char]
"Expected TyConApp, not:"
                                     , DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags Type
annotationType]

coreToAttrs' [Type]
illegal =
  [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected list with three items (as Annotate has three arguments), but got: "
      [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 (DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags) [Type]
illegal)

-- | If this type has an annotate type synonym, return list of attributes.
coreToAttrs
  :: Type
  -> C2C [C.Attr']
coreToAttrs :: Type -> C2C [Attr']
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
== [Char]
"Clash.Annotations.SynthesisAttributes.Annotate"
    then
      [Type] -> C2C [Attr']
coreToAttrs' [Type]
kindsOrTypes
    else
      [Attr'] -> C2C [Attr']
forall (m :: Type -> Type) a. Monad m => a -> m a
return []

coreToAttrs Type
_ =
    [Attr'] -> C2C [Attr']
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']
attrs <- Type -> C2C [Attr']
coreToAttrs Type
ty
  case [Attr']
attrs of
    [] -> Type -> C2C Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return Type
cty
    [Attr']
_  -> 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'] -> Type -> Type
C.AnnType [Attr']
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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar -> C2C Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv
coreToType' (TyConApp TyCon
tc [Type]
args)
  | 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 SrcSpan 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 SrcSpan 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
  | 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
                      Just ([(TyVar, Type)]
substs,Type
synTy,[Type]
remArgs) -> do
                        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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan 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.extendUniqMap Name TyCon
tcName TyCon
tc)
                        Name TyCon -> [Type] -> Type
C.mkTyConApp (Name TyCon -> [Type] -> Type)
-> C2C (Name TyCon)
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
-> RWST SrcSpan 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 SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv RWST SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan 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 SrcSpan 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' 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]
++ DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags 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]
++ DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags 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)

coreToTyVar :: TyVar
            -> C2C C.TyVar
coreToTyVar :: TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv =
  Type -> TyName -> TyVar
C.mkTyVar (Type -> TyName -> TyVar)
-> C2C Type
-> RWST SrcSpan 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 SrcSpan SrcSpanRB GHC2CoreState Identity (TyName -> TyVar)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyName
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyName
forall a. TyVar -> C2C (Name a)
coreToVar TyVar
tv

coreToId :: Id
         -> C2C C.Id
coreToId :: TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
coreToId TyVar
i = do
  Type -> IdScope -> Name Term -> Id
C.mkId (Type -> IdScope -> Name Term -> Id)
-> C2C Type
-> RWST
     SrcSpan
     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
  SrcSpan
  SrcSpanRB
  GHC2CoreState
  Identity
  (IdScope -> Name Term -> Id)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity IdScope
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Name Term -> Id)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IdScope -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity IdScope
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure IdScope
scope RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Name Term -> Id)
-> C2C (Name Term)
-> RWST SrcSpan 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 <- RWST SrcSpan SrcSpanRB GHC2CoreState Identity SrcSpan
forall r (m :: Type -> Type). MonadReader r m => m r
RWS.ask
  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))) =
    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))))))
  where
    (C.FunTy Type
_ Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
aTy Type
bTy)   = Type -> TypeView
C.tyView Type
funTy''
    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

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)) =
    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)))
  where
    (C.FunTy Type
_ Type
saTy) = Type -> TypeView
C.tyView Type
funTy
    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

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))) =
    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))))))
  where
    (C.FunTy Type
_ Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
saTy Type
sbTy)   = Type -> TypeView
C.tyView Type
funTy''
    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

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))) =
    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))))
  where
    (C.FunTy Type
_ Type
vsTy) = Type -> TypeView
C.tyView Type
funTy
    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

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)))) =
    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))))))))
  where
    (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
    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

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
dollarTerm :: Type -> Term
dollarTerm (C.ForAllTy TyVar
rTV (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV Type
funTy))) =
    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))))))
  where
    (C.FunTy Type
fTy Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
aTy Type
_)       = Type -> TypeView
C.tyView Type
funTy''
    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

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 a. Show a => a -> [Char]
show 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) =
  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))))
  where
    (C.FunTy Type
callStackTy Type
fTy) = Type -> TypeView
C.tyView Type
funTy
    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

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) =
  TyVar -> Term -> Term
C.TyLam TyVar
aTV (
  Id -> Term -> Term
C.Lam   Id
xId (
  Id -> Term
C.Var Id
xId))
  where
    (C.FunTy Type
xTy Type
_) = Type -> TypeView
C.tyView Type
funTy
    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

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)) =
  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 -> PrimInfo
C.PrimInfo Text
rwNm Type
rwTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult))))))
  where
    (C.FunTy Type
fTy Type
_)  = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
rwTy Type
_) = Type -> TypeView
C.tyView Type
fTy
    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#"

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 => (a -> BitVector n) -> a -> BitVector n@
--
-- Generate the term:
--
-- @/\(n:Nat)./\(a:TYPE r).\(kn:KnownNat n).\(f:a -> BitVector n).f@
packXWithTerm
  :: C.Type
  -> C.Term
packXWithTerm :: Type -> Term
packXWithTerm (C.ForAllTy TyVar
nTV (C.ForAllTy TyVar
aTV Type
funTy)) =
  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
fId (
  Id -> Term
C.Var Id
fId))))
  where
    C.FunTy Type
knTy Type
rTy = Type -> TypeView
C.tyView Type
funTy
    C.FunTy Type
fTy Type
_    = Type -> TypeView
C.tyView Type
rTy
    knName :: Name a
knName           = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"kn" Int
0
    fName :: Name a
fName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
1
    knId :: Id
knId             = Type -> Name Term -> Id
C.mkLocalId Type
knTy Name Term
forall a. Name a
knName
    fId :: Id
fId              = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName

packXWithTerm 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)) =
  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)))))
  where
    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
    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

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)) =
  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)))))
  where
    (C.FunTy Type
xTy Type
_)  = Type -> TypeView
C.tyView Type
funTy
    -- 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

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) =
  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)))
  where
    (C.FunTy Type
ctxTy Type
rTy) = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
xTy Type
_)     = Type -> TypeView
C.tyView Type
rTy
    -- 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

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