uhc-light-1.1.9.3: src/UHC/Light/Compiler/AbstractCore.hs
module UHC.Light.Compiler.AbstractCore
( AbstractCore (..)
, ACoreAppLikeMetaBound
, ACoreBindAspectKey (..), ACoreBindAspectKeyS, ACoreBindAspMp
, acbaspkeyMetaLev
, acbaspkeyDefaultTy, acbaspkeyTy, acbaspkeyDefaultCore, acbaspkeyNone, acbaspkeyDefault, acbaspkeyStrict, acbaspkeyDebug
, ppACBaspKeyS
, hsnUniqifyACoreBindAspectKeyS
, ACoreBindRef (..), acoreMkRef, acoreMkAspRef
, acbrefAspAnd
, ppACoreBindRef
, acore1App, acoreApp, acoreAppBound
, acoreLamBind, acoreLam1Ty, acoreLam1, acoreLamTy, acoreLam
, acoreTagTupTy, acoreTagTup, acoreTupTy, acoreTup, acoreTag
, acoreBind1CatTy, acoreBind1Cat, acoreBind1LevTy, acoreBind1Ty, acoreBind1
, acoreBind1Asp1, acoreBind1NmLevTy1, acoreBind1Nm1
, acoreBoundVal1CatTy, acoreBoundVal1Cat, acoreBoundVal1Ty, acoreBoundVal1
, acoreBound1AspkeyVal, acoreBound1Val
, acoreTyErrLift
, acoreLetMerge, acoreLet, acoreLetRec
, acoreLetN
, acoreLet1PlainTy, acoreLet1Plain
, acoreLet1StrictTy, acoreLet1Strict
, acoreLet1StrictIn, acoreLet1StrictInTy
, acoreBindcategDflt
, acoreChar, acoreInt, acoreInt2
, acoreBuiltinApp
, acoreBuiltinAddInt
, acoreBuiltinGtInt
, acoreBuiltinString
, acoreBuiltinError, acoreBuiltinUndefined
, acorePatConMbTag, acoreAltMbTag
, acoreBindNm
, acorePatFldTy
, acoreUnBoundVal
, Coe' (..)
, CoeCtx (..)
, acoreCoeId, acoreCoeMap
, acoreCoeApp1, acoreCoeAppN, acoreCoeAppNbyName
, acoreCoeLam1Ty, acoreCoeLam1
, acoreCoeCompose
, acoreCoeIsId
, CSubstKey (..)
, CSubstInfo' (..)
, CSubst', emptyCSubst
, acoreCSubstFromNmTyL
, acoreCSubstFromRefExprL
, acoreCSubstFromUidExprL
, cSubstAppSubst
, CSubstitutable (..)
, RAlt' (..), RPat' (..), RPatConBind' (..), RPatFld' (..), RCEAltL'
, rcaPat, raltLPatNms
, rcaTag
, raltIsVar, raltIsConst
, raltIsConMany
, raltIsIrrefutable
, rpatConBindUnFlatten
, acoreRPat2Pat
, ctagTrue, ctagFalse
, ctagCons, ctagNil
, CaseAltFailReason (..)
, cafailHasId
, AppFunKind (..)
, WhatExpr (..)
, whatExprMbVar, whatExprMbApp, whatExprMbLam, whatExprMbLam', whatExprAppArity, whatExprMbBind
, whatExprIsWHNF
, whatExprIsLam, whatExprIsTup, whatExprIsBind
, whatExprIsFFI
, acoreNmHolePred, acoreNmHole
, acoreCoeLamLetTy, acoreCoeLamLet, acoreCoeLetRec
, acoreCoePoiLApp, acoreCoeImplsApp
, acoreCoePoiLLamTy, acoreCoeImplsLam
, acoreCSubstFromUidImplsL, acoreCSubstFromUidBindLL
, acoreIf
, acbaspkeyFusionRole
, acoreBuiltinInteger
, raltMbBoolExpr, raltIsBoolExpr
, acoreBuiltinEqChar
, acoreBuiltinListSingleton
, acoreMatchChar )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.TermLike
import UHC.Light.Compiler.Opts.Base
import UHC.Light.Compiler.Ty
import UHC.Util.Pretty
import UHC.Util.Utils
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Applicative ((<|>),(<$>))
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize
{-# LINE 36 "src/ehc/AbstractCore.chs" #-}
class AbstractCore expr bind bound boundmeta bindcateg ty pat patrest patfld alt
| expr -> bind bound boundmeta bindcateg ty pat patrest patfld alt
, bind -> expr
, bound -> expr
, boundmeta -> expr
, bindcateg -> expr
, ty -> expr
, pat -> expr
, patrest -> expr
, patfld -> expr
, alt -> expr
where
------------------------- constructing: expr -------------------------
-- | 1 arg application, together with meta info about the argument, packaged in the bind
acoreLam1Bind :: bind -> expr -> expr
-- | 1 arg application, together with meta info about the argument
-- acoreLam1Ty :: HsName -> ty -> expr -> expr
-- | 1 lam abstraction, together with meta info about, and type of the argument
acore1AppBound :: expr -> bound -> expr
-- | a tuple, with tag, and ty
acoreTagTyTupBound :: CTag -> ty -> [bound] -> expr
-- | a value binding, for a name to value + type + metas + meta level
acoreBind1CatLevTy :: bindcateg -> HsName -> MetaLev -> ty -> expr -> bind
-- | a value binding aspect, for a name + value, optionally type + metas + meta level
acoreBoundVal1CatLevTy :: bindcateg -> HsName -> MetaLev -> ty -> expr -> bound
-- | a type for value binding aspect, for a name + type, optionally meta level
acoreBoundValTy1CatLev :: bindcateg -> HsName -> MetaLev -> ty -> bound
-- | meta for something bound; for a name, meta level and label
acoreBoundmeta :: ACoreBindAspectKeyS -> MetaLev -> CLbl -> boundmeta
-- | a expr binding aspect, for a name, meta level and label
acoreBound1Boundmeta :: boundmeta -> expr -> bound
-- | a binding, for/from a single aspect (for now, later multiple)
acoreBind1Asp :: HsName -> [bound] -> bind
-- | basic let binding
acoreLetBase :: bindcateg -> [bind] -> expr -> expr
-- | cast, defaults to noop
acoreCast :: ty -> expr -> expr
acoreCast _ e = e
-- | A Case expression, possibly with a default value.
acoreCaseDflt :: expr -- ^ The scrutinee. Required to be in WHNF.
-> [alt] -- ^ The alternatives.
-> Maybe expr -- ^ The default value. (TODO what is the behaviour if it is Nothing?)
-> expr
-- | Creates a variable expression.
acoreVar :: HsName -> expr
-- | string
acoreStringTy :: ty -> String -> expr
-- | char
acoreCharTy :: ty -> Char -> expr
-- | int as Int
acoreIntTy :: ty -> Int -> expr
-- | int as Integer
acoreIntTy2 :: ty -> Integer -> expr
-- | hole: placeholder for CSubst to fill in
acoreUidHole :: UID -> expr
-- | hole: let with hole for bindings to be filled in later by means of a CSubst
acoreHoleLet :: UID -> expr -> expr
-- | a default, fallback
-- acoreDflt :: expr
-- | get error/default expr
acoreExprErr :: String -> expr
acoreExprErr s = panic $ "AbstractCore.acoreExprErr: " ++ s
------------------------- constructing: ty constants -------------------------
-- Int
-- acoreTyInt2 :: ty
-- Bool
acoreTyBool :: EHCOpts -> ty
------------------------- constructing: pat -------------------------
-- | pat var, with type
acorePatVarTy :: HsName -> ty -> pat
-- | Matches the case scrutinee with the given constructor tag.
acorePatCon :: CTag -- ^ The constructor to match.
-> patrest -- ^ ???
-> [patfld] -- ^ ???
-> pat
-- | pat int
acorePatIntTy :: ty -> Int -> pat
-- | pat Integer
acorePatIntTy2 :: ty -> Integer -> pat
-- | pat char
acorePatCharTy :: ty -> Char -> pat
-- | pat boolean guard
acorePatBoolExpr :: expr -> pat
------------------------- constructing: pat field -------------------------
-- | TODO ??? pat field
acorePatFldBind :: (HsName,expr) -- ^ lbl, offset ???
-> bind -- ^ ??
-> patfld
-- acorePatFldTy :: ty -> (HsName,expr) -> HsName -> patfld
------------------------- constructing: patrest -------------------------
-- | patrest, empty TODO what does it mean?
acorePatRestEmpty :: patrest
-- | patrest, var
acorePatRestVar :: HsName -> patrest
------------------------- constructing: alt -------------------------
-- | Creates an alternative of a case statement.
acoreAlt :: pat -- ^ The pattern with which to match the case scrutinee.
-> expr -- ^ The value of this alternative.
-> alt
------------------------- constructing: top level -------------------------
-- | Wraps main expr into a form which can be directly run by evaluating
acoreRunMain :: expr -- ^ main
-> expr
acoreRunMain e = acore1App e (acoreTup [])
------------------------- type related -------------------------
-- | construct ty from Ty, usable in Core context
acoreTy2ty :: EHCOpts -> Ty -> ty
------------------------- defaults -------------------------
-- | get default for boundmeta
acoreDfltBoundmeta :: boundmeta
acoreDfltBoundmeta = panic "AbstractCore.acoreDfltBoundmeta not implemented"
-- | get error/default ty, type indexed by ty
acoreTyErr :: String -> ty
acoreTyErr s = panic $ "AbstractCore.acoreTyErr: " ++ s
-- | get the ty representing the absent type, no type info
acoreTyNone :: ty
-- | get char ty
acoreTyChar :: EHCOpts -> ty
-- | get int ty
acoreTyInt :: EHCOpts -> ty
-- | get String ty
acoreTyString :: EHCOpts -> ty
------------------------- bindcateg values -------------------------
-- | get recursive bindcateg
acoreBindcategRec :: bindcateg
-- | get strict bindcateg
acoreBindcategStrict :: bindcateg
-- | get plain bindcateg
acoreBindcategPlain :: bindcateg
------------------------- inspecting/deconstructing -------------------------
-- | is expr an application?
acoreExprMbApp :: expr -> Maybe (expr,bound)
-- | is expr a lambda?
acoreExprMbLam :: expr -> Maybe (bind,expr)
-- | is expr a let?
acoreExprMbLet :: expr -> Maybe (bindcateg,[bind],expr)
-- | is expr a var?
acoreExprMbVar :: expr -> Maybe HsName
-- | is expr a int?
acoreExprMbInt :: expr -> Maybe (ty,Integer)
-- | is bindcateg recursive?
acoreBindcategMbRec :: bindcateg -> Maybe bindcateg
-- | is bindcateg strict?
acoreBindcategMbStrict :: bindcateg -> Maybe bindcateg
-- | is pat a con?
acorePatMbCon :: pat -> Maybe(CTag,patrest,[patfld])
-- | is pat a int?
acorePatMbInt :: pat -> Maybe(ty,Integer)
-- | is pat a char?
acorePatMbChar :: pat -> Maybe(ty,Char)
-- | 'un' alt
acoreUnAlt :: alt -> (pat,expr)
-- | 'un' patfld
acoreUnPatFld :: patfld -> ((HsName,expr),bind)
-- | 'un' patfld
-- acoreUnPatFld :: patfld -> (ty,(HsName,expr),HsName)
-- | 'un' bind
acoreUnBind :: bind -> (HsName,[bound])
-- | is bound a expr?
acoreBoundMbVal :: bound -> Maybe (boundmeta,expr)
------------------------- transforming -------------------------
-- | thunk expr, i.e. turn into delayed computation
acoreExprThunk :: expr -> expr
acoreExprThunk = id
-- | thunk ty, i.e. ty of 'acoreExprThunk'-ed expr
acoreTyThunk :: ty -> ty
acoreTyThunk = id
-- | unthunk expr, i.e. force computation of delayed computation
acoreExprUnThunk :: expr -> expr
acoreExprUnThunk = id
-- | unthunk ty, i.e. ty of 'acoreExprUnThunk'-ed expr
acoreTyUnThunk :: ty -> ty
acoreTyUnThunk = id
------------------------- coercion related: construction -------------------------
-- | coercion arg placeholder
acoreCoeArg :: expr
------------------------- coercion related: inspecting/deconstructing -------------------------
-- | coercion arg placeholder
acoreExprIsCoeArg :: expr -> Bool
{-# LINE 306 "src/ehc/AbstractCore.chs" #-}
type ACoreAppLikeMetaBound = (ACoreBindAspectKeyS,MetaLev,CLbl)
{-# LINE 310 "src/ehc/AbstractCore.chs" #-}
instance {-# OVERLAPPABLE #-} AbstractCore e b bound boundmeta bcat t p pr pf a => AppLike e boundmeta {- () () -} where
app1App = acore1App
appTop = id
appCon = acoreVar . mkHNm
appPar = id
appVar = acoreVar . mkHNm
-- appDflt =
appDfltBoundmeta x = acoreDfltBoundmeta
appDbg = acoreExprErr
appMbCon = acoreExprMbVar
appMbApp1 e = do (f,b) <- acoreExprMbApp e
(_,a) <- acoreBoundMbVal b
return (f,a)
{-# LINE 341 "src/ehc/AbstractCore.chs" #-}
instance {-# OVERLAPPABLE #-} AbstractCore e b bound boundmeta bcat t p pr pf a => RecLike e boundmeta {- () () -} where
recRow _ fs = acoreTagTyTupBound CTagRec (acoreTyErr "AbstractCore.RecLike.recRow") [ acoreBound1Boundmeta (acoreBoundmeta acbaspkeyDefault 0 (CLbl_Nm n)) e | (n,e) <- fs ]
recMbRecRow _= Nothing -- tyMbRecRowWithLkup (const Nothing)
recUnRowExts e= (e,[])
{-# LINE 354 "src/ehc/AbstractCore.chs" #-}
-- | A ACoreBindAspectKeyS formed out of multiple ACoreBindAspectKey identifies a particular binding aspect
data ACoreBindAspectKey
= ACoreBindAspectKey_Default -- identifies the default binding, if omitted in a reference this aspect is the one chosen.
| ACoreBindAspectKey_Ty -- the normal ty
| ACoreBindAspectKey_Strict -- the as strict as possible variant
| ACoreBindAspectKey_Debug -- internal debugging only
| ACoreBindAspectKey_Core -- core
| ACoreBindAspectKey_FusionRole -- fusion role
deriving (Eq,Ord,Generic)
instance Show ACoreBindAspectKey where
show ACoreBindAspectKey_Default = "dft"
show ACoreBindAspectKey_Strict = "str"
show ACoreBindAspectKey_Ty = "ty"
show ACoreBindAspectKey_Debug = "dbg"
show ACoreBindAspectKey_Core = "core"
show ACoreBindAspectKey_FusionRole = "fusionrole"
instance PP ACoreBindAspectKey where
pp = pp . show
type ACoreBindAspectKeyS = Set.Set ACoreBindAspectKey
type ACoreBindAspMp x = Map.Map ACoreBindAspectKeyS x
acbaspkeyMk :: [ACoreBindAspectKey] -> ACoreBindAspectKeyS
acbaspkeyMk = Set.fromList
{-# LINE 399 "src/ehc/AbstractCore.chs" #-}
acbaspkeyMetaLev :: MetaLev -> ACoreBindAspectKeyS -> MetaLev
acbaspkeyMetaLev mlev _ = mlev
{-# LINE 417 "src/ehc/AbstractCore.chs" #-}
-- | predefined:
acbaspkeyNone :: ACoreBindAspectKeyS
acbaspkeyNone = acbaspkeyMk
[ ]
-- | predefined:
acbaspkeyDefault :: ACoreBindAspectKeyS
acbaspkeyDefault = acbaspkeyMk
[ ACoreBindAspectKey_Default ]
-- | predefined:
acbaspkeyTy :: ACoreBindAspectKeyS
acbaspkeyTy = acbaspkeyMk
[ ACoreBindAspectKey_Ty ]
-- | predefined:
acbaspkeyDefaultTy :: ACoreBindAspectKeyS
acbaspkeyDefaultTy = acbaspkeyMk
[ ACoreBindAspectKey_Default, ACoreBindAspectKey_Ty ]
-- | predefined:
acbaspkeyDefaultCore :: ACoreBindAspectKeyS
acbaspkeyDefaultCore = acbaspkeyMk
[ ACoreBindAspectKey_Default, ACoreBindAspectKey_Core ]
-- | predefined:
acbaspkeyStrict :: ACoreBindAspectKeyS
acbaspkeyStrict = acbaspkeyMk
[ ACoreBindAspectKey_Strict ]
-- | predefined:
acbaspkeyDebug :: ACoreBindAspectKeyS
acbaspkeyDebug = acbaspkeyMk
[ ACoreBindAspectKey_Debug ]
{-# LINE 471 "src/ehc/AbstractCore.chs" #-}
-- | predefined:
acbaspkeyFusionRole :: ACoreBindAspectKeyS
acbaspkeyFusionRole = acbaspkeyMk
[ ACoreBindAspectKey_FusionRole ]
{-# LINE 478 "src/ehc/AbstractCore.chs" #-}
ppACBaspKeyS :: ACoreBindAspectKeyS -> PP_Doc
ppACBaspKeyS = ppCurlysCommas . Set.toList
{-# LINE 483 "src/ehc/AbstractCore.chs" #-}
-- | uniqify with ACoreBindAspectKeyS, omitting the default
hsnUniqifyACoreBindAspectKeyS :: ACoreBindAspectKeyS -> HsName -> HsName
hsnUniqifyACoreBindAspectKeyS as n
= foldr mk n $ Set.toList as
where mk ACoreBindAspectKey_Strict = hsnUniqify HsNameUniqifier_Strict
mk a = hsnUniqifyStr HsNameUniqifier_BindAspect (show a)
{-# LINE 492 "src/ehc/AbstractCore.chs" #-}
deriving instance Typeable ACoreBindAspectKey
{-# LINE 500 "src/ehc/AbstractCore.chs" #-}
-- | reference to binding aspect: name + aspect keys
data ACoreBindRef
= ACoreBindRef
{ acbrefNm :: !HsName
, acbrefMbAspKey :: !(Maybe ACoreBindAspectKeyS)
}
deriving (Eq,Ord)
acoreMkRef :: HsName -> ACoreBindRef
acoreMkRef n = ACoreBindRef n Nothing
acoreMkAspRef :: ACoreBindAspectKeyS -> HsName -> ACoreBindRef
acoreMkAspRef a n = ACoreBindRef n (Just a)
instance HSNM ACoreBindRef where
mkHNm (ACoreBindRef n ma) = maybe n (\a -> hsnUniqifyACoreBindAspectKeyS a n) ma
instance Show ACoreBindRef where
show = show . mkHNm
{-# LINE 522 "src/ehc/AbstractCore.chs" #-}
acbrefAspKey :: ACoreBindRef -> ACoreBindAspectKeyS
acbrefAspKey = maybe acbaspkeyNone id . acbrefMbAspKey
{-# INLINE acbrefAspKey #-}
{-# LINE 528 "src/ehc/AbstractCore.chs" #-}
-- | narrow down aspects by adding more to ref; assume extra aspects non empty
acbrefAspAnd :: ACoreBindAspectKeyS -> ACoreBindRef -> ACoreBindRef
acbrefAspAnd a r = r {acbrefMbAspKey = Just $ a `Set.union` acbrefAspKey r }
{-# LINE 534 "src/ehc/AbstractCore.chs" #-}
ppACoreBindRef :: (HsName -> PP_Doc) -> ACoreBindRef -> PP_Doc
ppACoreBindRef ppN r = ppN (acbrefNm r) >|< (maybe empty (ppCurlysCommas . Set.toList) $ acbrefMbAspKey r)
instance PP ACoreBindRef where
pp = ppACoreBindRef pp
{-# LINE 542 "src/ehc/AbstractCore.chs" #-}
deriving instance Typeable ACoreBindRef
{-# LINE 550 "src/ehc/AbstractCore.chs" #-}
acore1App :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => e -> e -> e
acore1App f a = acore1AppBound f (acoreBound1Val a)
{-# INLINE acore1App #-}
-- | Applies the first expression to all given arguments.
acoreApp :: (AbstractCore e b bound boundmeta bcat t p pr pf a)
=> e -- ^ The lambda to apply.
-> [e] -- ^ The arguments (the empty list is allowed).
-> e
acoreApp f as = foldl (\f a -> acore1App f a) f as
acoreAppBound :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => e -> [bound] -> e
acoreAppBound f as = foldl (\f a -> acore1AppBound f a) f as
{-# LINE 570 "src/ehc/AbstractCore.chs" #-}
acoreLamBind :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [b] -> e -> e
acoreLamBind = flip (foldr acoreLam1Bind)
{-# INLINE acoreLamBind #-}
acoreLam1Ty :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> e -> e
acoreLam1Ty a t e = acoreLam1Bind (acoreBind1NmTy1 a t) e
-- acoreLam1Ty a t e = acoreLam1Bind (acoreBind1Nm1 a) e
-- acoreLam1Ty a t e = acoreLam1Bind (acoreBind1Ty a t) e -- 20120418, TBD: ignore type for now
{-# INLINE acoreLam1Ty #-}
acoreLam1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> e -> e
acoreLam1 a e = acoreLam1Ty a (acoreTyErr "acoreLam1") e
{-# INLINE acoreLam1 #-}
acoreLamTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [(HsName,t)] -> e -> e
acoreLamTy as e = foldr (\(n,t) e -> acoreLam1Ty n t e) e as
acoreLam :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [HsName] -> e -> e
acoreLam as e = foldr (\(n) e -> acoreLam1 n e) e as
{-# LINE 592 "src/ehc/AbstractCore.chs" #-}
acoreTagTupTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => CTag -> t -> [e] -> e
acoreTagTupTy tg t es = acoreTagTyTupBound tg t $ map acoreBound1Val es
-- | Creates a new tuple/record with the given values.
-- Has to be fully applied, partial application is not allowed.
acoreTagTup :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => CTag -> [e] -> e
acoreTagTup tg es = acoreTagTupTy tg (acoreTyErr "acoreTupTy") es
acoreTupTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => t -> [e] -> e
acoreTupTy t es = acoreTagTupTy CTagRec t es
{-# INLINE acoreTupTy #-}
acoreTup :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [e] -> e
acoreTup es = acoreTagTup CTagRec es
{-# INLINE acoreTup #-}
acoreTag :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => CTag -> e
acoreTag tg = acoreTagTup tg []
{-# INLINE acoreTag #-}
{-# LINE 625 "src/ehc/AbstractCore.chs" #-}
acoreBind1CatTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => bcat -> HsName -> t -> e -> b
acoreBind1CatTy cat n t e = acoreBind1CatLevTy cat n metaLevVal t e
{-# INLINE acoreBind1CatTy #-}
acoreBind1LevTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> MetaLev -> t -> e -> b
acoreBind1LevTy n l t e = acoreBind1CatLevTy (acoreBindcategDflt e) n l t e
{-# INLINE acoreBind1LevTy #-}
acoreBind1Ty :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> e -> b
acoreBind1Ty n t e = acoreBind1LevTy n metaLevVal t e
{-# INLINE acoreBind1Ty #-}
acoreBind1Cat :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => bcat -> HsName -> e -> b
acoreBind1Cat cat n e = acoreBind1CatTy cat n acoreTyNone {- (acoreTyErr "acoreBind1Cat") -} e
{-# INLINE acoreBind1Cat #-}
acoreBind1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> e -> b
acoreBind1 n e = acoreBind1Cat (acoreBindcategDflt e) n e
{-# INLINE acoreBind1 #-}
{-# LINE 647 "src/ehc/AbstractCore.chs" #-}
acoreBind1Asp1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> bound -> b
acoreBind1Asp1 n ba = acoreBind1Asp n [ba]
{-# INLINE acoreBind1Asp1 #-}
acoreBind1NmLevTy1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> MetaLev -> t -> b
acoreBind1NmLevTy1 n l t = acoreBind1Asp n [acoreBoundValTy1CatLev acoreBindcategPlain n l t]
-- {-# INLINE acoreBind1NmLevTy1 #-}
acoreBind1NmTy1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> b
acoreBind1NmTy1 n t = acoreBind1NmLevTy1 n metaLevTy t
{-# INLINE acoreBind1NmTy1 #-}
acoreBind1Nm1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> b
acoreBind1Nm1 n = acoreBind1Asp n []
{-# INLINE acoreBind1Nm1 #-}
{-# LINE 669 "src/ehc/AbstractCore.chs" #-}
acoreBoundVal1CatTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => bcat -> HsName -> t -> e -> bound
acoreBoundVal1CatTy cat n t e = acoreBoundVal1CatLevTy cat n metaLevVal t e
{-# INLINE acoreBoundVal1CatTy #-}
acoreBoundVal1Cat :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => bcat -> HsName -> e -> bound
acoreBoundVal1Cat cat n e = acoreBoundVal1CatTy cat n (acoreTyErr "acoreBoundVal1Cat") e
{-# INLINE acoreBoundVal1Cat #-}
acoreBoundVal1Ty :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> e -> bound
acoreBoundVal1Ty n t e = acoreBoundVal1CatTy (acoreBindcategDflt e) n t e
{-# INLINE acoreBoundVal1Ty #-}
acoreBoundVal1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> e -> bound
acoreBoundVal1 n e = acoreBoundVal1Ty n (acoreTyErr "acoreBoundVal1") e
{-# INLINE acoreBoundVal1 #-}
{-# LINE 687 "src/ehc/AbstractCore.chs" #-}
acoreBound1AspkeyVal :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => ACoreBindAspectKeyS -> e -> bound
acoreBound1AspkeyVal a e = acoreBound1Boundmeta (acoreBoundmeta a 0 CLbl_None) e
{-# INLINE acoreBound1AspkeyVal #-}
acoreBound1Val :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => e -> bound
acoreBound1Val e = acoreBound1AspkeyVal acbaspkeyDefault e
{-# INLINE acoreBound1Val #-}
{-# LINE 701 "src/ehc/AbstractCore.chs" #-}
acoreTyErrLift :: (AbstractCore e b bound boundmeta bcat t p pr pf a, Functor f) => String -> f x -> f (x,t)
acoreTyErrLift msg = fmap (\n -> (n,acoreTyErr msg))
{-# INLINE acoreTyErrLift #-}
{-# LINE 711 "src/ehc/AbstractCore.chs" #-}
-- | Construct let, possibly merging bindings
acoreLetMerge :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => Bool -> bcat -> [b] -> e -> e
acoreLetMerge merge c bs e
= if null bs
then e
else case acoreBindcategMbStrict c of
{-
Just _
->
-}
_ -> case acoreExprMbLet e of
Just (c',bs',e') | merge && c' == c
-> mk c (bs++bs') e'
_ -> mk c bs e
where mk c bs e
= case acoreBindcategMbRec c of
Just c -> acoreLetBase c bs e
_ -> foldr (\b e -> acoreLetBase c [b] e) e bs
acoreLet :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => bcat -> [b] -> e -> e
acoreLet c bs e = acoreLetMerge False c bs e
{-# INLINE acoreLet #-}
-- | Creates a let binding, where the bindings may be mutually recursive.
acoreLetRec :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a)
=> [b] -- ^ The bindings.
-> e -- ^ The body.
-> e
acoreLetRec bs e = acoreLet (acoreBindcategRec) bs e
{-# INLINE acoreLetRec #-}
{-# LINE 744 "src/ehc/AbstractCore.chs" #-}
acoreLetN :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => [(bcat,[b])] -> e -> e
acoreLetN cbs e = foldr (\(c,bs) e -> acoreLet c bs e) e cbs
{-# LINE 749 "src/ehc/AbstractCore.chs" #-}
acoreLet1PlainTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> e -> e -> e
acoreLet1PlainTy nm t e
= acoreLet cat [acoreBind1CatTy cat nm t e]
where cat = acoreBindcategPlain
-- | Creates a (non-recursive) let binding.
acoreLet1Plain :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a)
=> HsName -- ^ The identifier.
-> e -- ^ The expression to bind.
-> e -- ^ The body.
-> e
acoreLet1Plain nm e = acoreLet1PlainTy nm (acoreTyErr "acoreLet1Plain") e
{-# INLINE acoreLet1Plain #-}
{-# LINE 765 "src/ehc/AbstractCore.chs" #-}
acoreLet1StrictTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> e -> e -> e
acoreLet1StrictTy nm t e
= acoreLet cat [acoreBind1CatTy cat nm t e]
where cat = acoreBindcategStrict
-- | Creates a let binding, which is strict in the bound expression.
acoreLet1Strict :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a)
=> HsName -- ^ The identifer.
-> e -- ^ The expression to bind. Will be evaluated to WHNF, before the body is evaluated.
-> e -- ^ The body.
-> e
acoreLet1Strict nm e = acoreLet1StrictTy nm (acoreTyErr "acoreLet1Strict") e
{-# INLINE acoreLet1Strict #-}
{-# LINE 781 "src/ehc/AbstractCore.chs" #-}
-- | evaluate an expr, with a continuation for the evaluated expr
acoreLet1StrictInTyWith :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => (t->t) -> (e->e) -> HsName -> t -> e -> (e -> e) -> e
acoreLet1StrictInTyWith mkT mkE nm t e mkC
= acoreLetBase cat [acoreBind1CatTy cat nm (mkT t) (mkE e)] (mkC (acoreVar nm))
where cat = acoreBindcategStrict
acoreMbLet1StrictInTyWith :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => (t->t) -> (e->e) -> Maybe (HsName,t) -> e -> (e -> e) -> e
acoreMbLet1StrictInTyWith mkT mkE (Just (nm,t)) e mkC = acoreLet1StrictInTyWith mkT mkE nm t e mkC
acoreMbLet1StrictInTyWith _ _ _ e mkC = mkC e
acoreLet1StrictInTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> e -> (e -> e) -> e
acoreLet1StrictInTy = acoreLet1StrictInTyWith acoreTyUnThunk acoreExprUnThunk
{-# INLINE acoreLet1StrictInTy #-}
acoreLet1StrictIn :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> e -> (e -> e) -> e
acoreLet1StrictIn nm e mkC = acoreLet1StrictInTy nm (acoreTyErr "acoreLet1StrictIn") e mkC
{-# INLINE acoreLet1StrictIn #-}
{-# LINE 805 "src/ehc/AbstractCore.chs" #-}
acoreNmHole :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => UID -> e
acoreNmHole = acoreVar . mkHNm
acoreNmHolePred :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => PredOccId -> e
acoreNmHolePred = acoreNmHole . poiId
{-# LINE 817 "src/ehc/AbstractCore.chs" #-}
-- | get default for bindcateg
acoreBindcategDflt :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => e -> bcat
acoreBindcategDflt _ = acoreBindcategPlain
{-# INLINE acoreBindcategDflt #-}
{-# LINE 828 "src/ehc/AbstractCore.chs" #-}
acoreChar :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> Char -> e
acoreChar opts i = let x = acoreCharTy (acoreTyChar opts) i in x
-- | Creates an `Int` constant.
acoreInt :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> Int -> e
acoreInt opts i = let x = acoreIntTy (acoreTyInt opts) i in x
acoreInt2 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> Integer -> e
acoreInt2 opts i = let x = acoreIntTy2 (acoreTyInt opts) i in x
{-# LINE 844 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinApp :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> (EHBuiltinNames -> HsName) -> [e] -> e
acoreBuiltinApp opts bnmOf args = acoreVar (ehcOptBuiltin opts bnmOf) `acoreApp` args
{-# LINE 849 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinAddInt :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> e -> Int -> e
acoreBuiltinAddInt opts e i
= if i == 0
then e
else case acoreExprMbInt e of
Just (t,i') -> acoreIntTy2 t (toInteger i + i')
_ -> acoreBuiltinApp opts ehbnPrimAddInt [e,acoreInt opts i]
{-# LINE 859 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinGtInt :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> e -> Int -> e
acoreBuiltinGtInt opts e i = acoreBuiltinApp opts ehbnPrimGtInt [e,acoreInt opts i]
{-# LINE 864 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinEqChar :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> Char -> e -> e
acoreBuiltinEqChar opts c e = acoreBuiltinApp opts ehbnPrimEqChar [e,acoreChar opts c]
{-# LINE 869 "src/ehc/AbstractCore.chs" #-}
-- | Creates a string expression.
-- The expression represents a packed String, which can be passed to Haskell generated Core functions.
acoreBuiltinString :: (AbstractCore e b bound boundmeta bcat t p pr pf a)
=> EHCOpts
-> String -- ^ The string.
-> e
acoreBuiltinString opts m = let x = acoreBuiltinApp opts ehbnPackedStringToString [acoreStringTy (acoreTyString opts) m] in x
{-# LINE 879 "src/ehc/AbstractCore.chs" #-}
-- | Generates an error expression, failing with the given string when evaluated. ('error' in haskell)
acoreBuiltinError :: (AbstractCore e b bound boundmeta bcat t p pr pf a)
=> EHCOpts
-> String -- ^ The error message.
-> e
acoreBuiltinError opts m = acoreBuiltinApp opts ehbnError [acoreBuiltinString opts m]
-- | Generates an undefined expression, failing when evaluated. ('undefined' in haskell)
acoreBuiltinUndefined :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> e
acoreBuiltinUndefined opts = acoreBuiltinApp opts ehbnUndefined []
{-# LINE 892 "src/ehc/AbstractCore.chs" #-}
-- | Creates a Core 'Integer' constant.
acoreBuiltinInteger :: (AbstractCore e b bound boundmeta bcat t p pr pf a)
=> EHCOpts
-> Integer -- ^ The integer.
-> e
acoreBuiltinInteger opts i = acoreBuiltinApp opts ehbnPackedStringToInteger [acoreStringTy (acoreTyString opts) (show i)]
{-# LINE 901 "src/ehc/AbstractCore.chs" #-}
-- | Builtin list singleton (note: hardcoded of tags)
acoreBuiltinListSingleton :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> e -> e
acoreBuiltinListSingleton opts e
= acoreTagTupTy (ctagCons opts) (acoreTyErr "acoreBuiltinListSingleton.Cons") [e, acoreTagTupTy (ctagNil opts) (acoreTyErr "acoreBuiltinListSingleton.Nil") []]
{-# LINE 912 "src/ehc/AbstractCore.chs" #-}
-- | when pat is con get tag
acorePatConMbTag :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => p -> Maybe CTag
acorePatConMbTag = fmap (\(tg,_,_) -> tg) . acorePatMbCon
-- | possibly get tag of alt
acoreAltMbTag :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => a -> Maybe CTag
acoreAltMbTag = (\p -> (\(tg,_,_) -> tg) <$> acorePatMbCon p
<|> (const ctagInt) <$> acorePatMbInt p
-- <|> (const ctagChar) <$> acorePatMbChar p
) . fst . acoreUnAlt
{-# LINE 929 "src/ehc/AbstractCore.chs" #-}
-- | bound name of binding
acoreBindNm :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => b -> HsName
acoreBindNm = fst . acoreUnBind
{-# INLINE acoreBindNm #-}
{-# LINE 940 "src/ehc/AbstractCore.chs" #-}
-- | bound name of binding
acorePatFldTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => t -> (HsName,e) -> HsName -> pf
acorePatFldTy t lbloff n = acorePatFldBind lbloff (acoreBind1NmTy1 n t)
{-# INLINE acorePatFldTy #-}
{-# LINE 951 "src/ehc/AbstractCore.chs" #-}
-- | possible expr of bound (may panic)
acoreUnBoundVal :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => bound -> e
acoreUnBoundVal = maybe (panic "acoreBoundMbVal") (\(_,a) -> a) . acoreBoundMbVal
{-# INLINE acoreUnBoundVal #-}
{-# LINE 962 "src/ehc/AbstractCore.chs" #-}
-- | Construct 'if' expression. Hardcoded: tag nr, ordered alts (by tag)
acoreIf :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> Maybe HsName -> e -> e -> e -> e
acoreIf opts cn c t f
= acoreMbLet1StrictInTyWith id id (fmap (\n -> (n,acoreTyBool opts)) cn) c
$ (\c -> acoreCaseDflt c
[ acoreAlt (acorePatCon (ctagFalse opts) acorePatRestEmpty []) f
, acoreAlt (acorePatCon (ctagTrue opts) acorePatRestEmpty []) t
]
Nothing {-(tcUndefined opts)-}
)
{-# LINE 975 "src/ehc/AbstractCore.chs" #-}
acoreMatchChar :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> Maybe HsName -> Char -> e -> e -> e -> e
acoreMatchChar opts cn cchar cexpr t f
= acoreIf opts cn (acoreBuiltinEqChar opts cchar cexpr) t f
{-# LINE 1005 "src/ehc/AbstractCore.chs" #-}
data Coe' expr bind bindasp ty
= Coe_Map !(expr -> expr) -- normal, expression as function
| Coe_C !expr -- constant
| Coe_Compose !(Coe' expr bind bindasp ty) -- composition
!(Coe' expr bind bindasp ty)
| Coe_App1 !expr -- apply
| Coe_App [HsName] -- apply n args
| Coe_Lam !HsName !ty -- lambda
| Coe_CloseExists !TyVarId !ty !ty -- closing existential
| Coe_OpenExists !TyVarId !ty !ty -- opening existential
| Coe_LamLet !HsName !ty !UID -- lambda with a let binding in the body
| Coe_LetRec ![bind] -- let rec
| Coe_ImplApp !ImplsVarId -- implicits, for apply
| Coe_ImplLam !ImplsVarId -- implicits, for lambda
instance Show (Coe' expr bind bindasp ty) where
show _ = "COE"
{-# LINE 1042 "src/ehc/AbstractCore.chs" #-}
-- | Coercions may either be applied or not on type arguments.
-- In particular, due to lack of proper analysis (and generics code like generation),
-- it is only known for arrow and product types how to construct a coercion from its type args, as they directly
-- correspond to values.
--
-- A CoeCtx encodes this yes/no may allow.
-- A CoeCtx is isomorphic (for now) to Bool.
data CoeCtx
= CoeCtx_Allow
| CoeCtx_DontAllow
deriving
( Eq, Show
, Typeable
)
{-# LINE 1065 "src/ehc/AbstractCore.chs" #-}
-- | Non inspectable, most general, coercion
acoreCoeMap :: (e -> e) -> Coe' e b ba t
acoreCoeMap = Coe_Map
{-# INLINE acoreCoeMap #-}
-- | Coe identity
acoreCoeId :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => Coe' e b ba t
acoreCoeId = Coe_C acoreCoeArg
{-# INLINE acoreCoeId #-}
{-# LINE 1077 "src/ehc/AbstractCore.chs" #-}
acoreCoeLamLetTy :: HsName -> t -> UID -> Coe' e b ba t
acoreCoeLamLetTy = Coe_LamLet
{-# INLINE acoreCoeLamLetTy #-}
acoreCoeLamLet :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> UID -> Coe' e b ba t
acoreCoeLamLet n u = acoreCoeLamLetTy n (acoreTyErr "acoreCoeLamLet") u
{-# INLINE acoreCoeLamLet #-}
-- | Let still requiring a body
acoreCoeLetRec :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [b] -> Coe' e b ba t
acoreCoeLetRec [] = acoreCoeId
acoreCoeLetRec bs = Coe_LetRec bs
{-# LINE 1092 "src/ehc/AbstractCore.chs" #-}
-- | Application still requiring a function
acoreCoeApp1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => e -> Coe' e b ba t
acoreCoeApp1 = Coe_App1
{-# INLINE acoreCoeApp1 #-}
acoreCoeAppNbyName :: [(HsName)] -> Coe' e b ba t
acoreCoeAppNbyName = Coe_App
{-# INLINE acoreCoeAppNbyName #-}
-- acoreCoeApp2 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [(e)] -> Coe' e b ba t
-- acoreCoeApp2 as = acoreCoeMap (\e -> acoreApp e as)
acoreCoeAppN :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [e] -> Coe' e b ba t
acoreCoeAppN as = acoreCoeMap (\e -> acoreApp e as)
{-# INLINE acoreCoeAppN #-}
{-# LINE 1110 "src/ehc/AbstractCore.chs" #-}
-- | Lambda still requiring a body
acoreCoeLam1Ty :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> t -> Coe' e b ba t
acoreCoeLam1Ty = Coe_Lam
{-# INLINE acoreCoeLam1Ty #-}
acoreCoeLam1 :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => HsName -> Coe' e b ba t
acoreCoeLam1 n = acoreCoeLam1Ty n (acoreTyErr "acoreCoeLam1")
{-# INLINE acoreCoeLam1 #-}
{-# LINE 1121 "src/ehc/AbstractCore.chs" #-}
-- | Composition of 2 Coe's
acoreCoeCompose :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => Coe' e b ba t -> Coe' e b ba t -> Coe' e b ba t
acoreCoeCompose c1 c2
| acoreCoeIsId c1 = c2
| otherwise = Coe_Compose c1 c2
{-# LINE 1130 "src/ehc/AbstractCore.chs" #-}
acoreCoePoiLApp :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => [PredOccId] -> [Coe' e b ba t]
acoreCoePoiLApp = map (\i -> acoreCoeApp1 (acoreNmHolePred i))
acoreCoeImplsApp :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => Impls -> [Coe' e b ba t]
acoreCoeImplsApp = acoreCoePoiLApp . implsPrIdL
{-# LINE 1138 "src/ehc/AbstractCore.chs" #-}
acoreCoePoiLLamTy :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => Coe' e b ba t -> [(PredOccId,t)] -> [Coe' e b ba t]
acoreCoePoiLLamTy onLast poiL
= case map mk poiL of
l@(_:_) -> h ++ [t `acoreCoeCompose` onLast]
where (h,t) = fromJust $ initlast l
_ | acoreCoeIsId onLast -> []
| otherwise -> [onLast]
where mk (poi,ty) = acoreCoeLam1Ty (poiHNm poi) ty
acoreCoeImplsLam :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => Coe' e b ba t -> Impls -> [Coe' e b ba t]
acoreCoeImplsLam onLast is = acoreCoePoiLLamTy onLast (acoreTyErrLift "acoreCoeImplsLam" (implsPrIdL is))
{-# LINE 1156 "src/ehc/AbstractCore.chs" #-}
acoreCoeIsId :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => Coe' e b ba t -> Bool
acoreCoeIsId (Coe_C e) = acoreExprIsCoeArg e
acoreCoeIsId _ = False
{-# LINE 1166 "src/ehc/AbstractCore.chs" #-}
data CSubstKey
= CSKey_UID UID
| CSKey_Nm HsName
| CSKey_Ref ACoreBindRef
deriving (Show,Eq,Ord)
{-# LINE 1174 "src/ehc/AbstractCore.chs" #-}
data CSubstInfo' expr bind bindasp ty
= CSITy { csiTy :: !ty
}
| CSIExpr { csiRepl :: !expr
}
| CSIImpls { csiAppCoeL :: ![Coe' expr bind bindasp ty]
, csiLamCoeL :: ![Coe' expr bind bindasp ty]
}
| CSIBinds { csiBindL :: ![bind]
}
instance Show (CSubstInfo' e b ba t) where
show _ = "CSubstInfo'"
{-# LINE 1192 "src/ehc/AbstractCore.chs" #-}
type CSubst' e b ba t = Map.Map CSubstKey (CSubstInfo' e b ba t)
emptyCSubst :: CSubst' e b ba t
emptyCSubst = Map.empty
{-# LINE 1203 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromNmTyL :: AssocL HsName t -> CSubst' e b ba t
acoreCSubstFromNmTyL l = Map.fromList [ (CSKey_Nm k,CSITy v) | (k,v) <- l ]
{-# LINE 1208 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromRefExprL :: AssocL ACoreBindRef e -> CSubst' e b ba t
acoreCSubstFromRefExprL l = Map.fromList [ (CSKey_Ref k,CSIExpr v) | (k,v) <- l ]
{-# LINE 1213 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromUidExprL :: AssocL UID e -> CSubst' e b ba t
acoreCSubstFromUidExprL l = Map.fromList [ (CSKey_UID k,CSIExpr v) | (k,v) <- l ]
{-# LINE 1218 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromUidBindLL :: AssocL UID [b] -> CSubst' e b ba t
acoreCSubstFromUidBindLL l = Map.fromList [ (CSKey_UID k,CSIBinds v) | (k,v) <- l ]
acoreCSubstFromUidImplsL :: AssocL UID ([Coe' e b ba t],[Coe' e b ba t]) -> CSubst' e b ba t
acoreCSubstFromUidImplsL l = Map.fromList [ (CSKey_UID k,uncurry CSIImpls v) | (k,v) <- l ]
{-# LINE 1230 "src/ehc/AbstractCore.chs" #-}
-- | Combine CSubst: union only, application is postponed
cSubstAppSubst :: CSubst' e b ba t -> CSubst' e b ba t -> CSubst' e b ba t
cSubstAppSubst = Map.union
{-# LINE 1240 "src/ehc/AbstractCore.chs" #-}
infixr `cSubstApp`
class CSubstitutable e b ba t a
| a -> e b ba t
where
cSubstApp :: CSubst' e b ba t -> a -> a
instance CSubstitutable e b ba t (CSubst' e b ba t) where
cSubstApp cs s = cs `cSubstAppSubst` s
{-# LINE 1256 "src/ehc/AbstractCore.chs" #-}
data RAlt' e t b pr
= RAlt_Alt { rcaPats :: ![RPat' e t b pr], raaExpr :: !e, raaFailS :: UIDS }
data RPat' e t b pr
= RPat_Var { rcpPNm :: !RPatNm, rcpTy :: !t, rcpMustEval :: Bool }
| RPat_Con { rcpPNm :: !RPatNm, rcpTy :: !t, rcpTag :: !CTag, rcpBinds :: !(RPatConBind' e t b pr) }
| RPat_Int { rcpPNm :: !RPatNm, rcpTy :: !t, rcpInt :: !Integer }
| RPat_Char { rcpPNm :: !RPatNm, rcpTy :: !t, rcpChar :: !Char }
| RPat_Irrefutable { rcpPNm :: !RPatNm, rcpTy :: !t, rcpValBindL :: ![b] }
| RPat_BoolExpr { rcpPNm :: !RPatNm, rcpTy :: !t, rcpExpr :: !e, rcpMbConst :: Maybe SrcConst }
data RPatConBind' e t b pr
= RPatConBind_One { rpcbRest :: !pr, rpcbBinds :: ![RPatFld' e t b pr] }
| RPatConBind_Many { rpcbConBinds :: ![RPatConBind' e t b pr] }
data RPatFld' e t b pr
= RPatFld_Fld { rpbLbl :: !HsName, rpbOffset :: !e, rpbNm :: !HsName, rpbPat :: !(RPat' e t b pr)}
type RCEAltL' e t b pr = [RAlt' e t b pr]
{-# LINE 1280 "src/ehc/AbstractCore.chs" #-}
rcaPat :: RAlt' e t b pr -> RPat' e t b pr
rcaPat = head . rcaPats
raltLPatNms :: [RAlt' e t b pr] -> [RPatNm]
raltLPatNms = nub . sort . map (rcpPNm . rcaPat)
{-# LINE 1288 "src/ehc/AbstractCore.chs" #-}
rpatConTag :: RPat' e t b pr -> CTag
rpatConTag (RPat_Int _ _ _ ) = ctagInt
rpatConTag (RPat_Char _ _ _ ) = ctagChar
rpatConTag p = rcpTag p
rcaTag :: RAlt' e t b pr -> CTag
rcaTag = rpatConTag . head . rcaPats
{-# LINE 1298 "src/ehc/AbstractCore.chs" #-}
raltIsVar :: RAlt' e t b pr -> Bool
raltIsVar (RAlt_Alt (RPat_Var _ _ _ : _) _ _) = True
raltIsVar _ = False
raltIsConst :: RAlt' e t b pr -> Bool
raltIsConst (RAlt_Alt (p : _) _ _)
= c p
where c (RPat_Int _ _ _) = True
c (RPat_Char _ _ _) = True
c _ = False
raltIsConst _ = False
{-# LINE 1312 "src/ehc/AbstractCore.chs" #-}
raltIsConMany :: RAlt' e t b pr -> Bool
raltIsConMany (RAlt_Alt (RPat_Con _ _ _ (RPatConBind_Many _) : _) _ _) = True
raltIsConMany _ = False
{-# LINE 1318 "src/ehc/AbstractCore.chs" #-}
raltIsIrrefutable :: RAlt' e t b pr -> Bool
raltIsIrrefutable (RAlt_Alt (RPat_Irrefutable _ _ _ : _) _ _) = True
raltIsIrrefutable _ = False
{-# LINE 1324 "src/ehc/AbstractCore.chs" #-}
raltMbBoolExpr :: RAlt' e t b pr -> Maybe (Maybe SrcConst)
raltMbBoolExpr (RAlt_Alt (RPat_BoolExpr _ _ _ e : _) _ _) = Just e
raltMbBoolExpr _ = Nothing
raltIsBoolExpr :: RAlt' e t b pr -> Bool
raltIsBoolExpr = isJust . raltMbBoolExpr
{-# LINE 1335 "src/ehc/AbstractCore.chs" #-}
rpatConBindUnFlatten :: RPatConBind' e t b pr -> [RPatConBind' e t b pr] -> RPatConBind' e t b pr
rpatConBindUnFlatten z [] = z
rpatConBindUnFlatten _ [b] = b
rpatConBindUnFlatten _ bs = RPatConBind_Many bs
{-# LINE 1346 "src/ehc/AbstractCore.chs" #-}
acoreRPat2Pat :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => RPat' e t b pr -> p
acoreRPat2Pat p
= case p of
RPat_Var n ty _ -> acorePatVarTy (rpatNmNm n) ty
RPat_Con n _ t b -> acorePatCon t r bs
where (r,bs) = acoreRPatConBind2PatConBind b
RPat_Int n ty v -> acorePatIntTy2 ty v
RPat_Char n ty v -> acorePatCharTy ty v
RPat_BoolExpr n _ v _ -> acorePatBoolExpr v
{-# LINE 1360 "src/ehc/AbstractCore.chs" #-}
acoreRPatConBind2PatConBind :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => RPatConBind' e t b pr -> (pr,[pf])
acoreRPatConBind2PatConBind b
= case b of
RPatConBind_One r bs -> (r,map acoreRPatBind2PatFld bs)
RPatConBind_Many bs -> head (map acoreRPatConBind2PatConBind bs)
acoreRPatBind2PatFld :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => RPatFld' e t b pr -> pf
acoreRPatBind2PatFld (RPatFld_Fld l o _ p@(RPat_Var n _ _)) = acorePatFldTy (rcpTy p) (l,o) (rpatNmNm n)
{-# LINE 1377 "src/ehc/AbstractCore.chs" #-}
ctagTrue, ctagFalse :: EHCOpts -> CTag
ctagTrue opts = CTag (ehcOptBuiltin opts ehbnDataBool) (ehcOptBuiltin opts ehbnBoolTrue) tagBoolTrue 0 0 -- this makes it hardcoded, ideally dependent on datatype def itself !!
ctagFalse opts = CTag (ehcOptBuiltin opts ehbnDataBool) (ehcOptBuiltin opts ehbnBoolFalse) tagBoolFalse 0 0 -- this makes it hardcoded, ideally dependent on datatype def itself !!
{-# LINE 1389 "src/ehc/AbstractCore.chs" #-}
ctagCons, ctagNil :: EHCOpts -> CTag
ctagCons opts = CTag (ehcOptBuiltin opts ehbnDataList) (ehcOptBuiltin opts ehbnDataListAltCons) tagListCons 2 2 -- this makes it hardcoded, ideally dependent on datatype def itself !!
ctagNil opts = CTag (ehcOptBuiltin opts ehbnDataList) (ehcOptBuiltin opts ehbnDataListAltNil ) tagListNil 0 2 -- this makes it hardcoded, ideally dependent on datatype def itself !!
{-# LINE 1399 "src/ehc/AbstractCore.chs" #-}
-- | Reason to fail a case alternative
data CaseAltFailReason
= CaseAltFailReason_Absence -- failed because of absence
| CaseAltFailReason_Continue
{ cafailCaseId :: UID -- failed as part of case match attempt, but continues with code identified by id
}
deriving (Show,Eq,Ord,Generic)
instance PP CaseAltFailReason where
pp (CaseAltFailReason_Continue i) = pp i
pp (CaseAltFailReason_Absence ) = pp "absent"
{-# LINE 1413 "src/ehc/AbstractCore.chs" #-}
cafailHasId :: CaseAltFailReason -> (Bool,UID)
cafailHasId (CaseAltFailReason_Absence ) = (False,uidUnused)
cafailHasId (CaseAltFailReason_Continue i) = (True ,i)
{-# LINE 1419 "src/ehc/AbstractCore.chs" #-}
deriving instance Typeable CaseAltFailReason
{-# LINE 1427 "src/ehc/AbstractCore.chs" #-}
data AppFunKind
= AppFunKind_NoApp -- inlined Nothing
| AppFunKind_Fun ACoreBindRef
| AppFunKind_Tag CTag
| AppFunKind_FFI
{-# LINE 1439 "src/ehc/AbstractCore.chs" #-}
-- | What kind of Expr?
data WhatExpr
= ExprIsLam Int -- arity
(Maybe HsName) -- possibly name bound to
| ExprIsApp Int -- arity
WhatExpr -- function
| ExprIsVar HsName
| ExprIsInt Int
| ExprIsTup CTag
| ExprIsFFI
| ExprIsOtherWHNF
| ExprIsOther
| ExprIsBind HsName
deriving Eq
{-# LINE 1457 "src/ehc/AbstractCore.chs" #-}
-- | is an var?
whatExprMbVar :: WhatExpr -> Maybe HsName
whatExprMbVar (ExprIsVar a) = Just a
whatExprMbVar _ = Nothing
-- | is an app?
whatExprMbApp :: WhatExpr -> Maybe (Int,WhatExpr)
whatExprMbApp (ExprIsApp a w) = Just (a,w)
whatExprMbApp _ = Nothing
-- | is a lam?
whatExprMbLam' :: WhatExpr -> Maybe (Int, Maybe HsName)
whatExprMbLam' (ExprIsLam a n) = Just (a, n)
whatExprMbLam' _ = Nothing
-- | is a lam?
whatExprMbLam :: WhatExpr -> Maybe Int
whatExprMbLam (ExprIsLam a _) = Just a
whatExprMbLam _ = Nothing
-- | is a bind?
whatExprMbBind :: WhatExpr -> Maybe HsName
whatExprMbBind (ExprIsBind n) = Just n
whatExprMbBind _ = Nothing
-- | app arity
whatExprAppArity :: WhatExpr -> Int
whatExprAppArity (ExprIsApp a _) = a
whatExprAppArity _ = 0
{-# LINE 1489 "src/ehc/AbstractCore.chs" #-}
whatExprIsWHNF :: WhatExpr -> Bool
whatExprIsWHNF (ExprIsLam _ _) = True
whatExprIsWHNF (ExprIsVar _) = True
whatExprIsWHNF (ExprIsInt _) = True
whatExprIsWHNF (ExprIsTup _) = True
whatExprIsWHNF ExprIsOtherWHNF = True
whatExprIsWHNF _ = False
{-# LINE 1499 "src/ehc/AbstractCore.chs" #-}
whatExprIsBind :: WhatExpr -> Bool
whatExprIsBind = isJust . whatExprMbBind
{-# INLINE whatExprIsBind #-}
whatExprIsLam :: WhatExpr -> Bool
whatExprIsLam = isJust . whatExprMbLam
{-# INLINE whatExprIsLam #-}
-- | Is Expr a Tup?
whatExprIsTup :: WhatExpr -> Bool
whatExprIsTup (ExprIsTup _) = True
whatExprIsTup _ = False
{-# LINE 1515 "src/ehc/AbstractCore.chs" #-}
-- | Is Expr a FFI?
whatExprIsFFI :: WhatExpr -> Bool
whatExprIsFFI (ExprIsFFI ) = True
whatExprIsFFI _ = False
{-# LINE 1533 "src/ehc/AbstractCore.chs" #-}
instance Serialize ACoreBindAspectKey
{-# LINE 1572 "src/ehc/AbstractCore.chs" #-}
instance Serialize ACoreBindRef where
sput (ACoreBindRef a b) = sput a >> sput b
sget = liftM2 ACoreBindRef sget sget
{-# LINE 1578 "src/ehc/AbstractCore.chs" #-}
instance Serialize CaseAltFailReason
{-# LINE 1597 "src/ehc/AbstractCore.chs" #-}
instance PP CSubstKey where
pp (CSKey_UID i) = pp i
pp (CSKey_Nm n) = pp n
pp (CSKey_Ref r) = pp r
{-# LINE 1604 "src/ehc/AbstractCore.chs" #-}
instance (PP expr, PP ty) => PP (CSubstInfo' expr bind bindasp ty) where
pp (CSITy t ) = pp t
pp (CSIExpr e ) = pp e
pp (CSIImpls l r ) = pp "CSIImpls" -- pp (fst $ coeWeaveOnAsSubst uidStart l r CExpr_CoeArg)
pp (CSIBinds b ) = pp "CSIBinds" -- ppCBindL b