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, whatExprMbLam', whatExprAppArity, whatExprMbBind , whatExprIsWHNF , whatExprIsLam, whatExprIsTup, whatExprIsBind , 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 -- | 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 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 321 "src/ehc/AbstractCore.chs" #-} type ACoreAppLikeMetaBound = (ACoreBindAspectKeyS,MetaLev,CLbl) {-# LINE 325 "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 356 "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 368 "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 373 "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 383 "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 424 "src/ehc/AbstractCore.chs" #-} acbaspkeyMetaLev :: MetaLev -> ACoreBindAspectKeyS -> MetaLev acbaspkeyMetaLev mlev _ = mlev {-# LINE 435 "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 494 "src/ehc/AbstractCore.chs" #-} -- | predefined: acbaspkeyFusionRole :: ACoreBindAspectKeyS acbaspkeyFusionRole = acbaspkeyMk [ ACoreBindAspectKey_FusionRole ] {-# LINE 501 "src/ehc/AbstractCore.chs" #-} ppACBaspKeyS :: ACoreBindAspectKeyS -> PP_Doc ppACBaspKeyS = ppCurlysCommas . Set.toList {-# LINE 506 "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 515 "src/ehc/AbstractCore.chs" #-} deriving instance Typeable ACoreBindAspectKey deriving instance Data ACoreBindAspectKey {-# LINE 524 "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 546 "src/ehc/AbstractCore.chs" #-} acbrefAspKey :: ACoreBindRef -> ACoreBindAspectKeyS acbrefAspKey = maybe acbaspkeyNone id . acbrefMbAspKey {-# INLINE acbrefAspKey #-} {-# LINE 552 "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 558 "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 566 "src/ehc/AbstractCore.chs" #-} deriving instance Typeable ACoreBindRef deriving instance Data ACoreBindRef {-# LINE 575 "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 #-} -- | Applies the first expression to all given arguments. acoreApp :: (AbstractCore e m b bound boundmeta bcat mbind 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 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 595 "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 617 "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 -- | Creates a new tuple/record with the given values. -- Has to be fully applied, partial application is not allowed. 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 650 "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 688 "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 715 "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 737 "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 759 "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 770 "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 790 "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 800 "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 #-} -- | Creates a let binding, where the bindings may be mutually recursive. acoreLetRec :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [b] -- ^ The bindings. -> e -- ^ The body. -> e acoreLetRec bs e = acoreLet (acoreBindcategRec) bs e {-# INLINE acoreLetRec #-} {-# LINE 833 "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 838 "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 -- | Creates a (non-recursive) let binding. acoreLet1Plain :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind 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 854 "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 -- | Creates a let binding, which is strict in the bound expression. acoreLet1Strict :: (Eq bcat, AbstractCore e m b bound boundmeta bcat mbind 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 870 "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 902 "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 914 "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 925 "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 -- | Creates an `Int` constant. 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 941 "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 946 "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 956 "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 961 "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 966 "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 m b bound boundmeta bcat mbind 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 976 "src/ehc/AbstractCore.chs" #-} -- | Generates an error expression, failing with the given string when evaluated. ('error' in haskell) acoreBuiltinError :: (AbstractCore e m b bound boundmeta bcat mbind 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 m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> e acoreBuiltinUndefined opts = acoreBuiltinApp opts ehbnUndefined [] {-# LINE 989 "src/ehc/AbstractCore.chs" #-} -- | Creates a Core 'Integer' constant. acoreBuiltinInteger :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => EHCOpts -> Integer -- ^ The integer. -> e acoreBuiltinInteger opts i = acoreBuiltinApp opts ehbnPackedStringToInteger [acoreStringTy (acoreTyString opts) (show i)] {-# LINE 998 "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 1009 "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 1026 "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 1037 "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 1048 "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 1059 "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 1072 "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 1102 "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 1139 "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 1157 "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 1169 "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 1184 "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 1202 "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 1213 "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 1222 "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 1230 "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 1248 "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 1258 "src/ehc/AbstractCore.chs" #-} data CSubstKey = CSKey_UID UID | CSKey_Nm HsName | CSKey_Ref ACoreBindRef deriving (Show,Eq,Ord) {-# LINE 1266 "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 1284 "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 1295 "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 1300 "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 1305 "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 1310 "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 1322 "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 1332 "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 1348 "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 1372 "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 1380 "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 1390 "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 1403 "src/ehc/AbstractCore.chs" #-} raltIsConMany :: RAlt' e t b pr -> Bool raltIsConMany (RAlt_Alt (RPat_Con _ _ _ (RPatConBind_Many _) : _) _ _) = True raltIsConMany _ = False {-# LINE 1409 "src/ehc/AbstractCore.chs" #-} raltIsIrrefutable :: RAlt' e t b pr -> Bool raltIsIrrefutable (RAlt_Alt (RPat_Irrefutable _ _ _ : _) _ _) = True raltIsIrrefutable _ = False {-# LINE 1415 "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 1426 "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 1437 "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 1451 "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 1468 "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 1480 "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 1490 "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 1504 "src/ehc/AbstractCore.chs" #-} cafailHasId :: CaseAltFailReason -> (Bool,UID) cafailHasId (CaseAltFailReason_Absence ) = (False,uidUnused) cafailHasId (CaseAltFailReason_Continue i) = (True ,i) {-# LINE 1510 "src/ehc/AbstractCore.chs" #-} deriving instance Typeable CaseAltFailReason deriving instance Data CaseAltFailReason {-# LINE 1519 "src/ehc/AbstractCore.chs" #-} data AppFunKind = AppFunKind_NoApp -- inlined Nothing | AppFunKind_Fun ACoreBindRef | AppFunKind_Tag CTag | AppFunKind_FFI {-# LINE 1531 "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 1549 "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 1581 "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 1591 "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 1607 "src/ehc/AbstractCore.chs" #-} -- | Is Expr a FFI? whatExprIsFFI :: WhatExpr -> Bool whatExprIsFFI (ExprIsFFI ) = True whatExprIsFFI _ = False {-# LINE 1625 "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 1656 "src/ehc/AbstractCore.chs" #-} instance Serialize ACoreBindRef where sput (ACoreBindRef a b) = sput a >> sput b sget = liftM2 ACoreBindRef sget sget {-# LINE 1662 "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 1677 "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 1684 "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