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

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

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

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

-- External Modules
import           Control.Lens                ((^.), (%~), (&), (%=), (.~), view)
import           Control.Monad.RWS.Strict    (RWS)
import qualified Control.Monad.RWS.Strict    as RWS
import qualified Data.ByteString.Char8       as Char8
import           Data.Char                   (isDigit)
import           Data.Hashable               (Hashable (..))
import           Data.HashMap.Strict         (HashMap)
import qualified Data.HashMap.Strict         as HashMap
import           Data.Maybe                  (catMaybes,fromMaybe,listToMaybe)
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif
import           Data.Text                   (Text, pack)
import qualified Data.Text                   as Text
import           Data.Text.Encoding          (decodeUtf8)
import qualified Data.Traversable            as T
import qualified Text.Read                   as Text

-- GHC API
#if MIN_VERSION_ghc(9,0,0)
import GHC.Core.Coercion.Axiom
  (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs), fromBranches)
import GHC.Core.Coercion (Role (Nominal), coercionType, coercionKind)
import GHC.Core.FVs  (exprSomeFreeVars)
import GHC.Core
  (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..),
   collectArgs, rhssOfAlts, unfoldingTemplate)
import GHC.Core.DataCon
  (DataCon, dataConExTyCoVars, dataConName, dataConRepArgTys, dataConTag,
   dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel)
import GHC.Driver.Session (unsafeGlobalDynFlags)
import GHC.Core.FamInstEnv
  (FamInst (..), FamInstEnvs, familyInstances, normaliseType, emptyFamInstEnvs)
import GHC.Data.FastString (unpackFS, bytesFS)
import GHC.Types.Id (isDataConId_maybe)
import GHC.Types.Id.Info (IdDetails (..), unfoldingInfo)
import GHC.Types.Literal (Literal (..), LitNumType (..))
import GHC.Unit.Module (moduleName, moduleNameString)
import GHC.Types.Name
  (Name, nameModule_maybe, nameOccName, nameUnique, getSrcSpan)
import GHC.Builtin.Names  (tYPETyConKey, integerTyConKey, naturalTyConKey)
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Utils.Outputable (showPpr)
import GHC.Data.Pair (Pair (..))
import GHC.Types.SrcLoc (SrcSpan (..), isGoodSrcSpan)
import GHC.Core.TyCon
  (AlgTyConRhs (..), TyCon, tyConName, algTyConRhs, isAlgTyCon, isFamilyTyCon,
   isFunTyCon, isNewTyCon, isPrimTyCon, isTupleTyCon,
   isClosedSynFamilyTyConWithAxiom_maybe, expandSynTyCon_maybe, tyConArity,
   tyConDataCons, tyConKind, tyConName, tyConUnique, isClassTyCon)
import GHC.Core.Type (mkTvSubstPrs, substTy, coreView)
import GHC.Core.TyCo.Rep (Coercion (..), TyLit (..), Type (..), scaledThing)
import GHC.Types.Unique (Uniquable (..), Unique, getKey, hasKey)
import GHC.Types.Var
  (Id, TyVar, Var, VarBndr (..), idDetails, isTyVar, varName, varType,
   varUnique, idInfo, isGlobalId)
import GHC.Types.Var.Set (isEmptyVarSet)
#else
import CoAxiom    (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs),
                   fromBranches, Role (Nominal))
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, normaliseType, emptyFamInstEnvs)

#if MIN_VERSION_ghc(8,10,0)
import FastString (unpackFS, bytesFS)
#else
import FastString (unpackFS, fastStringToByteString)
#endif

import Id         (isDataConId_maybe)
import IdInfo     (IdDetails (..), unfoldingInfo)
import Literal    (Literal (..))
#if MIN_VERSION_ghc(8,6,0)
import Literal    (LitNumType (..))
#endif
import Module     (moduleName, moduleNameString)
import Name       (Name, nameModule_maybe,
                   nameOccName, nameUnique, getSrcSpan)
import PrelNames  (tYPETyConKey, integerTyConKey, naturalTyConKey)
import OccName    (occNameString)
import Outputable (showPpr)
import Pair       (Pair (..))
import SrcLoc     (SrcSpan (..), isGoodSrcSpan)
import TyCon      (AlgTyConRhs (..), TyCon, tyConName,
                   algTyConRhs, isAlgTyCon, isFamilyTyCon,
                   isFunTyCon, isNewTyCon,
                   isPrimTyCon, isTupleTyCon,
                   isClosedSynFamilyTyConWithAxiom_maybe,
                   expandSynTyCon_maybe,
                   tyConArity,
                   tyConDataCons, tyConKind,
                   tyConName, tyConUnique, isClassTyCon)
import Type       (mkTvSubstPrs, substTy, coreView)
import TyCoRep    (Coercion (..), TyLit (..), Type (..))
import Unique     (Uniquable (..), Unique, getKey, hasKey)
import Var        (Id, TyVar, Var, idDetails,
                   isTyVar, varName, varType,
                   varUnique, idInfo, isGlobalId)
#if MIN_VERSION_ghc(8,8,0)
import Var        (VarBndr (..))
#else
import Var        (TyVarBndr (..))
#endif
import VarSet     (isEmptyVarSet)
#endif

-- Local imports
import           Clash.Annotations.Primitive (extractPrim)
import qualified Clash.Core.DataCon          as C
import qualified Clash.Core.Literal          as C
import qualified Clash.Core.Name             as C
import qualified Clash.Core.Term             as C
import qualified Clash.Core.TyCon            as C
import qualified Clash.Core.Type             as C
import qualified Clash.Core.Var              as C
import           Clash.Primitives.Types
import qualified Clash.Unique                as C
import           Clash.Util

instance Hashable Name where
  hashWithSalt :: Int -> Name -> Int
hashWithSalt Int
s = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int -> Int) -> (Name -> Int) -> Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
getKey (Unique -> Int) -> (Name -> Unique) -> Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Unique
nameUnique

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

makeLenses ''GHC2CoreState

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

makeLenses ''GHC2CoreEnv

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

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

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

instance Monoid SrcSpanRB where
  mempty :: SrcSpanRB
mempty = SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
noSrcSpan
#if !MIN_VERSION_base(4,11,0)
  mappend = (<>)
#endif

type C2C = RWS GHC2CoreEnv SrcSpanRB GHC2CoreState

makeAllTyCons
  :: GHC2CoreState
  -> FamInstEnvs
  -> C.UniqMap C.TyCon
makeAllTyCons :: GHC2CoreState -> FamInstEnvs -> UniqMap TyCon
makeAllTyCons GHC2CoreState
hm FamInstEnvs
fiEnvs = GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go GHC2CoreState
hm GHC2CoreState
hm
  where
    go :: GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go GHC2CoreState
old GHC2CoreState
new
        | UniqMap TyCon -> Bool
forall a. UniqMap a -> Bool
C.nullUniqMap (GHC2CoreState
new GHC2CoreState
-> Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
-> UniqMap TyCon
forall s a. s -> Getting a s a -> a
^. Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap) = UniqMap TyCon
forall a. UniqMap a
C.emptyUniqMap
        | Bool
otherwise                       = UniqMap TyCon
tcm UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
forall a. UniqMap a -> UniqMap a -> UniqMap a
`C.unionUniqMap` UniqMap TyCon
tcm'
      where
        (UniqMap TyCon
tcm,GHC2CoreState
old', SrcSpanRB
_) = RWS GHC2CoreEnv SrcSpanRB GHC2CoreState (UniqMap TyCon)
-> GHC2CoreEnv
-> GHC2CoreState
-> (UniqMap TyCon, GHC2CoreState, SrcSpanRB)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
RWS.runRWS ((TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon)
-> UniqMap TyCon
-> RWS GHC2CoreEnv SrcSpanRB GHC2CoreState (UniqMap TyCon)
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
makeTyCon (GHC2CoreState
new GHC2CoreState
-> Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
-> UniqMap TyCon
forall s a. s -> Getting a s a -> a
^. Getting (UniqMap TyCon) GHC2CoreState (UniqMap TyCon)
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap))
                                   (SrcSpan -> FamInstEnvs -> GHC2CoreEnv
GHC2CoreEnv SrcSpan
noSrcSpan FamInstEnvs
fiEnvs)
                                   GHC2CoreState
old
        tcm' :: UniqMap TyCon
tcm'          = GHC2CoreState -> GHC2CoreState -> UniqMap TyCon
go GHC2CoreState
old' (GHC2CoreState
old' GHC2CoreState -> (GHC2CoreState -> GHC2CoreState) -> GHC2CoreState
forall a b. a -> (a -> b) -> b
& (UniqMap TyCon -> Identity (UniqMap TyCon))
-> GHC2CoreState -> Identity GHC2CoreState
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap ((UniqMap TyCon -> Identity (UniqMap TyCon))
 -> GHC2CoreState -> Identity GHC2CoreState)
-> (UniqMap TyCon -> UniqMap TyCon)
-> GHC2CoreState
-> GHC2CoreState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
forall 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 :: TyCon
          -> C2C C.TyCon
makeTyCon :: TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
makeTyCon TyCon
tc = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
tycon
  where
    tycon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
tycon
      | TyCon -> Bool
isFamilyTyCon TyCon
tc    = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkFunTyCon
      | TyCon -> Bool
isTupleTyCon TyCon
tc     = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkTupleTyCon
      | TyCon -> Bool
isAlgTyCon TyCon
tc       = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkAlgTyCon
      | TyCon -> Bool
isPrimTyCon TyCon
tc      = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkPrimTyCon
      | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tYPETyConKey = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkSuperKindTyCon
      | Bool
otherwise           = RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkVoidTyCon
      where
        tcArity :: Int
tcArity = TyCon -> Int
tyConArity TyCon
tc

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

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

        mkTupleTyCon :: RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
mkTupleTyCon = do
          Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
          Type
tcKind <- Type -> C2C Type
coreToType (TyCon -> Type
tyConKind TyCon
tc)
          AlgTyConRhs
tcDc   <- (DataCon -> AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([DataCon] -> AlgTyConRhs
C.DataTyCon ([DataCon] -> AlgTyConRhs)
-> (DataCon -> [DataCon]) -> DataCon -> AlgTyConRhs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataCon -> [DataCon] -> [DataCon]
forall a. a -> [a] -> [a]
:[])) (RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs)
-> (TyCon
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon)
-> TyCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon (DataCon
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon)
-> (TyCon -> DataCon)
-> TyCon
-> RWST GHC2CoreEnv 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 GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs)
-> TyCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity AlgTyConRhs
forall a b. (a -> b) -> a -> b
$ TyCon
tc
          TyCon -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyCon
forall (m :: Type -> Type) a. Monad m => a -> m a
return
            AlgTyCon :: Int -> Name TyCon -> Type -> Int -> AlgTyConRhs -> Bool -> TyCon
C.AlgTyCon
            { tyConUniq :: Int
C.tyConUniq   = Name TyCon -> Int
forall a. Name a -> Int
C.nameUniq Name TyCon
tcName
            , tyConName :: Name TyCon
C.tyConName   = Name TyCon
tcName
            , tyConKind :: Type
C.tyConKind   = Type
tcKind
            , tyConArity :: Int
C.tyConArity  = Int
tcArity
            , algTcRhs :: AlgTyConRhs
C.algTcRhs    = AlgTyConRhs
tcDc
            , isClassTc :: Bool
C.isClassTc   = TyCon -> Bool
isClassTyCon TyCon
tc
            }

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

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

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

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

makeAlgTyConRhs :: AlgTyConRhs
                -> C2C (Maybe C.AlgTyConRhs)
makeAlgTyConRhs :: AlgTyConRhs -> C2C (Maybe AlgTyConRhs)
makeAlgTyConRhs AlgTyConRhs
algTcRhs = case AlgTyConRhs
algTcRhs of
#if MIN_VERSION_ghc(8,6,0)
  DataTyCon [DataCon]
dcs Int
_ Bool
_ -> AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> ([DataCon] -> AlgTyConRhs) -> [DataCon] -> Maybe AlgTyConRhs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataCon] -> AlgTyConRhs
C.DataTyCon ([DataCon] -> Maybe AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
-> C2C (Maybe AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon)
-> [DataCon]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon [DataCon]
dcs
#else
  DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#endif
#if MIN_VERSION_ghc(8,6,0)
  SumTyCon [DataCon]
dcs Int
_ -> AlgTyConRhs -> Maybe AlgTyConRhs
forall a. a -> Maybe a
Just (AlgTyConRhs -> Maybe AlgTyConRhs)
-> ([DataCon] -> AlgTyConRhs) -> [DataCon] -> Maybe AlgTyConRhs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataCon] -> AlgTyConRhs
C.DataTyCon ([DataCon] -> Maybe AlgTyConRhs)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
-> C2C (Maybe AlgTyConRhs)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon)
-> [DataCon]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [DataCon]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon [DataCon]
dcs
#else
  SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs
#endif

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

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

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

    term' :: CoreExpr -> C2C Term
term' (Var TyVar
x)                 = TyVar -> C2C Term
var TyVar
x
    term' (Lit Literal
l)                 = Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> C2C Term) -> Term -> C2C Term
forall a b. (a -> b) -> a -> b
$ Literal -> Term
C.Literal (Literal -> Literal
coreToLiteral Literal
l)
    term' (App CoreExpr
eFun (Type Type
tyArg)) = Term -> Type -> Term
C.TyApp (Term -> Type -> Term)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
eFun RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Term)
-> C2C Type -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
tyArg
    term' (App CoreExpr
eFun CoreExpr
eArg)         = Term -> Term -> Term
C.App   (Term -> Term -> Term)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
eFun RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> CoreExpr -> C2C Term
term CoreExpr
eArg
    term' (Lam TyVar
x CoreExpr
e)
      | TyVar -> Bool
isTyVar TyVar
x
      = TyVar -> Term -> Term
C.TyLam (TyVar -> Term -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
x RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Term)
-> C2C Term -> C2C Term
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SrcSpan -> C2C Term -> C2C Term
forall a. SrcSpan -> C2C a -> C2C a
addUsefull (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) (CoreExpr -> C2C Term
term CoreExpr
e)
      | Bool
otherwise
      = do
        (Term
e',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
e
        Id
x' <- SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
x
        Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id -> Term -> Term
C.Lam  Id
x' Term
e')
    term' (Let (NonRec TyVar
x CoreExpr
e1) CoreExpr
e2)  = do
      (Term
e1',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
x) CoreExpr
e1
      Id
x'  <- SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
x
      Term
e2' <- CoreExpr -> C2C Term
term CoreExpr
e2
      Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([LetBinding] -> Term -> Term
C.Letrec [(Id
x', Term
e1')] Term
e2')

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

    term' (Case CoreExpr
_ TyVar
_ Type
ty [])  =
      Term -> Type -> Term
C.TyApp (PrimInfo -> Term
C.Prim (Text -> Type -> WorkInfo -> IsMultiPrim -> PrimInfo
C.PrimInfo ([Char] -> Text
pack [Char]
"EmptyCase") Type
C.undefinedTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult))
        (Type -> Term) -> C2C Type -> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
ty
    term' (Case CoreExpr
e TyVar
b Type
ty [Alt TyVar]
alts) = do
     let usesBndr :: Bool
usesBndr = (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any ( Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarSet -> Bool
isEmptyVarSet (VarSet -> Bool) -> (CoreExpr -> VarSet) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVar -> Bool) -> CoreExpr -> VarSet
exprSomeFreeVars (TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TyVar
b))
                  ([CoreExpr] -> Bool) -> [CoreExpr] -> Bool
forall a b. (a -> b) -> a -> b
$ [Alt TyVar] -> [CoreExpr]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt TyVar]
alts
     (Term
e',SrcSpan
sp) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
b) CoreExpr
e
     Id
b'  <- SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp TyVar
b
     Type
ty' <- Type -> C2C Type
coreToType Type
ty
     let caseTerm :: Term -> C2C Term
caseTerm Term
v =
             Term -> Type -> [Alt] -> Term
C.Case Term
v Type
ty' ([Alt] -> Term)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Alt]
-> C2C Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt TyVar
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt)
-> [Alt TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Alt]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall a. SrcSpan -> C2C a -> C2C a
addUsefull SrcSpan
sp (RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
 -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt)
-> (Alt TyVar
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt)
-> Alt TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> Alt TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
alt SrcSpan
sp) [Alt TyVar]
alts
     if Bool
usesBndr
      then do
        Term
ct <- Term -> C2C Term
caseTerm (Id -> Term
C.Var Id
b')
        Term -> C2C Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([LetBinding] -> Term -> Term
C.Letrec [(Id
b', Term
e')] Term
ct)
      else Term -> C2C Term
caseTerm Term
e'

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


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


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

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

    alt :: SrcSpan
-> Alt TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
alt SrcSpan
_   (AltCon
DEFAULT   , [TyVar]
_ , CoreExpr
e) = (Pat
C.DefaultPat,) (Term -> Alt)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
e
    alt SrcSpan
_   (LitAlt Literal
l  , [TyVar]
_ , CoreExpr
e) = (Literal -> Pat
C.LitPat (Literal -> Literal
coreToLiteral Literal
l),) (Term -> Alt)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> C2C Term
term CoreExpr
e
    alt SrcSpan
sp0 (DataAlt DataCon
dc, [TyVar]
xs, CoreExpr
e) = case (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span TyVar -> Bool
isTyVar [TyVar]
xs of
      ([TyVar]
tyvs,[TyVar]
tmvs) -> do
        (Term
e',SrcSpan
sp1) <- SrcSpan
-> CoreExpr
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term, SrcSpan)
termSP SrcSpan
sp0 CoreExpr
e
        (,) (Pat -> Term -> Alt)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Pat
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Alt)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataCon -> [TyVar] -> [Id] -> Pat
C.DataPat (DataCon -> [TyVar] -> [Id] -> Pat)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
-> RWST
     GHC2CoreEnv
     SrcSpanRB
     GHC2CoreState
     Identity
     ([TyVar] -> [Id] -> Pat)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity DataCon
coreToDataCon DataCon
dc
                           RWST
  GHC2CoreEnv
  SrcSpanRB
  GHC2CoreState
  Identity
  ([TyVar] -> [Id] -> Pat)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Id] -> Pat)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar)
-> [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [TyVar]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar [TyVar]
tyvs
                           RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Id] -> Pat)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Id]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Pat
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id)
-> [TyVar]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Id]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Id
coreToIdSP SrcSpan
sp1) [TyVar]
tmvs)
            RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Term -> Alt)
-> C2C Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Alt
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Term -> C2C Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Term
e'

    coreToLiteral :: Literal
                  -> C.Literal
    coreToLiteral :: Literal -> Literal
coreToLiteral Literal
l = case Literal
l of
#if MIN_VERSION_ghc(8,8,0)
      LitString  ByteString
fs  -> [Char] -> Literal
C.StringLiteral (ByteString -> [Char]
Char8.unpack ByteString
fs)
      LitChar    Char
c   -> Char -> Literal
C.CharLiteral Char
c
      Literal
LitRubbish     ->
        [Char] -> Literal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Literal) -> [Char] -> Literal
forall a b. (a -> b) -> a -> b
$ [Char]
"coreToTerm: Encountered LibRubbish. This is a bug in Clash. "
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Report on https://github.com/clash-lang/clash-compiler/issues."
#else
      MachStr    fs  -> C.StringLiteral (Char8.unpack fs)
      MachChar   c   -> C.CharLiteral c
#endif
#if MIN_VERSION_ghc(8,6,0)
#if MIN_VERSION_ghc(9,0,0)
      LitNumber lt i -> case lt of
#else
      LitNumber LitNumType
lt Integer
i Type
_ -> case LitNumType
lt of
#endif
        LitNumType
LitNumInteger -> Integer -> Literal
C.IntegerLiteral Integer
i
        LitNumType
LitNumNatural -> Integer -> Literal
C.NaturalLiteral Integer
i
        LitNumType
LitNumInt     -> Integer -> Literal
C.IntLiteral Integer
i
        LitNumType
LitNumInt64   -> Integer -> Literal
C.IntLiteral Integer
i
        LitNumType
LitNumWord    -> Integer -> Literal
C.WordLiteral Integer
i
        LitNumType
LitNumWord64  -> Integer -> Literal
C.WordLiteral Integer
i
#else
      MachInt    i   -> C.IntLiteral i
      MachInt64  i   -> C.IntLiteral i
      MachWord   i   -> C.WordLiteral i
      MachWord64 i   -> C.WordLiteral i
      LitInteger i _ -> C.IntegerLiteral i
#endif
#if MIN_VERSION_ghc(8,8,0)
      LitFloat Rational
r    -> Rational -> Literal
C.FloatLiteral Rational
r
      LitDouble Rational
r   -> Rational -> Literal
C.DoubleLiteral Rational
r
      Literal
LitNullAddr   -> [Char] -> Literal
C.StringLiteral []
      LitLabel FastString
fs Maybe Int
_ FunctionOrData
_ -> [Char] -> Literal
C.StringLiteral (FastString -> [Char]
unpackFS FastString
fs)
#else
      MachFloat r    -> C.FloatLiteral r
      MachDouble r   -> C.DoubleLiteral r
      MachNullAddr   -> C.StringLiteral []
      MachLabel fs _ _ -> C.StringLiteral (unpackFS fs)
#endif

addUsefull :: SrcSpan
           -> C2C a
           -> C2C a
addUsefull :: SrcSpan -> C2C a -> C2C a
addUsefull SrcSpan
x C2C a
m =
  if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
x
  then do a
a <- (GHC2CoreEnv -> GHC2CoreEnv) -> C2C a -> C2C a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
RWS.local ((SrcSpan -> Identity SrcSpan)
-> GHC2CoreEnv -> Identity GHC2CoreEnv
Lens' GHC2CoreEnv SrcSpan
srcSpan ((SrcSpan -> Identity SrcSpan)
 -> GHC2CoreEnv -> Identity GHC2CoreEnv)
-> SrcSpan -> GHC2CoreEnv -> GHC2CoreEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SrcSpan
x) C2C a
m
          SrcSpanRB -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
RWS.tell (SrcSpan -> SrcSpanRB
SrcSpanRB SrcSpan
x)
          a -> C2C a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
a
  else C2C a
m

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Try to interpret a Type as an Attr
coreToAttr
  :: Type
  -> C2C C.Attr'
coreToAttr :: Type -> C2C Attr'
coreToAttr (TyConApp TyCon
ty [Type]
args) = do
  let key :: Type
key   = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
0
  let value :: Type
value = [Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
1
  [Char]
name' <- TyCon -> C2C [Char]
typeConstructorToString TyCon
ty
  FamInstEnvs
envs <- Getting FamInstEnvs GHC2CoreEnv FamInstEnvs
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity FamInstEnvs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting FamInstEnvs GHC2CoreEnv FamInstEnvs
Lens' GHC2CoreEnv FamInstEnvs
famInstEnvs
  let (Coercion
_,Type
key1) = FamInstEnvs -> Role -> Type -> (Coercion, Type)
normaliseType FamInstEnvs
envs Role
Nominal Type
key
      (Coercion
_,Type
value1) = FamInstEnvs -> Role -> Type -> (Coercion, Type)
normaliseType FamInstEnvs
envs Role
Nominal Type
value
  case [Char]
name' of
    [Char]
"Clash.Annotations.SynthesisAttributes.StringAttr" ->
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Attr'
C.StringAttr' (Type -> [Char]
tyLitToString Type
key1) (Type -> [Char]
tyLitToString Type
value1)
    [Char]
"Clash.Annotations.SynthesisAttributes.IntegerAttr" ->
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> Integer -> Attr'
C.IntegerAttr' (Type -> [Char]
tyLitToString Type
key1) (Type -> Integer
tyLitToInteger Type
value1)
    [Char]
"Clash.Annotations.SynthesisAttributes.BoolAttr" -> do
        Bool
bool <- Type -> C2C Bool
boolTypeToBool Type
value1
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool -> Attr'
C.BoolAttr' (Type -> [Char]
tyLitToString Type
key1) Bool
bool
    [Char]
"Clash.Annotations.SynthesisAttributes.Attr" ->
        Attr' -> C2C Attr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Attr' -> C2C Attr') -> Attr' -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [Char] -> Attr'
C.Attr' (Type -> [Char]
tyLitToString Type
key1)
    [Char]
_ ->
        [Char] -> C2C Attr'
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C Attr') -> [Char] -> C2C Attr'
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Expected StringAttr, IntegerAttr, BoolAttr or Attr"
                        , [Char]
"constructor, got:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name' ]

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

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

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

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

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

        C2C [Attr']
result

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

coreToAttrs' [Type]
illegal =
  [Char] -> C2C [Attr']
forall a. HasCallStack => [Char] -> a
error ([Char] -> C2C [Attr']) -> [Char] -> C2C [Attr']
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected list with three items (as Annotate has three arguments), but got: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ((Type -> [Char]) -> [Type] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags) [Type]
illegal)

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

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

coreToAttrs Type
_ =
    [Attr'] -> C2C [Attr']
forall (m :: Type -> Type) a. Monad m => a -> m a
return []

-- | Wrap given type in an annotation if it is annotated using the constructs
-- defined in Clash.Annotations.SynthesisAttributes.
annotateType
  :: Type
  -> C.Type
  -> C2C C.Type
annotateType :: Type -> Type -> C2C Type
annotateType Type
ty Type
cty = do
  [Attr']
attrs <- Type -> C2C [Attr']
coreToAttrs Type
ty
  case [Attr']
attrs of
    [] -> Type -> C2C Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return Type
cty
    [Attr']
_  -> Type -> C2C Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> C2C Type) -> Type -> C2C Type
forall a b. (a -> b) -> a -> b
$ [Attr'] -> Type -> Type
C.AnnType [Attr']
attrs Type
cty

-- | Converts GHC Type to a Clash Type. Strips newtypes and signals, with the
-- exception of newtypes used as annotations (see: SynthesisAttributes).
coreToType
  :: Type
  -> C2C C.Type
coreToType :: Type -> C2C Type
coreToType Type
ty = C2C Type
ty'' C2C Type -> (Type -> C2C Type) -> C2C Type
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Type -> C2C Type
annotateType Type
ty
  where
    ty'' :: C2C Type
ty'' =
      case Type -> Maybe Type
coreView Type
ty of
        Just Type
ty' -> Type -> C2C Type
coreToType Type
ty'
        Maybe Type
Nothing  -> Type -> C2C Type
coreToType' Type
ty

coreToType'
  :: Type
  -> C2C C.Type
coreToType' :: Type -> C2C Type
coreToType' (TyVarTy TyVar
tv) = TyVar -> Type
C.VarTy (TyVar -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
-> C2C Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv
coreToType' (TyConApp TyCon
tc [Type]
args)
  | TyCon -> Bool
isFunTyCon TyCon
tc = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
C.AppTy (ConstTy -> Type
C.ConstTy ConstTy
C.Arrow) ([Type] -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
-> C2C Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType [Type]
args
  | Bool
otherwise     = case TyCon -> [Type] -> Maybe ([(TyVar, Type)], Type, [Type])
forall tyco.
TyCon -> [tyco] -> Maybe ([(TyVar, tyco)], Type, [tyco])
expandSynTyCon_maybe TyCon
tc [Type]
args of
                      Just ([(TyVar, Type)]
substs,Type
synTy,[Type]
remArgs) -> do
                        let substs' :: TCvSubst
substs' = [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs [(TyVar, Type)]
substs
                            synTy' :: Type
synTy'  = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
substs' Type
synTy
                        (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
C.AppTy (Type -> [Type] -> Type)
-> C2C Type
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
synTy' RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
-> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType [Type]
remArgs
                      Maybe ([(TyVar, Type)], Type, [Type])
_ -> do
                        Name TyCon
tcName <- (TyCon -> Name)
-> (TyCon -> Unique)
-> (Name -> C2C Text)
-> TyCon
-> C2C (Name TyCon)
forall b a.
(b -> Name)
-> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
coreToName TyCon -> Name
tyConName TyCon -> Unique
tyConUnique Name -> C2C Text
qualifiedNameString TyCon
tc
                        (UniqMap TyCon -> Identity (UniqMap TyCon))
-> GHC2CoreState -> Identity GHC2CoreState
Lens' GHC2CoreState (UniqMap TyCon)
tyConMap ((UniqMap TyCon -> Identity (UniqMap TyCon))
 -> GHC2CoreState -> Identity GHC2CoreState)
-> (UniqMap TyCon -> UniqMap TyCon)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Name TyCon -> TyCon -> UniqMap TyCon -> UniqMap TyCon
forall a b. Uniquable a => a -> b -> UniqMap b -> UniqMap b
C.extendUniqMap Name TyCon
tcName TyCon
tc)
                        Name TyCon -> [Type] -> Type
C.mkTyConApp (Name TyCon -> [Type] -> Type)
-> C2C (Name TyCon)
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name TyCon -> C2C (Name TyCon)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Name TyCon
tcName) RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity ([Type] -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
-> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Type -> C2C Type)
-> [Type]
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> C2C Type
coreToType [Type]
args
#if MIN_VERSION_ghc(8,8,0)
coreToType' (ForAllTy (Bndr TyVar
tv ArgFlag
_) Type
ty)   = TyVar -> Type -> Type
C.ForAllTy (TyVar -> Type -> Type)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity TyVar
coreToTyVar TyVar
tv RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
-> C2C Type -> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
ty
#else
coreToType' (ForAllTy (TvBndr tv _) ty) = C.ForAllTy <$> coreToTyVar tv <*> coreToType ty
#endif
#if MIN_VERSION_ghc(8,10,0)
-- TODO after we drop 8.8: save the distinction between => and ->
#if MIN_VERSION_ghc(9,0,0)
coreToType' (FunTy _ _ ty1 ty2)             = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#else
coreToType' (FunTy AnonArgFlag
_ Type
ty1 Type
ty2)             = Type -> Type -> Type
C.mkFunTy (Type -> Type -> Type)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
ty1 RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
-> C2C Type -> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType Type
ty2
#endif
#else
coreToType' (FunTy ty1 ty2)             = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2
#endif
coreToType' (LitTy TyLit
tyLit)    = Type -> C2C Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> C2C Type) -> Type -> C2C Type
forall a b. (a -> b) -> a -> b
$ LitTy -> Type
C.LitTy (TyLit -> LitTy
coreToTyLit TyLit
tyLit)
coreToType' (AppTy Type
ty1 Type
ty2)  = Type -> Type -> Type
C.AppTy (Type -> Type -> Type)
-> C2C Type
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> C2C Type
coreToType Type
ty1 RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Type -> Type)
-> C2C Type -> C2C Type
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> C2C Type
coreToType' Type
ty2
coreToType' t :: Type
t@(CastTy Type
_ Coercion
_)   = [Char] -> C2C Type
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot handle CastTy " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags Type
t)
coreToType' t :: Type
t@(CoercionTy Coercion
_) = [Char] -> C2C Type
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot handle CoercionTy " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DynFlags -> Type -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
showPpr DynFlags
unsafeGlobalDynFlags Type
t)

coreToTyLit :: TyLit
            -> C.LitTy
coreToTyLit :: TyLit -> LitTy
coreToTyLit (NumTyLit Integer
i) = Integer -> LitTy
C.NumTy (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
i)
coreToTyLit (StrTyLit FastString
s) = [Char] -> LitTy
C.SymTy (FastString -> [Char]
unpackFS FastString
s)

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

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

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

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

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

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

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

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

modNameM :: Name
         -> Maybe Text
modNameM :: Name -> Maybe Text
modNameM Name
n = do
  Module
module_ <- Name -> Maybe Module
nameModule_maybe Name
n
  let moduleNm :: ModuleName
moduleNm = Module -> ModuleName
moduleName Module
module_
  Text -> Maybe Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Char] -> Text
pack (ModuleName -> [Char]
moduleNameString ModuleName
moduleNm))

-- | Given the type:
--
-- @
--     forall dom a0 a1 .. aN
--   . Signal dom (a0, a1, .., aN)
--  -> (Signal dom a0, Signal dom a1, .., Signal dom aN)
-- @
--
-- or the type
--
-- @
--     forall dom a0 a1 .. aN
--   . (Signal dom a0, Signal dom a1, .., Signal dom aN)
--  -> Signal dom (a0, a1, .., aN)
-- @
--
-- Generate the term:
--
-- @/\dom. /\a0. /\a1. .. /\aN. \x -> x@
--
-- In other words: treat "bundle" and "unbundle" primitives as id.
--
bundleUnbundleTerm :: Int -> C.Type -> C.Term
bundleUnbundleTerm :: Int -> Type -> Term
bundleUnbundleTerm Int
nTyVarsExpected = [TyVar] -> Type -> Term
go []
 where
  go :: [C.TyVar] -> C.Type -> C.Term
  go :: [TyVar] -> Type -> Term
go [TyVar]
tvs (C.ForAllTy TyVar
tv Type
typ) = [TyVar] -> Type -> Term
go (TyVar
tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
tvs) Type
typ
  go [TyVar]
tvs (Type -> TypeView
C.tyView -> C.FunTy Type
argTy Type
_resTy) =
    if [TyVar] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TyVar]
tvs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nTyVarsExpected then
      -- Internal error: should never happen unless we change the type of
      -- bundle / unbundle.
      [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([TyVar] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TyVar]
tvs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" vs " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nTyVarsExpected
    else
      let sigName :: Id
sigName = Type -> Name Term -> Id
C.mkLocalId Type
argTy (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"c$s" Int
0) in
      (TyVar -> Term -> Term) -> Term -> [TyVar] -> Term
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVar -> Term -> Term
C.TyLam (Id -> Term -> Term
C.Lam Id
sigName (Id -> Term
C.Var Id
sigName)) ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs)
  go [TyVar]
tvs Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [TyVar] -> [Char]
forall a. Show a => a -> [Char]
show [TyVar]
tvs


-- | Given the type:
--
-- @forall a. forall b. forall clk. (a -> b) -> Signal clk a -> Signal clk b@
--
-- Generate the term:
--
-- @
-- /\(a:*)./\(b:*)./\(clk:Clock).\(f : (Signal clk a -> Signal clk b)).
-- \(x : Signal clk a).f x
-- @
mapSignalTerm :: C.Type
              -> C.Term
mapSignalTerm :: Type -> Term
mapSignalTerm (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV (C.ForAllTy TyVar
clkTV Type
funTy))) =
    TyVar -> Term -> Term
C.TyLam TyVar
aTV (
    TyVar -> Term -> Term
C.TyLam TyVar
bTV (
    TyVar -> Term -> Term
C.TyLam TyVar
clkTV (
    Id -> Term -> Term
C.Lam   Id
fId (
    Id -> Term -> Term
C.Lam   Id
xId (
    Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
xId))))))
  where
    (C.FunTy Type
_ Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
aTy Type
bTy)   = Type -> TypeView
C.tyView Type
funTy''
    fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
    fTy :: Type
fTy   = Type -> Type -> Type
C.mkFunTy Type
aTy Type
bTy
    fId :: Id
fId   = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
    xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
aTy Name Term
forall a. Name a
xName

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

-- | Given the type:
--
-- @forall a. forall dom. a -> Signal dom a@
--
-- Generate the term
--
-- @/\(a:*)./\(dom:Domain).\(x:Signal dom a).x@
signalTerm :: C.Type
           -> C.Term
signalTerm :: Type -> Term
signalTerm (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
domTV Type
funTy)) =
    TyVar -> Term -> Term
C.TyLam TyVar
aTV (
    TyVar -> Term -> Term
C.TyLam TyVar
domTV (
    Id -> Term -> Term
C.Lam   Id
xId (
    Id -> Term
C.Var   Id
xId)))
  where
    (C.FunTy Type
_ Type
saTy) = Type -> TypeView
C.tyView Type
funTy
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
0
    xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
saTy Name Term
forall a. Name a
xName

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

-- | Given the type:
--
-- @
-- forall dom. forall a. forall b. Signal dom (a -> b) -> Signal dom a ->
-- Signal dom b
-- @
--
-- Generate the term:
--
-- @
-- /\(dom:Domain)./\(a:*)./\(b:*).\(f : (Signal dom a -> Signal dom b)).
-- \(x : Signal dom a).f x
-- @
appSignalTerm :: C.Type
              -> C.Term
appSignalTerm :: Type -> Term
appSignalTerm (C.ForAllTy TyVar
domTV (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV Type
funTy))) =
    TyVar -> Term -> Term
C.TyLam TyVar
domTV (
    TyVar -> Term -> Term
C.TyLam TyVar
aTV (
    TyVar -> Term -> Term
C.TyLam TyVar
bTV (
    Id -> Term -> Term
C.Lam   Id
fId (
    Id -> Term -> Term
C.Lam   Id
xId (
    Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
xId))))))
  where
    (C.FunTy Type
_ Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
saTy Type
sbTy)   = Type -> TypeView
C.tyView Type
funTy''
    fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
    fTy :: Type
fTy   = Type -> Type -> Type
C.mkFunTy Type
saTy Type
sbTy
    fId :: Id
fId   = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
    xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
saTy Name Term
forall a. Name a
xName

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

-- | Given the type:
--
-- @
-- forall t.forall n.forall a.Vec n (Signal t a) ->
-- Signal t (Vec n a)
-- @
--
-- Generate the term:
--
-- @
-- /\(t:Domain)./\(n:Nat)./\(a:*).\(vs:Signal t (Vec n a)).vs
-- @
vecUnwrapTerm :: C.Type
              -> C.Term
vecUnwrapTerm :: Type -> Term
vecUnwrapTerm (C.ForAllTy TyVar
tTV (C.ForAllTy TyVar
nTV (C.ForAllTy TyVar
aTV Type
funTy))) =
    TyVar -> Term -> Term
C.TyLam TyVar
tTV (
    TyVar -> Term -> Term
C.TyLam TyVar
nTV (
    TyVar -> Term -> Term
C.TyLam TyVar
aTV (
    Id -> Term -> Term
C.Lam   Id
vsId (
    Id -> Term
C.Var Id
vsId))))
  where
    (C.FunTy Type
_ Type
vsTy) = Type -> TypeView
C.tyView Type
funTy
    vsName :: Name a
vsName           = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"vs" Int
0
    vsId :: Id
vsId             = Type -> Name Term -> Id
C.mkLocalId Type
vsTy Name Term
forall a. Name a
vsName

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

-- | Given the type:
--
-- @
-- forall f.forall a.forall b.forall dom.Applicative f => (a -> f b) ->
-- Signal dom a -> f (Signal dom b)
-- @
--
-- Generate the term:
--
-- @
-- /\(f:* -> *)./\(a:*)./\(b:*)./\(dom:Clock).\(dict:Applicative f).
-- \(g:a -> f b).\(x:Signal dom a).g x
-- @
traverseTerm :: C.Type
             -> C.Term
traverseTerm :: Type -> Term
traverseTerm (C.ForAllTy TyVar
fTV (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV (C.ForAllTy TyVar
domTV Type
funTy)))) =
    TyVar -> Term -> Term
C.TyLam TyVar
fTV (
    TyVar -> Term -> Term
C.TyLam TyVar
aTV (
    TyVar -> Term -> Term
C.TyLam TyVar
bTV (
    TyVar -> Term -> Term
C.TyLam TyVar
domTV (
    Id -> Term -> Term
C.Lam   Id
dictId (
    Id -> Term -> Term
C.Lam   Id
gId (
    Id -> Term -> Term
C.Lam   Id
xId (
    Term -> Term -> Term
C.App (Id -> Term
C.Var Id
gId) (Id -> Term
C.Var Id
xId))))))))
  where
    (C.FunTy Type
dictTy Type
funTy1) = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
gTy    Type
funTy2) = Type -> TypeView
C.tyView Type
funTy1
    (C.FunTy Type
xTy    Type
_)      = Type -> TypeView
C.tyView Type
funTy2
    dictName :: Name a
dictName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"dict" Int
0
    gName :: Name a
gName    = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"g" Int
1
    xName :: Name a
xName    = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
2
    dictId :: Id
dictId   = Type -> Name Term -> Id
C.mkLocalId Type
dictTy Name Term
forall a. Name a
dictName
    gId :: Id
gId      = Type -> Name Term -> Id
C.mkLocalId Type
gTy Name Term
forall a. Name a
gName
    xId :: Id
xId      = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName

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

-- ∀ (r :: GHC.Types.RuntimeRep)
--   (a :: GHC.Prim.TYPE GHC.Types.PtrRepLifted)
--   (b :: GHC.Prim.TYPE r).
-- (a -> b) -> a -> b


-- | Given the type:
--
-- @forall (r :: Rep) (a :: TYPE Lifted) (b :: TYPE r). (a -> b) -> a -> b@
--
-- Generate the term:
--
-- @/\(r:Rep)/\(a:TYPE Lifted)./\(b:TYPE r).\(f : (a -> b)).\(x : a).f x@
dollarTerm :: C.Type
           -> C.Term
dollarTerm :: Type -> Term
dollarTerm (C.ForAllTy TyVar
rTV (C.ForAllTy TyVar
aTV (C.ForAllTy TyVar
bTV Type
funTy))) =
    TyVar -> Term -> Term
C.TyLam TyVar
rTV (
    TyVar -> Term -> Term
C.TyLam TyVar
aTV (
    TyVar -> Term -> Term
C.TyLam TyVar
bTV (
    Id -> Term -> Term
C.Lam   Id
fId (
    Id -> Term -> Term
C.Lam   Id
xId (
    Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
xId))))))
  where
    (C.FunTy Type
fTy Type
funTy'') = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
aTy Type
_)       = Type -> TypeView
C.tyView Type
funTy''
    fName :: Name a
fName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
    xName :: Name a
xName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
    fId :: Id
fId   = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
    xId :: Id
xId   = Type -> Name Term -> Id
C.mkLocalId Type
aTy Name Term
forall a. Name a
xName

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

-- | Given the type:
--
-- @forall a. forall dom. Signal dom (Signal dom a) -> Signal dom a@
--
-- Generate the term
--
-- @/\(a:*)./\(dom:Domain).\(x:Signal dom a).x@
joinTerm :: C.Type
         -> C.Term
joinTerm :: Type -> Term
joinTerm ty :: Type
ty@(C.ForAllTy {}) = Type -> Term
signalTerm Type
ty
joinTerm Type
ty = [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ $([Char]
curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty

-- | Given the type:
--
-- @forall a. CallStack -> (HasCallStack => a) -> a@
--
-- Generate the term
--
-- @/\(a:*)./\(callStack:CallStack).\(f:HasCallStack => a).f callStack@
withFrozenCallStackTerm
  :: C.Type
  -> C.Term
withFrozenCallStackTerm :: Type -> Term
withFrozenCallStackTerm (C.ForAllTy TyVar
aTV Type
funTy) =
  TyVar -> Term -> Term
C.TyLam  TyVar
aTV (
  Id -> Term -> Term
C.Lam    Id
callStackId (
  Id -> Term -> Term
C.Lam    Id
fId (
  Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (Id -> Term
C.Var Id
callStackId))))
  where
    (C.FunTy Type
callStackTy Type
fTy) = Type -> TypeView
C.tyView Type
funTy
    callStackName :: Name a
callStackName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"callStack" Int
0
    fName :: Name a
fName         = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
1
    callStackId :: Id
callStackId   = Type -> Name Term -> Id
C.mkLocalId Type
callStackTy Name Term
forall a. Name a
callStackName
    fId :: Id
fId           = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName

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

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

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

-- | Given type type:
--
-- @forall (r :: RuntimeRep) (o :: TYPE r).(State# RealWorld -> o) -> o@
--
-- Generate the term:
--
-- @/\(r:RuntimeRep)./\(o:TYPE r).\(f:State# RealWord -> o) -> f realWorld#@
runRWTerm
  :: C.Type
  -> C.Term
runRWTerm :: Type -> Term
runRWTerm (C.ForAllTy TyVar
rTV (C.ForAllTy TyVar
oTV Type
funTy)) =
  TyVar -> Term -> Term
C.TyLam TyVar
rTV (
  TyVar -> Term -> Term
C.TyLam TyVar
oTV (
  Id -> Term -> Term
C.Lam   Id
fId (
  (Term -> Term -> Term
C.App (Id -> Term
C.Var Id
fId) (PrimInfo -> Term
C.Prim (Text -> Type -> WorkInfo -> IsMultiPrim -> PrimInfo
C.PrimInfo Text
rwNm Type
rwTy WorkInfo
C.WorkNever IsMultiPrim
C.SingleResult))))))
  where
    (C.FunTy Type
fTy Type
_)  = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
rwTy Type
_) = Type -> TypeView
C.tyView Type
fTy
    fName :: Name a
fName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
0
    fId :: Id
fId              = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName
    rwNm :: Text
rwNm             = [Char] -> Text
pack [Char]
"GHC.Prim.realWorld#"

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

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

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

-- | Given type type:
--
-- @forall (n :: Nat) (a :: Type) .Knownnat n => Typeable a => (BitVector n -> a) -> BitVector n -> a@
--
-- Generate the term:
--
-- @/\(n:Nat)./\(a:TYPE r).\(kn:KnownNat n).\(f:a -> BitVector n).f@
checkUnpackUndefTerm
  :: C.Type
  -> C.Term
checkUnpackUndefTerm :: Type -> Term
checkUnpackUndefTerm (C.ForAllTy TyVar
nTV (C.ForAllTy TyVar
aTV Type
funTy)) =
  TyVar -> Term -> Term
C.TyLam TyVar
nTV (
  TyVar -> Term -> Term
C.TyLam TyVar
aTV (
  Id -> Term -> Term
C.Lam Id
knId (
  Id -> Term -> Term
C.Lam Id
tpId (
  Id -> Term -> Term
C.Lam Id
fId (
  Id -> Term
C.Var Id
fId)))))
  where
    C.FunTy Type
knTy Type
r0Ty = Type -> TypeView
C.tyView Type
funTy
    C.FunTy Type
tpTy Type
r1Ty = Type -> TypeView
C.tyView Type
r0Ty
    C.FunTy Type
fTy Type
_     = Type -> TypeView
C.tyView Type
r1Ty
    knName :: Name a
knName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"kn" Int
0
    tpName :: Name a
tpName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"tp" Int
1
    fName :: Name a
fName             = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"f" Int
2
    knId :: Id
knId              = Type -> Name Term -> Id
C.mkLocalId Type
knTy Name Term
forall a. Name a
knName
    tpId :: Id
tpId              = Type -> Name Term -> Id
C.mkLocalId Type
tpTy Name Term
forall a. Name a
tpName
    fId :: Id
fId               = Type -> Name Term -> Id
C.mkLocalId Type
fTy Name Term
forall a. Name a
fName

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

-- | Given the type:
--
-- @forall (name :: Symbol) (a :: Type) . a -> (name ::: a)@
--
-- Generate the term:
--
-- @/\(name:Symbol)./\(a:Type).\(x:a) -> <TICK>x@
nameModTerm
  :: C.NameMod
  -> C.Type
  -> C.Term
nameModTerm :: NameMod -> Type -> Term
nameModTerm NameMod
sa (C.ForAllTy TyVar
nmTV (C.ForAllTy TyVar
aTV Type
funTy)) =
  TyVar -> Term -> Term
C.TyLam TyVar
nmTV (
  TyVar -> Term -> Term
C.TyLam TyVar
aTV (
  Id -> Term -> Term
C.Lam   Id
xId (
  (TickInfo -> Term -> Term
C.Tick (NameMod -> Type -> TickInfo
C.NameMod NameMod
sa (TyVar -> Type
C.VarTy TyVar
nmTV)) (Id -> Term
C.Var Id
xId)))))
  where
    (C.FunTy Type
xTy Type
_)  = Type -> TypeView
C.tyView Type
funTy
    -- Safe to use `mkUnsafeSystemName` here, because we're building the
    -- identity \x.x, so any shadowing of 'x' would be the desired behavior.
    xName :: Name a
xName            = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
0
    xId :: Id
xId              = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName

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


-- | Given the type:
--
-- @forall (a :: Type) . String -> a -> a@
--
-- Generate the term:
--
-- @/\(a:Type).\(ctx:String).\(x:a) -> x@
xToErrorCtxTerm
  :: C.Type
  -> C.Term
xToErrorCtxTerm :: Type -> Term
xToErrorCtxTerm (C.ForAllTy TyVar
aTV Type
funTy) =
  TyVar -> Term -> Term
C.TyLam TyVar
aTV (
  Id -> Term -> Term
C.Lam Id
ctxId (
  Id -> Term -> Term
C.Lam Id
xId (
  Id -> Term
C.Var Id
xId)))
  where
    (C.FunTy Type
ctxTy Type
rTy) = Type -> TypeView
C.tyView Type
funTy
    (C.FunTy Type
xTy Type
_)     = Type -> TypeView
C.tyView Type
rTy
    -- Safe to use `mkUnsafeSystemName` here, because we're building the
    -- identity \_ x.x, so any shadowing of 'x' would be the desired behavior.
    ctxName :: Name a
ctxName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"ctx" Int
0
    ctxId :: Id
ctxId   = Type -> Name Term -> Id
C.mkLocalId Type
ctxTy Name Term
forall a. Name a
ctxName
    xName :: Name a
xName   = Text -> Int -> Name a
forall a. Text -> Int -> Name a
C.mkUnsafeSystemName Text
"x" Int
1
    xId :: Id
xId     = Type -> Name Term -> Id
C.mkLocalId Type
xTy Name Term
forall a. Name a
xName

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

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