uhc-light-1.1.7.0: src/UHC/Light/Compiler/AbstractCore.hs
module UHC.Light.Compiler.AbstractCore
( AbstractCore (..)
, ACoreAppLikeMetaBound
, acoreMetaLift
, ACoreBindAspectKey (..), ACoreBindAspectKeyS, ACoreBindAspMp
, acbaspkeyMetaLev
, acbaspkeyDefaultTy, acbaspkeyTy, acbaspkeyDefaultCore, acbaspkeyNone, acbaspkeyDefault, acbaspkeyDefaultRelevTy, acbaspkeyStrict, acbaspkeyDebug
, ppACBaspKeyS
, hsnUniqifyACoreBindAspectKeyS
, ACoreBindRef (..), acoreMkRef, acoreMkAspRef
, acbrefAspAnd
, ppACoreBindRef
, acore1App, acoreApp, acoreAppBound
, acoreLamBind, acoreLam1Ty, acoreLam1, acoreLamTy, acoreLam
, acoreTagTupTy, acoreTagTup, acoreTupTy, acoreTup, acoreTag
, acoreBind1CatLevMetaTyWith, acoreBind1CatLevMetaTy, acoreBind1CatLevTy, acoreBind1CatMetaTy, acoreBind1CatTy, acoreBind1Cat, acoreBind1LevTy, acoreBind1Ty, acoreBind1
, acoreBind1MetasTy, acoreBind1CatMeta, acoreBind1MetaTy
, acoreBind1Asp1, acoreBind1NmLevTy1, acoreBind1Nm1
, acoreBoundVal1CatLevMetaTy, acoreBoundVal1CatLevTy, acoreBoundVal1CatMetaTy, acoreBoundVal1CatTy, acoreBoundVal1Cat
, acoreBoundVal1Metas, acoreBoundVal1Meta
, acoreBound1AspkeyVal, acoreBound1Val
, acoreTyErrLift
, acoreLetMerge, acoreLet, acoreLetRec
, acoreLetN
, acoreLet1PlainTy, acoreLet1Plain
, acoreLet1StrictTy, acoreLet1Strict
, acoreLet1StrictInMetaTyWith, acoreLet1StrictInMetaTy, acoreLet1StrictInMeta, 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, whatExprAppArity
, whatExprIsWHNF
, whatExprIsLam, whatExprIsTup
, whatExprIsFFI
, acoreMetaLiftDict
, 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
import Data.Typeable (Typeable)
import Data.Generics (Data)
{-# LINE 38 "src/ehc/AbstractCore.chs" #-}
class AbstractCore expr metaval bind bound boundmeta bindcateg metabind ty pat patrest patfld alt
| expr -> metaval bind bound boundmeta bindcateg metabind ty pat patrest patfld alt
, metaval -> expr
, bind -> expr
, bound -> expr
, boundmeta -> expr
, bindcateg -> expr
, metabind -> 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
acoreBind1CatLevMetasTy :: bindcateg -> HsName -> MetaLev -> (metabind,metaval) -> ty -> expr -> bind
-- | a value binding aspect, for a name + value, optionally type + metas + meta level
acoreBoundVal1CatLevMetasTy :: bindcateg -> HsName -> MetaLev -> (metabind,metaval) -> 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
acoreBound1MetaVal :: 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
-- | case, with possible default
acoreCaseDflt :: expr -> [alt] -> Maybe expr -> expr
-- | var
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
-- | pat con
acorePatCon :: CTag -> 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 -------------------------
-- | pat field
acorePatFldBind :: (HsName,expr) -> bind -> patfld
-- acorePatFldTy :: ty -> (HsName,expr) -> HsName -> patfld
------------------------- constructing: patrest -------------------------
-- | patrest, empty
acorePatRestEmpty :: patrest
-- | patrest, var
acorePatRestVar :: HsName -> patrest
------------------------- constructing: alt -------------------------
-- | 1 arg application, together with meta info about the argument
acoreAlt :: pat -> expr -> alt
------------------------- type related -------------------------
-- | construct ty from Ty, usable in Core context
acoreTy2ty :: EHCOpts -> Ty -> ty
------------------------- defaults -------------------------
-- | get default for metaval
acoreMetavalDflt :: metaval
-- | get default for metaval, for dicts
acoreMetavalDfltDict :: metaval
-- | get default for metabind
acoreMetabindDflt :: metabind
-- | get default for metabind
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 301 "src/ehc/AbstractCore.chs" #-}
type ACoreAppLikeMetaBound = (ACoreBindAspectKeyS,MetaLev,CLbl)
{-# LINE 305 "src/ehc/AbstractCore.chs" #-}
instance AbstractCore e m b bound boundmeta bcat mbind 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 336 "src/ehc/AbstractCore.chs" #-}
instance AbstractCore e m b bound boundmeta bcat mbind t p pr pf a => RecLike e boundmeta {- () () -} where
recRow _ fs = acoreTagTyTupBound CTagRec (acoreTyErr "AbstractCore.RecLike.recRow") [ acoreBound1MetaVal (acoreBoundmeta acbaspkeyDefault 0 (CLbl_Nm n)) e | (n,e) <- fs ]
recMbRecRow _= Nothing -- tyMbRecRowWithLkup (const Nothing)
recUnRowExts e= (e,[])
{-# LINE 348 "src/ehc/AbstractCore.chs" #-}
acoreMetaLift :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a, Functor f) => f x -> f (x,m)
acoreMetaLift = fmap2Tuple acoreMetavalDflt
{-# LINE 353 "src/ehc/AbstractCore.chs" #-}
acoreMetaLiftDict :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a, Functor f) => f x -> f (x,m)
acoreMetaLiftDict = fmap2Tuple acoreMetavalDfltDict
{-# LINE 363 "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_RelevTy -- the relevance ty
| ACoreBindAspectKey_Strict -- the as strict as possible variant
| ACoreBindAspectKey_Debug -- internal debugging only
| ACoreBindAspectKey_Core -- core
| ACoreBindAspectKey_FusionRole -- fusion role
deriving (Eq,Ord)
instance Show ACoreBindAspectKey where
show ACoreBindAspectKey_Default = "dft"
show ACoreBindAspectKey_Strict = "str"
show ACoreBindAspectKey_Ty = "ty"
show ACoreBindAspectKey_RelevTy = "rty"
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 404 "src/ehc/AbstractCore.chs" #-}
acbaspkeyMetaLev :: MetaLev -> ACoreBindAspectKeyS -> MetaLev
acbaspkeyMetaLev mlev _ = mlev
{-# LINE 415 "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:
acbaspkeyDefaultRelevTy :: ACoreBindAspectKeyS
acbaspkeyDefaultRelevTy = acbaspkeyMk
[ ACoreBindAspectKey_Default, ACoreBindAspectKey_RelevTy ]
-- | predefined:
acbaspkeyStrict :: ACoreBindAspectKeyS
acbaspkeyStrict = acbaspkeyMk
[ ACoreBindAspectKey_Strict ]
-- | predefined:
acbaspkeyDebug :: ACoreBindAspectKeyS
acbaspkeyDebug = acbaspkeyMk
[ ACoreBindAspectKey_Debug ]
{-# LINE 474 "src/ehc/AbstractCore.chs" #-}
-- | predefined:
acbaspkeyFusionRole :: ACoreBindAspectKeyS
acbaspkeyFusionRole = acbaspkeyMk
[ ACoreBindAspectKey_FusionRole ]
{-# LINE 481 "src/ehc/AbstractCore.chs" #-}
ppACBaspKeyS :: ACoreBindAspectKeyS -> PP_Doc
ppACBaspKeyS = ppCurlysCommas . Set.toList
{-# LINE 486 "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 495 "src/ehc/AbstractCore.chs" #-}
deriving instance Typeable ACoreBindAspectKey
deriving instance Data ACoreBindAspectKey
{-# LINE 504 "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 526 "src/ehc/AbstractCore.chs" #-}
acbrefAspKey :: ACoreBindRef -> ACoreBindAspectKeyS
acbrefAspKey = maybe acbaspkeyNone id . acbrefMbAspKey
{-# INLINE acbrefAspKey #-}
{-# LINE 532 "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 538 "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 546 "src/ehc/AbstractCore.chs" #-}
deriving instance Typeable ACoreBindRef
deriving instance Data ACoreBindRef
{-# LINE 555 "src/ehc/AbstractCore.chs" #-}
acore1App :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> e -> e
acore1App f a = acore1AppBound f (acoreBound1Val a)
{-# INLINE acore1App #-}
acoreApp :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> [e] -> e
acoreApp f as = foldl (\f a -> acore1App f a) f as
acoreAppBound :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> [bound] -> e
acoreAppBound f as = foldl (\f a -> acore1AppBound f a) f as
{-# LINE 571 "src/ehc/AbstractCore.chs" #-}
acoreLamBind :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [b] -> e -> e
acoreLamBind = flip (foldr acoreLam1Bind)
{-# INLINE acoreLamBind #-}
acoreLam1Ty :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => HsName -> e -> e
acoreLam1 a e = acoreLam1Ty a (acoreTyErr "acoreLam1") e
{-# INLINE acoreLam1 #-}
acoreLamTy :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => [HsName] -> e -> e
acoreLam as e = foldr (\(n) e -> acoreLam1 n e) e as
{-# LINE 593 "src/ehc/AbstractCore.chs" #-}
acoreTagTupTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => CTag -> t -> [e] -> e
acoreTagTupTy tg t es = acoreTagTyTupBound tg t $ map acoreBound1Val es
acoreTagTup :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => CTag -> [e] -> e
acoreTagTup tg es = acoreTagTupTy tg (acoreTyErr "acoreTupTy") es
acoreTupTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => t -> [e] -> e
acoreTupTy t es = acoreTagTupTy CTagRec t es
{-# INLINE acoreTupTy #-}
acoreTup :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [e] -> e
acoreTup es = acoreTagTup CTagRec es
{-# INLINE acoreTup #-}
acoreTag :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => CTag -> e
acoreTag tg = acoreTagTup tg []
{-# INLINE acoreTag #-}
{-# LINE 624 "src/ehc/AbstractCore.chs" #-}
acoreBind1CatLevMetaTyWith :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => (t->t) -> (e->e) -> bcat -> HsName -> MetaLev -> m -> t -> e -> b
acoreBind1CatLevMetaTyWith mkT mkE cat n l m t e = acoreBind1CatLevMetasTy cat n l (acoreMetabindDflt,m) (mkT t) (mkE e)
{-# INLINE acoreBind1CatLevMetaTyWith #-}
acoreBind1CatLevMetaTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> MetaLev -> m -> t -> e -> b
acoreBind1CatLevMetaTy = acoreBind1CatLevMetaTyWith id id
{-# INLINE acoreBind1CatLevMetaTy #-}
acoreBind1CatLevTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> MetaLev -> t -> e -> b
acoreBind1CatLevTy cat n l t e = acoreBind1CatLevMetaTy cat n l acoreMetavalDflt t e
{-# INLINE acoreBind1CatLevTy #-}
acoreBind1CatMetaTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> m -> t -> e -> b
acoreBind1CatMetaTy cat n m t e = acoreBind1CatLevMetaTy cat n metaLevVal m t e
{-# INLINE acoreBind1CatMetaTy #-}
acoreBind1CatTy :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => HsName -> t -> e -> b
acoreBind1Ty n t e = acoreBind1LevTy n metaLevVal t e
{-# INLINE acoreBind1Ty #-}
acoreBind1Cat :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => HsName -> e -> b
acoreBind1 n e = acoreBind1Cat (acoreBindcategDflt e) n e
{-# INLINE acoreBind1 #-}
{-# LINE 662 "src/ehc/AbstractCore.chs" #-}
acoreBind1MetasTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> (mbind,m) -> t -> e -> b
acoreBind1MetasTy n m t e = acoreBind1CatLevMetasTy (acoreBindcategDflt e) n metaLevVal m t e
{-# INLINE acoreBind1MetasTy #-}
{-
acoreBind1Metas :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> (mbind,m) -> e -> b
acoreBind1Metas n m e = aacoreBind1MetasTy n m acoreTyNone e
{-# INLINE acoreBind1Metas #-}
-}
acoreBind1CatMeta :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> m -> e -> b
acoreBind1CatMeta cat n m e = acoreBind1CatLevMetaTy cat n metaLevVal m (acoreTyErr "acoreBind1CatMeta") e
{-# INLINE acoreBind1CatMeta #-}
acoreBind1MetaTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> m -> t -> e -> b
acoreBind1MetaTy n m t e = acoreBind1MetasTy n (acoreMetabindDflt,m) t e
{-# INLINE acoreBind1MetaTy #-}
{-
acoreBind1Meta :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> m -> e -> b
acoreBind1Meta n m e = acoreBind1MetaTy n m acoreTyNone e
{-# INLINE acoreBind1Meta #-}
-}
{-# LINE 689 "src/ehc/AbstractCore.chs" #-}
acoreBind1Asp1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> bound -> b
acoreBind1Asp1 n ba = acoreBind1Asp n [ba]
{-# INLINE acoreBind1Asp1 #-}
acoreBind1NmLevTy1 :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => HsName -> t -> b
acoreBind1NmTy1 n t = acoreBind1NmLevTy1 n metaLevTy t
{-# INLINE acoreBind1NmTy1 #-}
acoreBind1Nm1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> b
acoreBind1Nm1 n = acoreBind1Asp n []
{-# INLINE acoreBind1Nm1 #-}
{-# LINE 711 "src/ehc/AbstractCore.chs" #-}
acoreBoundVal1CatLevMetaTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> MetaLev -> m -> t -> e -> bound
acoreBoundVal1CatLevMetaTy bcat n mlev m t e = acoreBoundVal1CatLevMetasTy bcat n mlev (acoreMetabindDflt,m) t e
{-# INLINE acoreBoundVal1CatLevMetaTy #-}
acoreBoundVal1CatLevTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> MetaLev -> t -> e -> bound
acoreBoundVal1CatLevTy cat n l t e = acoreBoundVal1CatLevMetaTy cat n l acoreMetavalDflt t e
{-# INLINE acoreBoundVal1CatLevTy #-}
acoreBoundVal1CatMetaTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> m -> t -> e -> bound
acoreBoundVal1CatMetaTy cat n m t e = acoreBoundVal1CatLevMetaTy cat n metaLevVal m t e
{-# INLINE acoreBoundVal1CatMetaTy #-}
acoreBoundVal1CatTy :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => bcat -> HsName -> e -> bound
acoreBoundVal1Cat cat n e = acoreBoundVal1CatTy cat n (acoreTyErr "acoreBoundVal1Cat") e
{-# INLINE acoreBoundVal1Cat #-}
{-# LINE 733 "src/ehc/AbstractCore.chs" #-}
acoreBoundVal1Metas :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> (mbind,m) -> e -> bound
acoreBoundVal1Metas n m e = acoreBoundVal1CatLevMetasTy (acoreBindcategDflt e) n metaLevVal m (acoreTyErr "acoreBoundVal1Metas") e
{-# INLINE acoreBoundVal1Metas #-}
acoreBoundVal1Meta :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> m -> e -> bound
acoreBoundVal1Meta n m e = acoreBoundVal1Metas n (acoreMetabindDflt,m) e
{-# INLINE acoreBoundVal1Meta #-}
{-# LINE 744 "src/ehc/AbstractCore.chs" #-}
acoreBound1AspkeyVal :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => ACoreBindAspectKeyS -> e -> bound
acoreBound1AspkeyVal a e = acoreBound1MetaVal (acoreBoundmeta a 0 CLbl_None) e
{-# INLINE acoreBound1AspkeyVal #-}
acoreBound1Val :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> bound
acoreBound1Val e = acoreBound1AspkeyVal acbaspkeyDefault e
{-# INLINE acoreBound1Val #-}
{-# LINE 764 "src/ehc/AbstractCore.chs" #-}
acoreTyErrLift :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a, Functor f) => String -> f x -> f (x,t)
acoreTyErrLift msg = fmap (\n -> (n,acoreTyErr msg))
{-# INLINE acoreTyErrLift #-}
{-# LINE 774 "src/ehc/AbstractCore.chs" #-}
-- | Construct let, possibly merging bindings
acoreLetMerge :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => bcat -> [b] -> e -> e
acoreLet c bs e = acoreLetMerge False c bs e
{-# INLINE acoreLet #-}
acoreLetRec :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [b] -> e -> e
acoreLetRec bs e = acoreLet (acoreBindcategRec) bs e
{-# INLINE acoreLetRec #-}
{-# LINE 803 "src/ehc/AbstractCore.chs" #-}
acoreLetN :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [(bcat,[b])] -> e -> e
acoreLetN cbs e = foldr (\(c,bs) e -> acoreLet c bs e) e cbs
{-# LINE 808 "src/ehc/AbstractCore.chs" #-}
acoreLet1PlainTy :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> t -> e -> e -> e
acoreLet1PlainTy nm t e
= acoreLet cat [acoreBind1CatTy cat nm t e]
where cat = acoreBindcategPlain
acoreLet1Plain :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> e -> e -> e
acoreLet1Plain nm e = acoreLet1PlainTy nm (acoreTyErr "acoreLet1Plain") e
{-# INLINE acoreLet1Plain #-}
{-# LINE 819 "src/ehc/AbstractCore.chs" #-}
acoreLet1StrictTy :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> t -> e -> e -> e
acoreLet1StrictTy nm t e
= acoreLet cat [acoreBind1CatTy cat nm t e]
where cat = acoreBindcategStrict
acoreLet1Strict :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> e -> e -> e
acoreLet1Strict nm e = acoreLet1StrictTy nm (acoreTyErr "acoreLet1Strict") e
{-# INLINE acoreLet1Strict #-}
{-# LINE 830 "src/ehc/AbstractCore.chs" #-}
-- | evaluate an expr, with a continuation for the evaluated expr
acoreLet1StrictInMetaTyWith :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => (t->t) -> (e->e) -> HsName -> m -> t -> e -> (e -> e) -> e
acoreLet1StrictInMetaTyWith mkT mkE nm m t e mkC
= acoreLetBase cat [acoreBind1CatMetaTy cat nm m (mkT t) (mkE e)] (mkC (acoreVar nm))
where cat = acoreBindcategStrict
acoreMbLet1StrictInMetaTyWith :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => (t->t) -> (e->e) -> Maybe (HsName,t) -> m -> e -> (e -> e) -> e
acoreMbLet1StrictInMetaTyWith mkT mkE (Just (nm,t)) m e mkC = acoreLet1StrictInMetaTyWith mkT mkE nm m t e mkC
acoreMbLet1StrictInMetaTyWith _ _ _ m e mkC = mkC e
acoreLet1StrictInMetaTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> m -> t -> e -> (e -> e) -> e
acoreLet1StrictInMetaTy = acoreLet1StrictInMetaTyWith acoreTyUnThunk acoreExprUnThunk
{-# INLINE acoreLet1StrictInMetaTy #-}
acoreLet1StrictInMeta :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> m -> e -> (e -> e) -> e
acoreLet1StrictInMeta nm m e mkC = acoreLet1StrictInMetaTy nm m (acoreTyErr "acoreLet1StrictInMeta") e mkC
{-# INLINE acoreLet1StrictInMeta #-}
acoreLet1StrictInTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> t -> e -> (e -> e) -> e
acoreLet1StrictInTy nm t e mkC = acoreLet1StrictInMetaTy nm acoreMetavalDflt t e mkC
{-# INLINE acoreLet1StrictInTy #-}
acoreLet1StrictIn :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> e -> (e -> e) -> e
acoreLet1StrictIn nm e mkC = acoreLet1StrictInMeta nm acoreMetavalDflt e mkC
{-# INLINE acoreLet1StrictIn #-}
{-# LINE 862 "src/ehc/AbstractCore.chs" #-}
acoreNmHole :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => UID -> e
acoreNmHole = acoreVar . mkHNm
acoreNmHolePred :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => PredOccId -> e
acoreNmHolePred = acoreNmHole . poiId
{-# LINE 874 "src/ehc/AbstractCore.chs" #-}
-- | get default for bindcateg
acoreBindcategDflt :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> bcat
acoreBindcategDflt _ = acoreBindcategPlain
{-# INLINE acoreBindcategDflt #-}
{-# LINE 885 "src/ehc/AbstractCore.chs" #-}
acoreChar :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> Char -> e
acoreChar opts i = let x = acoreCharTy (acoreTyChar opts) i in x
acoreInt :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> Int -> e
acoreInt opts i = let x = acoreIntTy (acoreTyInt opts) i in x
acoreInt2 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> Integer -> e
acoreInt2 opts i = let x = acoreIntTy2 (acoreTyInt opts) i in x
{-# LINE 900 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinApp :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> (EHBuiltinNames -> HsName) -> [e] -> e
acoreBuiltinApp opts bnmOf args = acoreVar (ehcOptBuiltin opts bnmOf) `acoreApp` args
{-# LINE 905 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinAddInt :: (AbstractCore e m b bound boundmeta bcat mbind 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 915 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinGtInt :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> e -> Int -> e
acoreBuiltinGtInt opts e i = acoreBuiltinApp opts ehbnPrimGtInt [e,acoreInt opts i]
{-# LINE 920 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinEqChar :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> Char -> e -> e
acoreBuiltinEqChar opts c e = acoreBuiltinApp opts ehbnPrimEqChar [e,acoreChar opts c]
{-# LINE 925 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinString :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> String -> e
acoreBuiltinString opts m = let x = acoreBuiltinApp opts ehbnPackedStringToString [acoreStringTy (acoreTyString opts) m] in x
{-# LINE 930 "src/ehc/AbstractCore.chs" #-}
acoreBuiltinError :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> String -> e
acoreBuiltinError opts m = acoreBuiltinApp opts ehbnError [acoreBuiltinString opts m]
acoreBuiltinUndefined :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> e
acoreBuiltinUndefined opts = acoreBuiltinApp opts ehbnUndefined []
{-# LINE 938 "src/ehc/AbstractCore.chs" #-}
-- | Builtin Integer
acoreBuiltinInteger :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> Integer -> e
acoreBuiltinInteger opts i = acoreBuiltinApp opts ehbnPackedStringToInteger [acoreStringTy (acoreTyString opts) (show i)]
{-# LINE 944 "src/ehc/AbstractCore.chs" #-}
-- | Builtin list singleton (note: hardcoded of tags)
acoreBuiltinListSingleton :: (AbstractCore e m b bound boundmeta bcat mbind 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 955 "src/ehc/AbstractCore.chs" #-}
-- | when pat is con get tag
acorePatConMbTag :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => p -> Maybe CTag
acorePatConMbTag = fmap (\(tg,_,_) -> tg) . acorePatMbCon
-- | possibly get tag of alt
acoreAltMbTag :: (AbstractCore e m b bound boundmeta bcat mbind 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 972 "src/ehc/AbstractCore.chs" #-}
-- | bound name of binding
acoreBindNm :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => b -> HsName
acoreBindNm = fst . acoreUnBind
{-# INLINE acoreBindNm #-}
{-# LINE 983 "src/ehc/AbstractCore.chs" #-}
-- | bound name of binding
acorePatFldTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => t -> (HsName,e) -> HsName -> pf
acorePatFldTy t lbloff n = acorePatFldBind lbloff (acoreBind1NmTy1 n t)
{-# INLINE acorePatFldTy #-}
{-# LINE 994 "src/ehc/AbstractCore.chs" #-}
-- | possible expr of bound (may panic)
acoreUnBoundVal :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bound -> e
acoreUnBoundVal = maybe (panic "acoreBoundMbVal") (\(_,a) -> a) . acoreBoundMbVal
{-# INLINE acoreUnBoundVal #-}
{-# LINE 1005 "src/ehc/AbstractCore.chs" #-}
-- | Construct 'if' expression. Hardcoded: tag nr, ordered alts (by tag)
acoreIf :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> Maybe HsName -> e -> e -> e -> e
acoreIf opts cn c t f
= acoreMbLet1StrictInMetaTyWith id id (fmap (\n -> (n,acoreTyBool opts)) cn) acoreMetavalDflt c
$ (\c -> acoreCaseDflt c
[ acoreAlt (acorePatCon (ctagFalse opts) acorePatRestEmpty []) f
, acoreAlt (acorePatCon (ctagTrue opts) acorePatRestEmpty []) t
]
Nothing {-(tcUndefined opts)-}
)
{-# LINE 1018 "src/ehc/AbstractCore.chs" #-}
acoreMatchChar :: (AbstractCore e m b bound boundmeta bcat mbind 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 1048 "src/ehc/AbstractCore.chs" #-}
data Coe' expr metaval bind bindasp ty
= Coe_Map !(expr -> expr) -- normal, expression as function
| Coe_C !expr -- constant
| Coe_Compose !(Coe' expr metaval bind bindasp ty) -- composition
!(Coe' expr metaval 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 metaval bind bindasp ty) where
show _ = "COE"
{-# LINE 1085 "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)
{-# LINE 1103 "src/ehc/AbstractCore.chs" #-}
-- | Non inspectable, most general, coercion
acoreCoeMap :: (e -> e) -> Coe' e m b ba t
acoreCoeMap = Coe_Map
{-# INLINE acoreCoeMap #-}
-- | Coe identity
acoreCoeId :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => Coe' e m b ba t
acoreCoeId = Coe_C acoreCoeArg
{-# INLINE acoreCoeId #-}
{-# LINE 1115 "src/ehc/AbstractCore.chs" #-}
acoreCoeLamLetTy :: HsName -> t -> UID -> Coe' e m b ba t
acoreCoeLamLetTy = Coe_LamLet
{-# INLINE acoreCoeLamLetTy #-}
acoreCoeLamLet :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> UID -> Coe' e m b ba t
acoreCoeLamLet n u = acoreCoeLamLetTy n (acoreTyErr "acoreCoeLamLet") u
{-# INLINE acoreCoeLamLet #-}
-- | Let still requiring a body
acoreCoeLetRec :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [b] -> Coe' e m b ba t
acoreCoeLetRec [] = acoreCoeId
acoreCoeLetRec bs = Coe_LetRec bs
{-# LINE 1130 "src/ehc/AbstractCore.chs" #-}
-- | Application still requiring a function
acoreCoeApp1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> Coe' e m b ba t
acoreCoeApp1 = Coe_App1 -- a acoreMetavalDflt
{-# INLINE acoreCoeApp1 #-}
acoreCoeAppNbyName :: [(HsName)] -> Coe' e m b ba t
acoreCoeAppNbyName = Coe_App
{-# INLINE acoreCoeAppNbyName #-}
-- acoreCoeApp2 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [(e)] -> Coe' e m b ba t
-- acoreCoeApp2 as = acoreCoeMap (\e -> acoreApp e as)
acoreCoeAppN :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [e] -> Coe' e m b ba t
acoreCoeAppN as = acoreCoeMap (\e -> acoreApp e as)
{-# INLINE acoreCoeAppN #-}
{-# LINE 1148 "src/ehc/AbstractCore.chs" #-}
-- | Lambda still requiring a body
acoreCoeLam1Ty :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> t -> Coe' e m b ba t
acoreCoeLam1Ty = Coe_Lam
{-# INLINE acoreCoeLam1Ty #-}
acoreCoeLam1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> Coe' e m b ba t
acoreCoeLam1 n = acoreCoeLam1Ty n (acoreTyErr "acoreCoeLam1")
{-# INLINE acoreCoeLam1 #-}
{-# LINE 1159 "src/ehc/AbstractCore.chs" #-}
-- | Composition of 2 Coe's
acoreCoeCompose :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => Coe' e m b ba t -> Coe' e m b ba t -> Coe' e m b ba t
acoreCoeCompose c1 c2
| acoreCoeIsId c1 = c2
| otherwise = Coe_Compose c1 c2
{-# LINE 1168 "src/ehc/AbstractCore.chs" #-}
acoreCoePoiLApp :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [PredOccId] -> [Coe' e m b ba t]
acoreCoePoiLApp = map (\i -> acoreCoeApp1 (acoreNmHolePred i))
acoreCoeImplsApp :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => Impls -> [Coe' e m b ba t]
acoreCoeImplsApp = acoreCoePoiLApp . implsPrIdL
{-# LINE 1176 "src/ehc/AbstractCore.chs" #-}
acoreCoePoiLLamTy :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => Coe' e m b ba t -> [(PredOccId,t)] -> [Coe' e m 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 m b bound boundmeta bcat mbind t p pr pf a) => Coe' e m b ba t -> Impls -> [Coe' e m b ba t]
acoreCoeImplsLam onLast is = acoreCoePoiLLamTy onLast (acoreTyErrLift "acoreCoeImplsLam" (implsPrIdL is))
{-# LINE 1194 "src/ehc/AbstractCore.chs" #-}
acoreCoeIsId :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => Coe' e m b ba t -> Bool
acoreCoeIsId (Coe_C e) = acoreExprIsCoeArg e
acoreCoeIsId _ = False
{-# LINE 1204 "src/ehc/AbstractCore.chs" #-}
data CSubstKey
= CSKey_UID UID
| CSKey_Nm HsName
| CSKey_Ref ACoreBindRef
deriving (Show,Eq,Ord)
{-# LINE 1212 "src/ehc/AbstractCore.chs" #-}
data CSubstInfo' expr metaval bind bindasp ty
= CSITy { csiTy :: !ty
}
| CSIExpr { csiRepl :: !expr
}
| CSIImpls { csiAppCoeL :: ![Coe' expr metaval bind bindasp ty]
, csiLamCoeL :: ![Coe' expr metaval bind bindasp ty]
}
| CSIBinds { csiBindL :: ![bind]
}
instance Show (CSubstInfo' e m b ba t) where
show _ = "CSubstInfo'"
{-# LINE 1230 "src/ehc/AbstractCore.chs" #-}
type CSubst' e m b ba t = Map.Map CSubstKey (CSubstInfo' e m b ba t)
emptyCSubst :: CSubst' e m b ba t
emptyCSubst = Map.empty
{-# LINE 1241 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromNmTyL :: AssocL HsName t -> CSubst' e m b ba t
acoreCSubstFromNmTyL l = Map.fromList [ (CSKey_Nm k,CSITy v) | (k,v) <- l ]
{-# LINE 1246 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromRefExprL :: AssocL ACoreBindRef e -> CSubst' e m b ba t
acoreCSubstFromRefExprL l = Map.fromList [ (CSKey_Ref k,CSIExpr v) | (k,v) <- l ]
{-# LINE 1251 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromUidExprL :: AssocL UID e -> CSubst' e m b ba t
acoreCSubstFromUidExprL l = Map.fromList [ (CSKey_UID k,CSIExpr v) | (k,v) <- l ]
{-# LINE 1256 "src/ehc/AbstractCore.chs" #-}
acoreCSubstFromUidBindLL :: AssocL UID [b] -> CSubst' e m b ba t
acoreCSubstFromUidBindLL l = Map.fromList [ (CSKey_UID k,CSIBinds v) | (k,v) <- l ]
acoreCSubstFromUidImplsL :: AssocL UID ([Coe' e m b ba t],[Coe' e m b ba t]) -> CSubst' e m b ba t
acoreCSubstFromUidImplsL l = Map.fromList [ (CSKey_UID k,uncurry CSIImpls v) | (k,v) <- l ]
{-# LINE 1268 "src/ehc/AbstractCore.chs" #-}
-- | Combine CSubst: union only, application is postponed
cSubstAppSubst :: CSubst' e m b ba t -> CSubst' e m b ba t -> CSubst' e m b ba t
cSubstAppSubst = Map.union
{-# LINE 1278 "src/ehc/AbstractCore.chs" #-}
infixr `cSubstApp`
class CSubstitutable e m b ba t a
| a -> e m b ba t
where
cSubstApp :: CSubst' e m b ba t -> a -> a
instance CSubstitutable e m b ba t (CSubst' e m b ba t) where
cSubstApp cs s = cs `cSubstAppSubst` s
{-# LINE 1294 "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 1318 "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 1326 "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 1336 "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
{-# LINE 1349 "src/ehc/AbstractCore.chs" #-}
raltIsConMany :: RAlt' e t b pr -> Bool
raltIsConMany (RAlt_Alt (RPat_Con _ _ _ (RPatConBind_Many _) : _) _ _) = True
raltIsConMany _ = False
{-# LINE 1355 "src/ehc/AbstractCore.chs" #-}
raltIsIrrefutable :: RAlt' e t b pr -> Bool
raltIsIrrefutable (RAlt_Alt (RPat_Irrefutable _ _ _ : _) _ _) = True
raltIsIrrefutable _ = False
{-# LINE 1361 "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 1372 "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 1383 "src/ehc/AbstractCore.chs" #-}
acoreRPat2Pat :: (AbstractCore e m b bound boundmeta bcat mbind 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 1397 "src/ehc/AbstractCore.chs" #-}
acoreRPatConBind2PatConBind :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind 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 1414 "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 1426 "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 1436 "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)
instance PP CaseAltFailReason where
pp (CaseAltFailReason_Continue i) = pp i
pp (CaseAltFailReason_Absence ) = pp "absent"
{-# LINE 1450 "src/ehc/AbstractCore.chs" #-}
cafailHasId :: CaseAltFailReason -> (Bool,UID)
cafailHasId (CaseAltFailReason_Absence ) = (False,uidUnused)
cafailHasId (CaseAltFailReason_Continue i) = (True ,i)
{-# LINE 1456 "src/ehc/AbstractCore.chs" #-}
deriving instance Typeable CaseAltFailReason
deriving instance Data CaseAltFailReason
{-# LINE 1465 "src/ehc/AbstractCore.chs" #-}
data AppFunKind
= AppFunKind_NoApp -- inlined Nothing
| AppFunKind_Fun ACoreBindRef
| AppFunKind_Tag CTag
| AppFunKind_FFI
{-# LINE 1477 "src/ehc/AbstractCore.chs" #-}
-- | What kind of Expr?
data WhatExpr
= ExprIsLam Int -- arity
| ExprIsApp Int -- arity
WhatExpr -- function
| ExprIsVar HsName
| ExprIsInt Int
| ExprIsTup CTag
| ExprIsFFI
| ExprIsOtherWHNF
| ExprIsOther
| ExprIsBind
deriving Eq
{-# LINE 1494 "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
whatExprMbLam (ExprIsLam a) = Just a
whatExprMbLam _ = Nothing
-- | app arity
whatExprAppArity :: WhatExpr -> Int
whatExprAppArity (ExprIsApp a _) = a
whatExprAppArity _ = 0
{-# LINE 1516 "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 1526 "src/ehc/AbstractCore.chs" #-}
whatExprIsLam :: WhatExpr -> Bool
whatExprIsLam = isJust . whatExprMbLam
{-# INLINE whatExprIsLam #-}
-- | Is Expr a Tup?
whatExprIsTup :: WhatExpr -> Bool
whatExprIsTup (ExprIsTup _) = True
whatExprIsTup _ = False
{-# LINE 1538 "src/ehc/AbstractCore.chs" #-}
-- | Is Expr a FFI?
whatExprIsFFI :: WhatExpr -> Bool
whatExprIsFFI (ExprIsFFI ) = True
whatExprIsFFI _ = False
{-# LINE 1556 "src/ehc/AbstractCore.chs" #-}
instance Serialize ACoreBindAspectKey where
sput (ACoreBindAspectKey_Default ) = sputWord8 0
sput (ACoreBindAspectKey_Strict ) = sputWord8 1
sput (ACoreBindAspectKey_Ty ) = sputWord8 2
sput (ACoreBindAspectKey_RelevTy ) = sputWord8 3
sput (ACoreBindAspectKey_Debug ) = sputWord8 4
sput (ACoreBindAspectKey_Core ) = sputWord8 5
sput (ACoreBindAspectKey_FusionRole ) = sputWord8 7
sget = do
t <- sgetWord8
case t of
0 -> return ACoreBindAspectKey_Default
1 -> return ACoreBindAspectKey_Strict
2 -> return ACoreBindAspectKey_Ty
3 -> return ACoreBindAspectKey_RelevTy
4 -> return ACoreBindAspectKey_Debug
5 -> return ACoreBindAspectKey_Core
7 -> return ACoreBindAspectKey_FusionRole
{-# LINE 1587 "src/ehc/AbstractCore.chs" #-}
instance Serialize ACoreBindRef where
sput (ACoreBindRef a b) = sput a >> sput b
sget = liftM2 ACoreBindRef sget sget
{-# LINE 1593 "src/ehc/AbstractCore.chs" #-}
instance Serialize CaseAltFailReason where
sput (CaseAltFailReason_Continue a) = sputWord8 0 >> sput a
sput (CaseAltFailReason_Absence ) = sputWord8 1
sget = do
t <- sgetWord8
case t of
0 -> liftM CaseAltFailReason_Continue sget
1 -> return CaseAltFailReason_Absence
{-# LINE 1608 "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 1615 "src/ehc/AbstractCore.chs" #-}
instance (PP expr, PP ty) => PP (CSubstInfo' expr metaval 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