module HERMIT.Dictionary.Composite
( externals
, unfoldBasicCombinatorR
, simplifyR
, bashUsingR
, bashR
, bashExtendedWithR
, bashDebugR
)
where
import Control.Arrow
import HERMIT.Context
import HERMIT.Core
import HERMIT.GHC
import HERMIT.Monad
import HERMIT.Kure
import HERMIT.External
import HERMIT.Dictionary.Debug hiding (externals)
import HERMIT.Dictionary.GHC hiding (externals)
import HERMIT.Dictionary.Inline hiding (externals)
import HERMIT.Dictionary.Local hiding (externals)
import HERMIT.Dictionary.Unfold hiding (externals)
import qualified Language.Haskell.TH as TH
externals :: [External]
externals =
[ external "unfold-basic-combinator" (promoteExprR unfoldBasicCombinatorR :: RewriteH Core)
[ "Unfold the current expression if it is one of the basic combinators: ($), (.), id, flip, const, fst or snd." ]
, external "simplify" (simplifyR :: RewriteH Core)
[ "innermost (unfold-basic-combinator <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ let-elim)" ]
, external "bash" (bashR :: RewriteH Core)
bashHelp .+ Eval .+ Deep .+ Loop
, external "bash-extended-with" (bashExtendedWithR :: [RewriteH Core] -> RewriteH Core)
[ "Run \"bash\" extended with an additional rewrite.",
"Note: be sure that the new rewrite either fails or makes progress, else this may loop."
] .+ Eval .+ Deep .+ Loop
, external "bash-debug" (bashDebugR :: RewriteH Core)
[ "verbose bash - most useful with set-auto-corelint True" ] .+ Eval .+ Deep .+ Loop
]
basicCombinators :: [String]
basicCombinators = ["$",".","id","flip","const","fst","snd","curry","uncurry"]
unfoldBasicCombinatorR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr
unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $
unfoldNamesR (map TH.mkName basicCombinators)
simplifyR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core
simplifyR = setFailMsg "Simplify failed: nothing to simplify." $
innermostR ( promoteBindR recToNonrecR
<+ promoteExprR ( unfoldBasicCombinatorR
<+ betaReducePlusR
<+ letNonRecSubstSafeR
<+ caseReduceR
<+ letElimR )
)
bashR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core
bashR = bashUsingR (map fst bashComponents)
bashExtendedWithR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core
bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents)
bashDebugR :: RewriteH Core
bashDebugR = bashUsingR $ map (\ (r,nm) -> r >>> observeR nm) bashComponents
bashUsingR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core
bashUsingR rs =
setFailMsg "bash failed: nothing to do." $
repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR
bashHelp :: [String]
bashHelp = "Iteratively apply the following rewrites until nothing changes:" : map snd (bashComponents
:: [(RewriteH Core,String)]
)
bashComponents :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)]
bashComponents =
[
(promoteExprR betaReduceR, "beta-reduce")
, (promoteExprR caseReduceR, "case-reduce")
, (promoteExprR caseReduceIdR, "case-reduce-id")
, (promoteExprR caseElimSeqR, "case-elim-seq")
, (promoteExprR unfoldBasicCombinatorR, "unfold-basic-combinator")
, (promoteExprR inlineCaseAlternativeR, "inline-case-alternative")
, (promoteExprR etaReduceR, "eta-reduce")
, (promoteExprR letNonRecSubstSafeR, "let-nonrec-subst-safe")
, (promoteExprR caseFloatAppR, "case-float-app")
, (promoteExprR caseFloatCaseR, "case-float-case")
, (promoteExprR caseFloatLetR, "case-float-let")
, (promoteExprR caseFloatCastR, "case-float-cast")
, (promoteExprR letFloatAppR, "let-float-app")
, (promoteExprR letFloatArgR, "let-float-arg")
, (promoteExprR letFloatLamR, "let-float-lam")
, (promoteExprR letFloatLetR, "let-float-let")
, (promoteExprR letFloatCaseR, "let-float-case")
, (promoteExprR letFloatCastR, "let-float-cast")
, (promoteProgR letFloatTopR, "let-float-top")
, (promoteExprR castElimReflR, "cast-elim-refl")
, (promoteExprR castElimSymR, "cast-elim-sym")
]