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)
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
acoreLam1Bind :: bind -> expr -> expr
acore1AppBound :: expr -> bound -> expr
acoreTagTyTupBound :: CTag -> ty -> [bound] -> expr
acoreBind1CatLevMetasTy :: bindcateg -> HsName -> MetaLev -> (metabind,metaval) -> ty -> expr -> bind
acoreBoundVal1CatLevMetasTy :: bindcateg -> HsName -> MetaLev -> (metabind,metaval) -> ty -> expr -> bound
acoreBoundValTy1CatLev :: bindcateg -> HsName -> MetaLev -> ty -> bound
acoreBoundmeta :: ACoreBindAspectKeyS -> MetaLev -> CLbl -> boundmeta
acoreBound1MetaVal :: boundmeta -> expr -> bound
acoreBind1Asp :: HsName -> [bound] -> bind
acoreLetBase :: bindcateg -> [bind] -> expr -> expr
acoreCast :: ty -> expr -> expr
acoreCast _ e = e
acoreCaseDflt :: expr
-> [alt]
-> Maybe expr
-> expr
acoreVar :: HsName -> expr
acoreStringTy :: ty -> String -> expr
acoreCharTy :: ty -> Char -> expr
acoreIntTy :: ty -> Int -> expr
acoreIntTy2 :: ty -> Integer -> expr
acoreUidHole :: UID -> expr
acoreHoleLet :: UID -> expr -> expr
acoreExprErr :: String -> expr
acoreExprErr s = panic $ "AbstractCore.acoreExprErr: " ++ s
acoreTyBool :: EHCOpts -> ty
acorePatVarTy :: HsName -> ty -> pat
acorePatCon :: CTag
-> patrest
-> [patfld]
-> pat
acorePatIntTy :: ty -> Int -> pat
acorePatIntTy2 :: ty -> Integer -> pat
acorePatCharTy :: ty -> Char -> pat
acorePatBoolExpr :: expr -> pat
acorePatFldBind :: (HsName,expr)
-> bind
-> patfld
acorePatRestEmpty :: patrest
acorePatRestVar :: HsName -> patrest
acoreAlt :: pat
-> expr
-> alt
acoreTy2ty :: EHCOpts -> Ty -> ty
acoreMetavalDflt :: metaval
acoreMetavalDfltDict :: metaval
acoreMetabindDflt :: metabind
acoreDfltBoundmeta :: boundmeta
acoreDfltBoundmeta = panic "AbstractCore.acoreDfltBoundmeta not implemented"
acoreTyErr :: String -> ty
acoreTyErr s = panic $ "AbstractCore.acoreTyErr: " ++ s
acoreTyNone :: ty
acoreTyChar :: EHCOpts -> ty
acoreTyInt :: EHCOpts -> ty
acoreTyString :: EHCOpts -> ty
acoreBindcategRec :: bindcateg
acoreBindcategStrict :: bindcateg
acoreBindcategPlain :: bindcateg
acoreExprMbApp :: expr -> Maybe (expr,bound)
acoreExprMbLam :: expr -> Maybe (bind,expr)
acoreExprMbLet :: expr -> Maybe (bindcateg,[bind],expr)
acoreExprMbVar :: expr -> Maybe HsName
acoreExprMbInt :: expr -> Maybe (ty,Integer)
acoreBindcategMbRec :: bindcateg -> Maybe bindcateg
acoreBindcategMbStrict :: bindcateg -> Maybe bindcateg
acorePatMbCon :: pat -> Maybe(CTag,patrest,[patfld])
acorePatMbInt :: pat -> Maybe(ty,Integer)
acorePatMbChar :: pat -> Maybe(ty,Char)
acoreUnAlt :: alt -> (pat,expr)
acoreUnPatFld :: patfld -> ((HsName,expr),bind)
acoreUnBind :: bind -> (HsName,[bound])
acoreBoundMbVal :: bound -> Maybe (boundmeta,expr)
acoreExprThunk :: expr -> expr
acoreExprThunk = id
acoreTyThunk :: ty -> ty
acoreTyThunk = id
acoreExprUnThunk :: expr -> expr
acoreExprUnThunk = id
acoreTyUnThunk :: ty -> ty
acoreTyUnThunk = id
acoreCoeArg :: expr
acoreExprIsCoeArg :: expr -> Bool
type ACoreAppLikeMetaBound = (ACoreBindAspectKeyS,MetaLev,CLbl)
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
appDfltBoundmeta x = acoreDfltBoundmeta
appDbg = acoreExprErr
appMbCon = acoreExprMbVar
appMbApp1 e = do (f,b) <- acoreExprMbApp e
(_,a) <- acoreBoundMbVal b
return (f,a)
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
recUnRowExts e= (e,[])
acoreMetaLift :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a, Functor f) => f x -> f (x,m)
acoreMetaLift = fmap2Tuple acoreMetavalDflt
acoreMetaLiftDict :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a, Functor f) => f x -> f (x,m)
acoreMetaLiftDict = fmap2Tuple acoreMetavalDfltDict
data ACoreBindAspectKey
= ACoreBindAspectKey_Default
| ACoreBindAspectKey_Ty
| ACoreBindAspectKey_RelevTy
| ACoreBindAspectKey_Strict
| ACoreBindAspectKey_Debug
| ACoreBindAspectKey_Core
| ACoreBindAspectKey_FusionRole
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
acbaspkeyMetaLev :: MetaLev -> ACoreBindAspectKeyS -> MetaLev
acbaspkeyMetaLev mlev _ = mlev
acbaspkeyNone :: ACoreBindAspectKeyS
acbaspkeyNone = acbaspkeyMk
[ ]
acbaspkeyDefault :: ACoreBindAspectKeyS
acbaspkeyDefault = acbaspkeyMk
[ ACoreBindAspectKey_Default ]
acbaspkeyTy :: ACoreBindAspectKeyS
acbaspkeyTy = acbaspkeyMk
[ ACoreBindAspectKey_Ty ]
acbaspkeyDefaultTy :: ACoreBindAspectKeyS
acbaspkeyDefaultTy = acbaspkeyMk
[ ACoreBindAspectKey_Default, ACoreBindAspectKey_Ty ]
acbaspkeyDefaultCore :: ACoreBindAspectKeyS
acbaspkeyDefaultCore = acbaspkeyMk
[ ACoreBindAspectKey_Default, ACoreBindAspectKey_Core ]
acbaspkeyDefaultRelevTy :: ACoreBindAspectKeyS
acbaspkeyDefaultRelevTy = acbaspkeyMk
[ ACoreBindAspectKey_Default, ACoreBindAspectKey_RelevTy ]
acbaspkeyStrict :: ACoreBindAspectKeyS
acbaspkeyStrict = acbaspkeyMk
[ ACoreBindAspectKey_Strict ]
acbaspkeyDebug :: ACoreBindAspectKeyS
acbaspkeyDebug = acbaspkeyMk
[ ACoreBindAspectKey_Debug ]
acbaspkeyFusionRole :: ACoreBindAspectKeyS
acbaspkeyFusionRole = acbaspkeyMk
[ ACoreBindAspectKey_FusionRole ]
ppACBaspKeyS :: ACoreBindAspectKeyS -> PP_Doc
ppACBaspKeyS = ppCurlysCommas . Set.toList
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)
deriving instance Typeable ACoreBindAspectKey
deriving instance Data ACoreBindAspectKey
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
acbrefAspKey :: ACoreBindRef -> ACoreBindAspectKeyS
acbrefAspKey = maybe acbaspkeyNone id . acbrefMbAspKey
acbrefAspAnd :: ACoreBindAspectKeyS -> ACoreBindRef -> ACoreBindRef
acbrefAspAnd a r = r {acbrefMbAspKey = Just $ a `Set.union` acbrefAspKey r }
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
deriving instance Typeable ACoreBindRef
deriving instance Data ACoreBindRef
acore1App :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> e -> e
acore1App f a = acore1AppBound f (acoreBound1Val a)
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
acoreLamBind :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [b] -> e -> e
acoreLamBind = flip (foldr acoreLam1Bind)
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
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
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
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
acoreTup :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => [e] -> e
acoreTup es = acoreTagTup CTagRec es
acoreTag :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => CTag -> e
acoreTag tg = acoreTagTup tg []
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)
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
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
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
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
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
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
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 e
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
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
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
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
acoreBind1Asp1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> bound -> b
acoreBind1Asp1 n ba = acoreBind1Asp n [ba]
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]
acoreBind1NmTy1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> t -> b
acoreBind1NmTy1 n t = acoreBind1NmLevTy1 n metaLevTy t
acoreBind1Nm1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => HsName -> b
acoreBind1Nm1 n = acoreBind1Asp n []
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
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
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
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
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
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
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
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
acoreBound1Val :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> bound
acoreBound1Val e = acoreBound1AspkeyVal acbaspkeyDefault e
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))
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
_ -> 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
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
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
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
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
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
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
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
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
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
acoreBindcategDflt :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> bcat
acoreBindcategDflt _ = acoreBindcategPlain
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
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
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]
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]
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]
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
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 []
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)]
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") []]
acorePatConMbTag :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => p -> Maybe CTag
acorePatConMbTag = fmap (\(tg,_,_) -> tg) . acorePatMbCon
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
) . fst . acoreUnAlt
acoreBindNm :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => b -> HsName
acoreBindNm = fst . acoreUnBind
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)
acoreUnBoundVal :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => bound -> e
acoreUnBoundVal = maybe (panic "acoreBoundMbVal") (\(_,a) -> a) . acoreBoundMbVal
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
)
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
data Coe' expr metaval bind bindasp ty
= Coe_Map !(expr -> expr)
| Coe_C !expr
| Coe_Compose !(Coe' expr metaval bind bindasp ty)
!(Coe' expr metaval bind bindasp ty)
| Coe_App1 !expr
| Coe_App [HsName]
| Coe_Lam !HsName !ty
| Coe_CloseExists !TyVarId !ty !ty
| Coe_OpenExists !TyVarId !ty !ty
| Coe_LamLet !HsName !ty !UID
| Coe_LetRec ![bind]
| Coe_ImplApp !ImplsVarId
| Coe_ImplLam !ImplsVarId
instance Show (Coe' expr metaval bind bindasp ty) where
show _ = "COE"
data CoeCtx
= CoeCtx_Allow
| CoeCtx_DontAllow
deriving (Eq,Show)
acoreCoeMap :: (e -> e) -> Coe' e m b ba t
acoreCoeMap = Coe_Map
acoreCoeId :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => Coe' e m b ba t
acoreCoeId = Coe_C acoreCoeArg
acoreCoeLamLetTy :: HsName -> t -> UID -> Coe' e m b ba t
acoreCoeLamLetTy = Coe_LamLet
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
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
acoreCoeApp1 :: (AbstractCore e m b bound boundmeta bcat mbind t p pr pf a) => e -> Coe' e m b ba t
acoreCoeApp1 = Coe_App1
acoreCoeAppNbyName :: [(HsName)] -> Coe' e m b ba t
acoreCoeAppNbyName = Coe_App
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)
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
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")
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
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
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))
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
data CSubstKey
= CSKey_UID UID
| CSKey_Nm HsName
| CSKey_Ref ACoreBindRef
deriving (Show,Eq,Ord)
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'"
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
acoreCSubstFromNmTyL :: AssocL HsName t -> CSubst' e m b ba t
acoreCSubstFromNmTyL l = Map.fromList [ (CSKey_Nm k,CSITy v) | (k,v) <- l ]
acoreCSubstFromRefExprL :: AssocL ACoreBindRef e -> CSubst' e m b ba t
acoreCSubstFromRefExprL l = Map.fromList [ (CSKey_Ref k,CSIExpr v) | (k,v) <- l ]
acoreCSubstFromUidExprL :: AssocL UID e -> CSubst' e m b ba t
acoreCSubstFromUidExprL l = Map.fromList [ (CSKey_UID k,CSIExpr v) | (k,v) <- l ]
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 ]
cSubstAppSubst :: CSubst' e m b ba t -> CSubst' e m b ba t -> CSubst' e m b ba t
cSubstAppSubst = Map.union
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
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]
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)
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
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
raltIsConMany :: RAlt' e t b pr -> Bool
raltIsConMany (RAlt_Alt (RPat_Con _ _ _ (RPatConBind_Many _) : _) _ _) = True
raltIsConMany _ = False
raltIsIrrefutable :: RAlt' e t b pr -> Bool
raltIsIrrefutable (RAlt_Alt (RPat_Irrefutable _ _ _ : _) _ _) = True
raltIsIrrefutable _ = False
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
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
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
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)
ctagTrue, ctagFalse :: EHCOpts -> CTag
ctagTrue opts = CTag (ehcOptBuiltin opts ehbnDataBool) (ehcOptBuiltin opts ehbnBoolTrue) tagBoolTrue 0 0
ctagFalse opts = CTag (ehcOptBuiltin opts ehbnDataBool) (ehcOptBuiltin opts ehbnBoolFalse) tagBoolFalse 0 0
ctagCons, ctagNil :: EHCOpts -> CTag
ctagCons opts = CTag (ehcOptBuiltin opts ehbnDataList) (ehcOptBuiltin opts ehbnDataListAltCons) tagListCons 2 2
ctagNil opts = CTag (ehcOptBuiltin opts ehbnDataList) (ehcOptBuiltin opts ehbnDataListAltNil ) tagListNil 0 2
data CaseAltFailReason
= CaseAltFailReason_Absence
| CaseAltFailReason_Continue
{ cafailCaseId :: UID
}
deriving (Show,Eq,Ord)
instance PP CaseAltFailReason where
pp (CaseAltFailReason_Continue i) = pp i
pp (CaseAltFailReason_Absence ) = pp "absent"
cafailHasId :: CaseAltFailReason -> (Bool,UID)
cafailHasId (CaseAltFailReason_Absence ) = (False,uidUnused)
cafailHasId (CaseAltFailReason_Continue i) = (True ,i)
deriving instance Typeable CaseAltFailReason
deriving instance Data CaseAltFailReason
data AppFunKind
= AppFunKind_NoApp
| AppFunKind_Fun ACoreBindRef
| AppFunKind_Tag CTag
| AppFunKind_FFI
data WhatExpr
= ExprIsLam Int
| ExprIsApp Int
WhatExpr
| ExprIsVar HsName
| ExprIsInt Int
| ExprIsTup CTag
| ExprIsFFI
| ExprIsOtherWHNF
| ExprIsOther
| ExprIsBind
deriving Eq
whatExprMbVar :: WhatExpr -> Maybe HsName
whatExprMbVar (ExprIsVar a) = Just a
whatExprMbVar _ = Nothing
whatExprMbApp :: WhatExpr -> Maybe (Int,WhatExpr)
whatExprMbApp (ExprIsApp a w) = Just (a,w)
whatExprMbApp _ = Nothing
whatExprMbLam :: WhatExpr -> Maybe Int
whatExprMbLam (ExprIsLam a) = Just a
whatExprMbLam _ = Nothing
whatExprAppArity :: WhatExpr -> Int
whatExprAppArity (ExprIsApp a _) = a
whatExprAppArity _ = 0
whatExprIsWHNF :: WhatExpr -> Bool
whatExprIsWHNF (ExprIsLam _) = True
whatExprIsWHNF (ExprIsVar _) = True
whatExprIsWHNF (ExprIsInt _) = True
whatExprIsWHNF (ExprIsTup _) = True
whatExprIsWHNF ExprIsOtherWHNF = True
whatExprIsWHNF _ = False
whatExprIsLam :: WhatExpr -> Bool
whatExprIsLam = isJust . whatExprMbLam
whatExprIsTup :: WhatExpr -> Bool
whatExprIsTup (ExprIsTup _) = True
whatExprIsTup _ = False
whatExprIsFFI :: WhatExpr -> Bool
whatExprIsFFI (ExprIsFFI ) = True
whatExprIsFFI _ = False
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
instance Serialize ACoreBindRef where
sput (ACoreBindRef a b) = sput a >> sput b
sget = liftM2 ACoreBindRef sget sget
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
instance PP CSubstKey where
pp (CSKey_UID i) = pp i
pp (CSKey_Nm n) = pp n
pp (CSKey_Ref r) = pp r
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 (CSIBinds b ) = pp "CSIBinds"