{-|
  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  #-}
{-# LANGUAGE TupleSections    #-}
{-# LANGUAGE ViewPatterns     #-}

{-# 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.Lazy      (RWS)
import qualified Control.Monad.RWS.Lazy      as RWS
import qualified Data.ByteString.Char8       as Char8
import           Data.Hashable               (Hashable (..))
import           Data.HashMap.Lazy           (HashMap)
import qualified Data.HashMap.Lazy           as HashMap
import qualified Data.HashMap.Strict         as HSM
import           Data.Maybe                  (catMaybes,fromMaybe,listToMaybe)
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif
import           Data.Text                   (Text, isInfixOf,pack)
import qualified Data.Text                   as Text
import           Data.Text.Encoding          (decodeUtf8)
import qualified Data.Traversable            as T

-- GHC API
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)
import FastString (unpackFS, fastStringToByteString)
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)
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)

-- 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 s :: 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
HSM.empty

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

instance Semigroup SrcSpanRB where
  (SrcSpanRB l :: SrcSpan
l) <> :: SrcSpanRB -> SrcSpanRB -> SrcSpanRB
<> (SrcSpanRB r :: 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 hm :: GHC2CoreState
hm fiEnvs :: FamInstEnvs
fiEnvs = GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go GHC2CoreState
hm GHC2CoreState
hm
  where
    go :: GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go old :: GHC2CoreState
old new :: 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
        (tcm :: UniqMap TyCon
tcm,old' :: GHC2CoreState
old', _) = 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 :: * -> *) (m :: * -> *) 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 fiEnvs :: FamInstEnvs
fiEnvs tc :: 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 tcRhs :: AlgTyConRhs
tcRhs ->
              TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return
                $WAlgTyCon :: 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
                }
            Nothing -> TyCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: * -> *) 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
            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 :: * -> *) (m :: * -> *) 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 cx :: 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\b :: CoAxBranch
b -> (,) ([Type] -> Type -> ([Type], Type))
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
-> RWST
     SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> ([Type], Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> C2C Type)
-> [Type] -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return
            $WFunTyCon :: 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 :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return
            $WAlgTyCon :: 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 :: * -> *) a. Monad m => a -> m a
return
            $WPrimTyCon :: 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 :: * -> *) a. Monad m => a -> m a
return $WSuperKindTyCon :: 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 :: * -> *) 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 fi :: FamInst
fi = do
          [Type]
tys <- (Type -> C2C Type)
-> [Type] -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([Type]
tys,Type
ty)

makeAlgTyConRhs :: AlgTyConRhs
                -> C2C (Maybe C.AlgTyConRhs)
makeAlgTyConRhs :: AlgTyConRhs -> C2C (Maybe AlgTyConRhs)
makeAlgTyConRhs algTcRhs :: AlgTyConRhs
algTcRhs = case AlgTyConRhs
algTcRhs of
#if MIN_VERSION_ghc(8,6,0)
  DataTyCon dcs :: [DataCon]
dcs _ _ -> AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> ([DataCon] -> AlgTyConRhs) -> [DataCon] -> Maybe AlgTyConRhs
forall (f :: * -> *) 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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 dcs :: [DataCon]
dcs _ -> AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> ([DataCon] -> AlgTyConRhs) -> [DataCon] -> Maybe AlgTyConRhs
forall (f :: * -> *) 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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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
  NewTyCon dc :: DataCon
dc _ (rhsTvs :: [TyVar]
rhsTvs,rhsEtad :: Type
rhsEtad) _ -> AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity AlgTyConRhs
-> C2C (Maybe AlgTyConRhs)
forall (f :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 "Cannot handle tuple tycons"

coreToTerm
  :: CompiledPrimMap
  -> [Var]
  -> CoreExpr
  -> C2C C.Term
coreToTerm :: CompiledPrimMap -> [TyVar] -> CoreExpr -> C2C Term
coreToTerm primMap :: CompiledPrimMap
primMap unlocs :: [TyVar]
unlocs = CoreExpr -> C2C Term
term
  where
    term :: CoreExpr -> C2C C.Term
    term :: CoreExpr -> C2C Term
term e :: CoreExpr
e
      | (Var x :: TyVar
x,args :: [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e
      , let (nm :: Text
nm, _) = 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
forall a. (Eq a, IsString a) => a -> [CoreExpr] -> C2C Term
go Text
nm [CoreExpr]
args
      | Bool
otherwise
      = CoreExpr -> C2C Term
term' CoreExpr
e
      where
        -- Remove most Signal transformers
        go :: a -> [CoreExpr] -> C2C Term
go "Clash.Signal.Internal.mapSignal#"  args :: [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
!!3) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!4))
        go "Clash.Signal.Internal.signal#"     args :: [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3
          = CoreExpr -> C2C Term
term ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!2)
        go "Clash.Signal.Internal.appSignal#"  args :: [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
!!3) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!4))
        go "Clash.Signal.Internal.joinSignal#" args :: [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3
          = CoreExpr -> C2C Term
term ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!2)
        go "Clash.Signal.Bundle.vecBundle#"    args :: [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4
          = CoreExpr -> C2C Term
term ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!3)
        --- Remove `$`
        go "GHC.Base.$"                        args :: [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
!!3) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!4))
        go "GHC.Magic.noinline"                args :: [CoreExpr]
args   -- noinline :: forall a. a -> a
          | [_ty :: CoreExpr
_ty, x :: CoreExpr
x] <- [CoreExpr]
args
          = CoreExpr -> C2C Term
term CoreExpr
x
        -- Remove most CallStack logic
        go "GHC.Stack.Types.PushCallStack"     args :: [CoreExpr]
args = CoreExpr -> C2C Term
term ([CoreExpr] -> CoreExpr
forall a. [a] -> a
last [CoreExpr]
args)
        go "GHC.Stack.Types.FreezeCallStack"   args :: [CoreExpr]
args = CoreExpr -> C2C Term
term ([CoreExpr] -> CoreExpr
forall a. [a] -> a
last [CoreExpr]
args)
        go "GHC.Stack.withFrozenCallStack"     args :: [CoreExpr]
args
          | [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
!!2) ([CoreExpr]
args[CoreExpr] -> Int -> CoreExpr
forall a. [a] -> Int -> a
!!1))
        go "Clash.Class.BitPack.packXWith" args :: [CoreExpr]
args
          | [_nTy :: CoreExpr
_nTy,_aTy :: CoreExpr
_aTy,_kn :: CoreExpr
_kn,f :: CoreExpr
f] <- [CoreExpr]
args
          = CoreExpr -> C2C Term
term CoreExpr
f
        go "Clash.Sized.BitVector.Internal.checkUnpackUndef" args :: [CoreExpr]
args
          | [_nTy :: CoreExpr
_nTy,_aTy :: CoreExpr
_aTy,_kn :: CoreExpr
_kn,_typ :: CoreExpr
_typ,f :: CoreExpr
f] <- [CoreExpr]
args
          = CoreExpr -> C2C Term
term CoreExpr
f
        go "Clash.Magic.prefixName" args :: [CoreExpr]
args
          | [Type nmTy :: Type
nmTy,_aTy :: CoreExpr
_aTy,f :: 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go "Clash.Magic.suffixName" args :: [CoreExpr]
args
          | [Type nmTy :: Type
nmTy,_aTy :: CoreExpr
_aTy,f :: 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f
        go "Clash.Magic.setName" args :: [CoreExpr]
args
          | [Type nmTy :: Type
nmTy,_aTy :: CoreExpr
_aTy,f :: 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
f

        go _ _ = CoreExpr -> C2C Term
term' CoreExpr
e
    term' :: CoreExpr -> C2C Term
term' (Var x :: TyVar
x)                 = TyVar -> C2C Term
var TyVar
x
    term' (Lit l :: Literal
l)                 = Term -> C2C Term
forall (m :: * -> *) 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 eFun :: CoreExpr
eFun (Type tyArg :: Type
tyArg)) = Term -> Type -> Term
C.TyApp (Term -> Type -> Term)
-> C2C Term
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> Term)
forall (f :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
tyArg
    term' (App eFun :: CoreExpr
eFun eArg :: CoreExpr
eArg)         = Term -> Term -> Term
C.App   (Term -> Term -> Term)
-> C2C Term
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
eArg
    term' (Lam x :: TyVar
x e :: 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 :: * -> *) 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 :: * -> *) 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
        (e' :: Term
e',sp :: 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 :: * -> *) a. Monad m => a -> m a
return (Id -> Term -> Term
C.Lam  Id
x' Term
e')
    term' (Let (NonRec x :: TyVar
x e1 :: CoreExpr
e1) e2 :: CoreExpr
e2)  = do
      (e1' :: Term
e1',sp :: 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 :: * -> *) a. Monad m => a -> m a
return ([LetBinding] -> Term -> Term
C.Letrec [(Id
x', Term
e1')] Term
e2')

    term' (Let (Rec xes :: [(TyVar, CoreExpr)]
xes) e :: CoreExpr
e) = do
      [LetBinding]
xes' <- ((TyVar, CoreExpr)
 -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity LetBinding)
-> [(TyVar, CoreExpr)]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [LetBinding]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) 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 (x :: TyVar
x,b :: CoreExpr
b) = do
        (b' :: Term
b',sp :: 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 :: * -> *) a. Monad m => a -> m a
return (Id
x',Term
b')

    term' (Case _ _ ty :: Type
ty [])  = Term -> Type -> Term
C.TyApp (Text -> PrimInfo -> Term
C.Prim ([Char] -> Text
pack "EmptyCase") (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
C.undefinedTy WorkInfo
C.WorkNever))
                                (Type -> Term) -> C2C Type -> C2C Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
ty
    term' (Case e :: CoreExpr
e b :: TyVar
b ty :: Type
ty alts :: [Alt TyVar]
alts) = do
     let usesBndr :: Bool
usesBndr = (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) 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
     (e' :: Term
e',sp :: 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 v :: Term
v =
             Term -> Type -> [Alt] -> Term
C.Case Term
v Type
ty' ([Alt] -> Term)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Alt] -> C2C Term
forall (f :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) 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 e :: CoreExpr
e co :: Coercion
co) = do
      let (Pair ty1 :: Type
ty1 ty2 :: Type
ty2) = Coercion -> Pair Type
coercionKind Coercion
co
      Maybe Type
hasPrimCoM <- Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
      Bool
ty1_I <- Type -> C2C Bool
isIntegerTy Type
ty1
      Bool
ty2_I <- Type -> C2C Bool
isIntegerTy Type
ty2
      case Maybe Type
hasPrimCoM of
        Just _ | Bool
ty1_I Bool -> Bool -> Bool
|| Bool
ty2_I
          -> Term -> Type -> Type -> Term
C.Cast (Term -> Type -> Type -> Term)
-> C2C Term
-> RWST
     SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> Type -> Term)
forall (f :: * -> *) 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 :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
ty2
        _ -> CoreExpr -> C2C Term
term CoreExpr
e
    term' (Tick (SourceNote rsp :: RealSrcSpan
rsp _) e :: CoreExpr
e) =
      TickInfo -> Term -> Term
C.Tick (SrcSpan -> TickInfo
C.SrcSpan (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
rsp)) (Term -> Term) -> C2C Term -> C2C Term
forall (f :: * -> *) 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)
    term' (Tick _ e :: CoreExpr
e)        = CoreExpr -> C2C Term
term CoreExpr
e
    term' (Type t :: Type
t)          = Term -> Type -> Term
C.TyApp (Text -> PrimInfo -> Term
C.Prim ([Char] -> Text
pack "_TY_") (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
C.undefinedTy WorkInfo
C.WorkNever)) (Type -> Term) -> C2C Type -> C2C Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                Type -> C2C Type
coreToType Type
t
    term' (Coercion co :: Coercion
co)     = Term -> Type -> Term
C.TyApp (Text -> PrimInfo -> Term
C.Prim ([Char] -> Text
pack "_CO_") (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
C.undefinedTy WorkInfo
C.WorkNever)) (Type -> Term) -> C2C Type -> C2C Term
forall (f :: * -> *) 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 sp :: SrcSpan
sp = ((Term, SrcSpanRB) -> (Term, SrcSpan))
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpanRB)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SrcSpanRB -> SrcSpan) -> (Term, SrcSpanRB) -> (Term, SrcSpan)
forall (a :: * -> * -> *) 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 :: * -> *) 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 sp :: SrcSpan
sp = (SrcSpan -> SrcSpan)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
RWS.local (\r :: 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 nm :: 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 :: * -> *) 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 x :: 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 dc :: DataCon
dc -> case Text -> Maybe (Maybe CompiledPrimitive)
lookupPrim Text
xNameS of
            Just p :: Maybe CompiledPrimitive
p  -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ Text -> PrimInfo -> Term
C.Prim Text
xNameS (Type -> WorkInfo -> PrimInfo
C.PrimInfo 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))
            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 :: * -> *). MonadReader r m => m r
RWS.ask
                            (SrcSpanRB -> SrcSpanRB) -> C2C Term -> C2C Term
forall w (m :: * -> *) 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))
                          NoUnfolding -> [Char] -> C2C Term
forall a. HasCallStack => [Char] -> a
error ("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)
                          _ -> [Char] -> C2C Term
forall a. HasCallStack => [Char] -> a
error ("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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc
          Nothing -> case Text -> Maybe (Maybe CompiledPrimitive)
lookupPrim Text
xNameS of
            Just (Just (Primitive f :: Text
f wi :: WorkInfo
wi _))
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Signal.Internal.mapSignal#" -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
mapSignalTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Signal.Internal.signal#"    -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
signalTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Signal.Internal.appSignal#" -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
appSignalTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Signal.Internal.traverse#"  -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
traverseTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Signal.Internal.joinSignal#" -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
joinTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Signal.Bundle.vecBundle#"   -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
vecUnwrapTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "GHC.Base.$"                       -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
dollarTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "GHC.Stack.withFrozenCallStack"    -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
withFrozenCallStackTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "GHC.Magic.noinline"               -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
idTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "GHC.Magic.lazy"                   -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
idTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "GHC.Magic.runRW#"                 -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
runRWTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Class.BitPack.packXWith"    -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
packXWithTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Sized.Internal.BitVector.checkUnpackUndef" -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Term
checkUnpackUndefTerm Type
xType)
              | Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
pack "Clash.Magic.prefixName"
              -> Term -> C2C Term
forall (m :: * -> *) 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
== [Char] -> Text
pack "Clash.Magic.postfixName"
              -> Term -> C2C Term
forall (m :: * -> *) 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
== [Char] -> Text
pack "Clash.Magic.setName"
              -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (NameMod -> Type -> Term
nameModTerm NameMod
C.SetName Type
xType)
              | Bool
otherwise                                    -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> PrimInfo -> Term
C.Prim Text
xNameS (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
xType WorkInfo
wi))
            Just (Just (BlackBox {workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
workInfo = WorkInfo
wi})) ->
              Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ Text -> PrimInfo -> Term
C.Prim Text
xNameS (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
xType WorkInfo
wi)
            Just (Just (BlackBoxHaskell {workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
workInfo = WorkInfo
wi})) ->
              Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ Text -> PrimInfo -> Term
C.Prim Text
xNameS (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
xType WorkInfo
wi)
            Just Nothing ->
              -- Was guarded by "DontTranslate". We don't know yet if Clash will
              -- actually use it later on, so we don't err here.
              Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ Text -> PrimInfo -> Term
C.Prim Text
xNameS (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
xType WorkInfo
C.WorkAlways)
            Nothing
              | TyVar
x TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyVar]
unlocs
              -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> PrimInfo -> Term
C.Prim Text
xNameS (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
xType WorkInfo
C.WorkAlways))
              | [Char] -> Text
pack "$cshow" Text -> Text -> Bool
`isInfixOf` Text
xNameS
              -> Term -> C2C Term
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> PrimInfo -> Term
C.Prim Text
xNameS (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
xType WorkInfo
C.WorkAlways))
              | Bool
otherwise
              -> Id -> Term
C.Var (Id -> Term)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Id -> C2C Term
forall (f :: * -> *) 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 _   (DEFAULT   , _ , e :: CoreExpr
e) = (Pat
C.DefaultPat,) (Term -> Alt)
-> C2C Term -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
e
    alt _   (LitAlt l :: Literal
l  , _ , e :: CoreExpr
e) = (Literal -> Pat
C.LitPat (Literal -> Literal
coreToLiteral Literal
l),) (Term -> Alt)
-> C2C Term -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity Alt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
e
    alt sp0 :: SrcSpan
sp0 (DataAlt dc :: DataCon
dc, xs :: [TyVar]
xs, e :: CoreExpr
e) = case (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span TyVar -> Bool
isTyVar [TyVar]
xs of
      (tyvs :: [TyVar]
tyvs,tmvs :: [TyVar]
tmvs) -> do
        (e' :: Term
e',sp1 :: 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> C2C Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
e'

    coreToLiteral :: Literal
                  -> C.Literal
    coreToLiteral :: Literal -> Literal
coreToLiteral l :: Literal
l = case Literal
l of
#if MIN_VERSION_ghc(8,8,0)
      LitString  fs :: ByteString
fs  -> [Char] -> Literal
C.StringLiteral (ByteString -> [Char]
Char8.unpack ByteString
fs)
      LitChar    c :: Char
c   -> Char -> Literal
C.CharLiteral Char
c
      LitRubbish     ->
        [Char] -> Literal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Literal) -> [Char] -> Literal
forall a b. (a -> b) -> a -> b
$ "coreToTerm: Encountered LibRubbish. This is a bug in Clash. "
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ "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)
      LitNumber lt :: LitNumType
lt i :: Integer
i _ -> case LitNumType
lt of
        LitNumInteger -> Integer -> Literal
C.IntegerLiteral Integer
i
        LitNumNatural -> Integer -> Literal
C.NaturalLiteral Integer
i
        LitNumInt     -> Integer -> Literal
C.IntLiteral Integer
i
        LitNumInt64   -> Integer -> Literal
C.IntLiteral Integer
i
        LitNumWord    -> Integer -> Literal
C.WordLiteral Integer
i
        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 r :: Rational
r    -> Rational -> Literal
C.FloatLiteral Rational
r
      LitDouble r :: Rational
r   -> Rational -> Literal
C.DoubleLiteral Rational
r
      LitNullAddr   -> [Char] -> Literal
C.StringLiteral []
      LitLabel fs :: FastString
fs _ _ -> [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 x :: SrcSpan
x m :: C2C a
m =
  if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
x
  then do a
a <- (SrcSpan -> SrcSpan) -> C2C a -> C2C a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
RWS.local (SrcSpan -> SrcSpan -> SrcSpan
forall a b. a -> b -> a
const SrcSpan
x) C2C a
m
          SrcSpanRB -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
RWS.tell (SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
x)
          a -> C2C a
forall (m :: * -> *) 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 x :: SrcSpan
x m :: C2C a
m =
  if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
x
  then (SrcSpan -> SrcSpan) -> C2C a -> C2C a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
RWS.local (SrcSpan -> SrcSpan -> SrcSpan
forall a b. a -> b -> a
const SrcSpan
x) C2C a
m
  else C2C a
m

isIntegerTy :: Type -> C2C Bool
isIntegerTy :: Type -> C2C Bool
isIntegerTy (TyConApp tc :: TyCon
tc []) = do
  Text
tcNm <- Name -> C2C Text
qualifiedNameString (TyCon -> Name
tyConName TyCon
tc)
  Bool -> C2C Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Integer.Type.Integer")
isIntegerTy _ = Bool -> C2C Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

hasPrimCo :: Coercion -> C2C (Maybe Type)
hasPrimCo :: Coercion -> C2C (Maybe Type)
hasPrimCo (TyConAppCo _ _ coers :: [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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Maybe Type]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe [Type]
tcs)

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

hasPrimCo co :: Coercion
co@(AxiomInstCo _ _ coers :: [Coercion]
coers) = do
    let (Pair ty1 :: Type
ty1 _) = 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 :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Maybe Type]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) 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 tc :: TyCon
tc _) = do
      Text
tcNm <- Name -> C2C Text
qualifiedNameString (TyCon -> Name
tyConName TyCon
tc)
      Bool -> C2C Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
tcNm Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["Clash.Sized.Internal.BitVector.Bit"
                          ,"Clash.Sized.Internal.BitVector.BitVector"
                          ,"Clash.Sized.Internal.Index.Index"
                          ,"Clash.Sized.Internal.Signed.Signed"
                          ,"Clash.Sized.Internal.Unsigned.Unsigned"
                          ])
    isPrimTc _ = Bool -> C2C Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

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

hasPrimCo (AxiomRuleCo _ coers :: [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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coercion -> C2C (Maybe Type))
-> [Coercion]
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Maybe Type]
forall (t :: * -> *) (m :: * -> *) 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 :: * -> *) 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 _ _ co :: Coercion
co)  = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
#else
hasPrimCo (NthCo _ co)  = hasPrimCo co
#endif
hasPrimCo (LRCo _ co :: Coercion
co)   = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
hasPrimCo (InstCo co :: Coercion
co _) = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co
hasPrimCo (SubCo co :: Coercion
co)    = Coercion -> C2C (Maybe Type)
hasPrimCo Coercion
co

hasPrimCo _ = Maybe Type -> C2C (Maybe Type)
forall (m :: * -> *) 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 dc :: DataCon
dc = do
    [Type]
repTys <- (Type -> C2C Type)
-> [Type] -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType (DataCon -> [Type]
dataConRepArgTys DataCon
dc)
    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 dcTy :: Type
dcTy repTys :: [Type]
repTys = do
      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
fastStringToByteString (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
      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 :: * -> *) (m :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) 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
$ $WMkData :: 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 constructor :: 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 :: * -> *) 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 = "Clash.Annotations.SynthesisAttributes.Attr"

-- | Flatten a list type structure to a list of types.
listTypeToListOfTypes :: Type -> [Type]
listTypeToListOfTypes :: Type -> [Type]
listTypeToListOfTypes (TyConApp _ [_, a :: Type
a, as :: Type
as]) = Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
listTypeToListOfTypes Type
as
listTypeToListOfTypes _                       = []

-- | Try to determine boolean value by looking at constructor name of type.
boolTypeToBool :: Type -> C2C Bool
boolTypeToBool :: Type -> C2C Bool
boolTypeToBool (TyConApp constructor :: TyCon
constructor _args :: [Type]
_args) = do
  [Char]
constructorName <- TyCon -> C2C [Char]
typeConstructorToString TyCon
constructor
  Bool -> C2C Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> C2C Bool) -> Bool -> C2C Bool
forall a b. (a -> b) -> a -> b
$ case [Char]
constructorName of
    "GHC.Types.True"  -> Bool
True
    "GHC.Types.False" -> Bool
False
    _ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ "Expected boolean constructor, got:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
constructorName
boolTypeToBool s :: 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 [ "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 s :: FastString
s)) = FastString -> [Char]
unpackFS FastString
s
tyLitToString s :: Type
s = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ "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 n :: Integer
n)) = Integer
n
tyLitToInteger s :: Type
s = [Char] -> Integer
forall a. HasCallStack => [Char] -> a
error ([Char] -> Integer) -> [Char] -> Integer
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ "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 ty :: TyCon
ty args :: [Type]
args) = do
  let key :: Type
key   = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! 0
  let value :: Type
value = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! 1
  [Char]
name' <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty
  case [Char]
name' of
    "Clash.Annotations.SynthesisAttributes.StringAttr" ->
        Attr' -> C2C Attr'
forall (m :: * -> *) 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)
    "Clash.Annotations.SynthesisAttributes.IntegerAttr" ->
        Attr' -> C2C Attr'
forall (m :: * -> *) 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)
    "Clash.Annotations.SynthesisAttributes.BoolAttr" -> do
        Bool
bool <- Type -> C2C Bool
boolTypeToBool Type
value
        Attr' -> C2C Attr'
forall (m :: * -> *) 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
    "Clash.Annotations.SynthesisAttributes.Attr" ->
        Attr' -> C2C Attr'
forall (m :: * -> *) 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] -> C2C Attr'
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C Attr') -> [Char] -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ "Expected StringAttr, IntegerAttr, BoolAttr or Attr"
                        , "constructor, got:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name' ]

coreToAttr t :: 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 [ "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' [annotationType :: Type
annotationType, realType :: Type
realType, attributes :: 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 :: * -> *) 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 :: * -> *) 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 ty :: TyCon
ty [TyConApp ty' :: TyCon
ty' _args' :: [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
== "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 :: * -> *) (m :: * -> *) 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
== "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
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [ "Annotate expects an"
                                                   , "Attr or a list of"
                                                   , "Attr's, but got a list"
                                                   , "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
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [ "Annotate expects an"
                                                   , "Attr or a list of"
                                                   , "Attr's, but got:"
                                                   , [Char]
name' ]

        C2C [Attr']
result

      TyConApp ty :: TyCon
ty _args :: [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 :: * -> *) (m :: * -> *) 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 [ "Annotate expects an Attr or a list of Attr's,"
                            , "but got:", [Char]
tystr ]
      _ ->
        [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [ "Expected TyConApp, not:"
                                     , DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags Type
annotationType]

coreToAttrs' illegal :: [Type]
illegal =
  [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ "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
tycon kindsOrTypes :: [Type]
kindsOrTypes) = do
  [Char]
name' <- TyCon -> C2C [Char]
typeConstructorToString TyCon
tycon

  if [Char]
name' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Annotations.SynthesisAttributes.Annotate"
    then
      [Type] -> C2C [Attr']
coreToAttrs' [Type]
kindsOrTypes
    else
      [Attr'] -> C2C [Attr']
forall (m :: * -> *) a. Monad m => a -> m a
return []

coreToAttrs _ =
    [Attr'] -> C2C [Attr']
forall (m :: * -> *) 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 ty :: Type
ty cty :: Type
cty = do
  [Attr']
attrs <- Type -> C2C [Attr']
coreToAttrs Type
ty
  case [Attr']
attrs of
    [] -> Type -> C2C Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
cty
    _  -> Type -> C2C Type
forall (m :: * -> *) 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 ty :: Type
ty = C2C Type
ty'' C2C Type -> (Type -> C2C Type) -> C2C Type
forall (m :: * -> *) 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 ty' :: Type
ty' -> Type -> C2C Type
coreToType Type
ty'
        Nothing  -> Type -> C2C Type
coreToType' Type
ty

coreToType'
  :: Type
  -> C2C C.Type
coreToType' :: Type -> C2C Type
coreToType' (TyVarTy tv :: TyVar
tv) = TyVar -> Type
C.VarTy (TyVar -> Type)
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar -> C2C Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv
coreToType' (TyConApp tc :: TyCon
tc args :: [Type]
args)
  | TyCon -> Bool
isFunTyCon TyCon
tc = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> C2C Type)
-> [Type] -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: * -> *) (m :: * -> *) 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 (substs :: [(TyVar, Type)]
substs,synTy :: Type
synTy,remArgs :: [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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> C2C Type)
-> [Type] -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType [Type]
remArgs
                      _ -> 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 :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name TyCon -> C2C (Name TyCon)
forall (f :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> C2C Type)
-> [Type] -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: * -> *) (m :: * -> *) 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 tv :: TyVar
tv _) ty :: 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 :: * -> *) 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 :: * -> *) 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
coreToType' (FunTy ty1 :: Type
ty1 ty2 :: Type
ty2)             = Type -> Type -> Type
C.mkFunTy (Type -> Type -> Type)
-> C2C Type
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
ty2
coreToType' (LitTy tyLit :: TyLit
tyLit)    = Type -> C2C Type
forall (m :: * -> *) 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 ty1 :: Type
ty1 ty2 :: Type
ty2)  = Type -> Type -> Type
C.AppTy (Type -> Type -> Type)
-> C2C Type
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType' Type
ty2
coreToType' t :: Type
t@(CastTy _ _)   = [Char] -> C2C Type
forall a. HasCallStack => [Char] -> a
error ("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 _) = [Char] -> C2C Type
forall a. HasCallStack => [Char] -> a
error ("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 i :: Integer
i) = Integer -> LitTy
C.NumTy (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
i)
coreToTyLit (StrTyLit s :: 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 tv :: TyVar
tv =
  Type -> TyName -> TyVar
C.mkTyVar (Type -> TyName -> TyVar)
-> C2C Type
-> RWST SrcSpan SrcSpanRB GHC2CoreState Identity (TyName -> TyVar)
forall (f :: * -> *) 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 :: * -> *) 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 i :: 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 :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IdScope -> RWST SrcSpan SrcSpanRB GHC2CoreState Identity IdScope
forall (f :: * -> *) 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 :: * -> *) 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 toName :: b -> Name
toName toUnique :: b -> Unique
toUnique toString :: Name -> C2C Text
toString v :: 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)
      sort :: NameSort
sort | Text
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "ds" Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isPrefixOf "$" Text
ns
           = NameSort
C.System
           | Bool
otherwise
           = NameSort
C.User
  SrcSpan
locR <- RWST SrcSpan SrcSpanRB GHC2CoreState Identity SrcSpan
forall r (m :: * -> *). 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 :: * -> *) 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' n :: Name
n =
  Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "_INTERNAL_" (Name -> Maybe Text
modNameM Name
n) Text -> Text -> Text
`Text.append` ('.' 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 n :: Name
n =
  Name
-> Lens' GHC2CoreState (HashMap Name Text) -> C2C Text -> C2C Text
forall s (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "_INTERNAL_" (Name -> Maybe Text
modNameM Name
n) Text -> Text -> Text
`Text.append` ('.' 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 n :: Name
n =
  Name
-> Lens' GHC2CoreState (HashMap Name Text) -> C2C Text -> C2C Text
forall s (m :: * -> *) 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 :: * -> *) 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 (\modName :: Text
modName -> Text
modName Text -> Text -> Text
`Text.append` ('.' 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 n :: 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 :: * -> *) a. Monad m => a -> m a
return ([Char] -> Text
pack (ModuleName -> [Char]
moduleNameString ModuleName
moduleNm))

-- | 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 aTV :: TyVar
aTV (C.ForAllTy bTV :: TyVar
bTV (C.ForAllTy clkTV :: TyVar
clkTV funTy :: 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 _ funTy'' :: Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy aTy :: Type
aTy bTy :: Type
bTy)   = Type -> TypeView
C.tyView Type
funTy''
    fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "f" 0
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "x" 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 ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 clk. a -> Signal clk a@
--
-- Generate the term
--
-- @/\(a:*)./\(clk:Clock).\(x:Signal clk a).x@
signalTerm :: C.Type
           -> C.Term
signalTerm :: Type -> Term
signalTerm (C.ForAllTy aTV :: TyVar
aTV (C.ForAllTy clkTV :: TyVar
clkTV funTy :: Type
funTy)) =
    TyVar -> Term -> Term
C.TyLam TyVar
aTV (
    TyVar -> Term -> Term
C.TyLam TyVar
clkTV (
    Id -> Term -> Term
C.Lam   Id
xId (
    Id -> Term
C.Var   Id
xId)))
  where
    (C.FunTy _ aTy :: Type
aTy) = Type -> TypeView
C.tyView Type
funTy
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "x" 0
    xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
aTy Name Term
forall a. Name a
xName

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

-- | Given the type:
--
-- @
-- forall clk. forall a. forall b. Signal clk (a -> b) -> Signal clk a ->
-- Signal clk b
-- @
--
-- Generate the term:
--
-- @
-- /\(clk:Clock)./\(a:*)./\(b:*).\(f : (Signal clk a -> Signal clk b)).
-- \(x : Signal clk a).f x
-- @
appSignalTerm :: C.Type
              -> C.Term
appSignalTerm :: Type -> Term
appSignalTerm (C.ForAllTy clkTV :: TyVar
clkTV (C.ForAllTy aTV :: TyVar
aTV (C.ForAllTy bTV :: TyVar
bTV funTy :: Type
funTy))) =
    TyVar -> Term -> Term
C.TyLam TyVar
clkTV (
    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 _ funTy'' :: Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy aTy :: Type
aTy bTy :: Type
bTy)   = Type -> TypeView
C.tyView Type
funTy''
    fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "f" 0
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "x" 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

appSignalTerm ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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:Clock)./\(n:Nat)./\(a:*).\(vs:Signal t (Vec n a)).vs
-- @
vecUnwrapTerm :: C.Type
              -> C.Term
vecUnwrapTerm :: Type -> Term
vecUnwrapTerm (C.ForAllTy tTV :: TyVar
tTV (C.ForAllTy nTV :: TyVar
nTV (C.ForAllTy aTV :: TyVar
aTV funTy :: 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 _ vsTy :: Type
vsTy) = Type -> TypeView
C.tyView Type
funTy
    vsName :: Name a
vsName           = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "vs" 0
    vsId :: Id
vsId             = Type -> Name Term -> Id
C.mkLocalId Type
vsTy Name Term
forall a. Name a
vsName

vecUnwrapTerm ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 clk.Applicative f => (a -> f b) ->
-- CSignal clk a -> f (Signal clk b)
-- @
--
-- Generate the term:
--
-- @
-- /\(f:* -> *)./\(a:*)./\(b:*)./\(clk:Clock).\(dict:Applicative f).
-- \(g:a -> f b).\(x:Signal clk a).g x
-- @
traverseTerm :: C.Type
             -> C.Term
traverseTerm :: Type -> Term
traverseTerm (C.ForAllTy fTV :: TyVar
fTV (C.ForAllTy aTV :: TyVar
aTV (C.ForAllTy bTV :: TyVar
bTV (C.ForAllTy clkTV :: TyVar
clkTV funTy :: 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
clkTV (
    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 dictTy :: Type
dictTy funTy1 :: Type
funTy1) = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy gTy :: Type
gTy    funTy2 :: Type
funTy2) = Type -> TypeView
C.tyView Type
funTy1
    (C.FunTy xTy :: Type
xTy    _)      = Type -> TypeView
C.tyView Type
funTy2
    dictName :: Name a
dictName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "dict" 0
    gName :: Name a
gName    = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "g" 1
    xName :: Name a
xName    = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "x" 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 ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 rTV :: TyVar
rTV (C.ForAllTy aTV :: TyVar
aTV (C.ForAllTy bTV :: TyVar
bTV funTy :: 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 fTy :: Type
fTy funTy'' :: Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy aTy :: Type
aTy _)       = Type -> TypeView
C.tyView Type
funTy''
    fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "f" 0
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "x" 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 ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 clk. Signal clk (Signal clk a) -> Signal clk a@
--
-- Generate the term
--
-- @/\(a:*)./\(clk:Clock).\(x:Signal clk a).x@
joinTerm :: C.Type
         -> C.Term
joinTerm :: Type -> Term
joinTerm ty :: Type
ty@(C.ForAllTy {}) = Type -> Term
signalTerm Type
ty
joinTerm ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 aTV :: TyVar
aTV funTy :: 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 callStackTy :: Type
callStackTy fTy :: Type
fTy) = Type -> TypeView
C.tyView Type
funTy
    callStackName :: Name a
callStackName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "callStack" 0
    fName :: Name a
fName         = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "f" 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 ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 aTV :: TyVar
aTV funTy :: 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 xTy :: Type
xTy _) = Type -> TypeView
C.tyView Type
funTy
    xName :: Name a
xName           = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "x" 0
    xId :: Id
xId             = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName

idTerm ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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@
--
-- Genereate the term:
--
-- @/\(r:RuntimeRep)./\(o:TYPE r).\(f:State# RealWord -> o) -> f realWorld#@
runRWTerm
  :: C.Type
  -> C.Term
runRWTerm :: Type -> Term
runRWTerm (C.ForAllTy rTV :: TyVar
rTV (C.ForAllTy oTV :: TyVar
oTV funTy :: 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) (Text -> PrimInfo -> Term
C.Prim Text
rwNm (Type -> WorkInfo -> PrimInfo
C.PrimInfo Type
rwTy WorkInfo
C.WorkNever))))))
  where
    (C.FunTy fTy :: Type
fTy _)  = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy rwTy :: Type
rwTy _) = Type -> TypeView
C.tyView Type
fTy
    fName :: Name a
fName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "f" 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 "GHC.Prim.realWorld#"

runRWTerm ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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@
--
-- Genereate 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 nTV :: TyVar
nTV (C.ForAllTy aTV :: TyVar
aTV funTy :: 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 knTy :: Type
knTy rTy :: Type
rTy = Type -> TypeView
C.tyView Type
funTy
    C.FunTy fTy :: Type
fTy _    = Type -> TypeView
C.tyView Type
rTy
    knName :: Name a
knName           = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "kn" 0
    fName :: Name a
fName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "f" 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 ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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@
--
-- Genereate 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 nTV :: TyVar
nTV (C.ForAllTy aTV :: TyVar
aTV funTy :: 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 knTy :: Type
knTy r0Ty :: Type
r0Ty = Type -> TypeView
C.tyView Type
funTy
    C.FunTy tpTy :: Type
tpTy r1Ty :: Type
r1Ty = Type -> TypeView
C.tyView Type
r0Ty
    C.FunTy fTy :: Type
fTy _     = Type -> TypeView
C.tyView Type
r1Ty
    knName :: Name a
knName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "kn" 0
    tpName :: Name a
tpName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "tp" 1
    fName :: Name a
fName             = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName "f" 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 ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 sa :: NameMod
sa (C.ForAllTy nmTV :: TyVar
nmTV (C.ForAllTy aTV :: TyVar
aTV funTy :: 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 xTy :: Type
xTy _)  = 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 "x" 0
    xId :: Id
xId              = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName

nameModTerm _ ty :: Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $(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 v :: TyVar
v = case TyVar -> IdDetails
idDetails TyVar
v of
  DataConWrapId {} -> Bool
True
  _                -> Bool
False