module Language.HERMIT.Core
(
CoreProg(..)
, CoreDef(..)
, CoreTickish
, defsToRecBind
, defToIdExpr
, progToBinds
, bindsToProg
, bindToIdExprs
, isCoArg
, exprTypeOrKind
, endoFunType
, funArgResTypes
, funsWithInverseTypes
, appCount
, Crumb(..)
, showCrumbs
, deprecatedLeftSibling
, deprecatedRightSibling
) where
import GhcPlugins
import Language.KURE.Combinators.Monad
import Language.KURE.MonadCatch
import Data.List (intercalate)
data CoreProg = ProgNil
| ProgCons CoreBind CoreProg
infixr 5 `ProgCons`
progToBinds :: CoreProg -> [CoreBind]
progToBinds ProgNil = []
progToBinds (ProgCons bd p) = bd : progToBinds p
bindsToProg :: [CoreBind] -> CoreProg
bindsToProg = foldr ProgCons ProgNil
bindToIdExprs :: CoreBind -> [(Id,CoreExpr)]
bindToIdExprs (NonRec v e) = [(v,e)]
bindToIdExprs (Rec bds) = bds
data CoreDef = Def Id CoreExpr
defToIdExpr :: CoreDef -> (Id,CoreExpr)
defToIdExpr (Def v e) = (v,e)
defsToRecBind :: [CoreDef] -> CoreBind
defsToRecBind = Rec . map defToIdExpr
type CoreTickish = Tickish Id
exprTypeOrKind :: CoreExpr -> Type
exprTypeOrKind (Type t) = typeKind t
exprTypeOrKind e = exprType e
isCoArg :: CoreExpr -> Bool
isCoArg (Coercion {}) = True
isCoArg _ = False
appCount :: CoreExpr -> Int
appCount (App e1 _) = appCount e1 + 1
appCount _ = 0
endoFunType :: Monad m => CoreExpr -> m Type
endoFunType f = do (ty1,ty2) <- funArgResTypes f
guardMsg (eqType ty1 ty2) ("argument and result types differ.")
return ty1
funArgResTypes :: Monad m => CoreExpr -> m (Type,Type)
funArgResTypes e = maybe (fail "not a function type.") return (splitFunTy_maybe $ exprType e)
funsWithInverseTypes :: MonadCatch m => CoreExpr -> CoreExpr -> m (Type,Type)
funsWithInverseTypes f g = do (fdom,fcod) <- funArgResTypes f
(gdom,gcod) <- funArgResTypes g
setFailMsg "functions do not have inverse types." $
do guardM (eqType fdom gcod)
guardM (eqType gdom fcod)
return (fdom,fcod)
data Crumb =
ModGuts_Prog
| ProgCons_Head | ProgCons_Tail
| NonRec_RHS | NonRec_Var
| Rec_Def Int
| Def_Id | Def_RHS
| Var_Id
| Lit_Lit
| App_Fun | App_Arg
| Lam_Var | Lam_Body
| Let_Bind | Let_Body
| Case_Scrutinee | Case_Binder | Case_Type | Case_Alt Int
| Cast_Expr | Cast_Co
| Tick_Tick | Tick_Expr
| Type_Type
| Co_Co
| Alt_Con | Alt_Var Int | Alt_RHS
| TyVarTy_TyVar
| LitTy_TyLit
| AppTy_Fun | AppTy_Arg
| TyConApp_TyCon | TyConApp_Arg Int
| FunTy_Dom | FunTy_CoDom
| ForAllTy_Var | ForAllTy_Body
| Refl_Type
| TyConAppCo_TyCon | TyConAppCo_Arg Int
| AppCo_Fun | AppCo_Arg
| ForAllCo_TyVar | ForAllCo_Body
| CoVarCo_CoVar
| AxiomInstCo_Axiom | AxiomInstCo_Index | AxiomInstCo_Arg Int
| UnsafeCo_Left | UnsafeCo_Right
| SymCo_Co
| TransCo_Left | TransCo_Right
| NthCo_Int | NthCo_Co
| InstCo_Co | InstCo_Type
| LRCo_LR | LRCo_Co
deriving (Eq,Read,Show)
showCrumbs :: [Crumb] -> String
showCrumbs crs = "[" ++ intercalate ", " (map showCrumb crs) ++ "]"
showCrumb :: Crumb -> String
showCrumb = \case
ModGuts_Prog -> "prog"
ProgCons_Head -> "prog-head"
ProgCons_Tail -> "prog-tail"
NonRec_RHS -> "nonrec-rhs"
Rec_Def n -> "rec-def " ++ show n
Def_RHS -> "def-rhs"
App_Fun -> "app-fun"
App_Arg -> "app-arg"
Lam_Body -> "lam-body"
Let_Bind -> "let-bind"
Let_Body -> "let-body"
Case_Scrutinee -> "case-expr"
Case_Type -> "case-type"
Case_Alt n -> "case-alt " ++ show n
Cast_Expr -> "cast-expr"
Cast_Co -> "cast-co"
Tick_Expr -> "tick-expr"
Alt_RHS -> "alt-rhs"
Type_Type -> "type"
Co_Co -> "coercion"
AppTy_Fun -> "appTy-fun"
AppTy_Arg -> "appTy-arg"
TyConApp_Arg n -> "tyCon-arg " ++ show n
FunTy_Dom -> "fun-dom"
FunTy_CoDom -> "fun-cod"
ForAllTy_Body -> "forall-body"
Refl_Type -> "refl-type"
TyConAppCo_Arg n -> "coCon-arg " ++ show n
AppCo_Fun -> "appCo-fun"
AppCo_Arg -> "appCo-arg"
ForAllCo_Body -> "coForall-body"
AxiomInstCo_Arg n -> "axiom-inst " ++ show n
UnsafeCo_Left -> "unsafe-left"
UnsafeCo_Right -> "unsafe-right"
SymCo_Co -> "sym-co"
TransCo_Left -> "trans-left"
TransCo_Right -> "trans-right"
NthCo_Co -> "nth-co"
InstCo_Co -> "inst-co"
InstCo_Type -> "inst-type"
LRCo_Co -> "lr-co"
_ -> "Warning: Crumb should not be in use! This is probably Neil's fault."
deprecatedLeftSibling :: Crumb -> Maybe Crumb
deprecatedLeftSibling = \case
ProgCons_Tail -> Just ProgCons_Head
Rec_Def n | n > 0 -> Just (Rec_Def (n1))
App_Arg -> Just App_Fun
Let_Body -> Just Let_Bind
Case_Alt n | n == 0 -> Just Case_Scrutinee
| n > 0 -> Just (Case_Alt (n1))
_ -> Nothing
deprecatedRightSibling :: Crumb -> Maybe Crumb
deprecatedRightSibling = \case
ProgCons_Head -> Just ProgCons_Tail
Rec_Def n -> Just (Rec_Def (n+1))
App_Fun -> Just App_Arg
Let_Bind -> Just Let_Body
Case_Scrutinee -> Just (Case_Alt 0)
Case_Alt n -> Just (Case_Alt (n+1))
_ -> Nothing