module Language.HERMIT.Primitive.Inline where
import GhcPlugins
import Control.Arrow
import Language.HERMIT.GHC
import Language.HERMIT.Primitive.Common
import Language.HERMIT.Primitive.GHC
import Language.HERMIT.Primitive.Unfold
import Language.HERMIT.Kure
import Language.HERMIT.Context
import Language.HERMIT.External
import qualified Language.Haskell.TH as TH
externals :: [External]
externals =
[ external "inline" (promoteExprR inline :: RewriteH Core)
[ "(Var n) ==> <defn of n>, fails otherwise" ].+ Eval .+ Deep .+ TODO
, external "inline-scrutinee" (promoteExprR inlineScrutinee :: RewriteH Core)
[ "(Var n) ==> <defn of n>, fails otherwise"
, "In the case of case binders, replaces with scrutinee expression, "
, "rather than constructor or literal." ].+ Eval .+ Deep .+ TODO
, external "inline" (promoteExprR . inlineName :: TH.Name -> RewriteH Core)
[ "Restrict inlining to a given name" ].+ Eval .+ Deep .+ TODO
, external "inline-case-binder" (promoteExprR inlineCaseBinder :: RewriteH Core)
[ "Inline if this variable is a case binder." ].+ Eval .+ Deep .+ Bash .+ TODO
]
inlineName :: TH.Name -> RewriteH CoreExpr
inlineName nm = (varT (cmpTHName2Id nm) >>= guardM) >> inline
inline :: RewriteH CoreExpr
inline = configurableInline False False
inlineScrutinee :: RewriteH CoreExpr
inlineScrutinee = configurableInline True False
inlineCaseBinder :: RewriteH CoreExpr
inlineCaseBinder = configurableInline False True
configurableInline :: Bool
-> Bool
-> RewriteH CoreExpr
configurableInline scrutinee caseBinderOnly =
prefixFailMsg "Inline failed: " $
withPatFailMsg (wrongExprForm "Var v") $
do (c, Var v) <- exposeT
(e,d) <- getUnfolding scrutinee caseBinderOnly v c
return e >>> accepterR (extractT $ ensureDepth d) "values in inlined expression have been rebound."
ensureDepth :: Int -> TranslateH Core Bool
ensureDepth d = do
frees <- promoteT freeVarsT
ds <- collectT $ do c <- contextT
promoteExprT $ varT $ \ i -> if i `elem` frees
then maybe (i,0) (\b -> (i,hermitBindingDepth b)) (lookupHermitBinding i c)
else (i,0)
return $ all (toSnd (<= d)) ds
inlineTargets :: TranslateH Core [String]
inlineTargets = collectT $ promoteT $ ifM (testM inline)
(varT unqualifiedIdName)
(fail "cannot be inlined.")