module Language.HERMIT.Primitive.Local.Let
(
externals
, letIntro
, letFloatApp
, letFloatArg
, letFloatLet
, letFloatExpr
, letFloatLetTop
, letToCase
)
where
import GhcPlugins
import Data.List
import Data.Monoid
import Language.HERMIT.Kure
import Language.HERMIT.Monad
import Language.HERMIT.External
import Language.HERMIT.Primitive.Common
import Language.HERMIT.Primitive.GHC hiding (externals)
import Language.HERMIT.Primitive.AlphaConversion hiding (externals)
import qualified Language.Haskell.TH as TH
externals :: [External]
externals =
[ external "let-intro" (promoteExprR . letIntro :: TH.Name -> RewriteH Core)
[ "e => (let v = e in v), name of v is provided" ] .+ Shallow .+ Introduce
, external "let-float-app" (promoteExprR letFloatApp :: RewriteH Core)
[ "(let v = ev in e) x ==> let v = ev in e x" ] .+ Commute .+ Shallow .+ Bash
, external "let-float-arg" (promoteExprR letFloatArg :: RewriteH Core)
[ "f (let v = ev in e) ==> let v = ev in f e" ] .+ Commute .+ Shallow .+ Bash
, external "let-float-let" (promoteProgramR letFloatLetTop <+ promoteExprR letFloatLet :: RewriteH Core)
[ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow .+ Bash
, external "let-float" (promoteProgramR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core)
[ "Float a Let whatever the context." ] .+ Commute .+ Shallow .+ Bash
, external "let-to-case" (promoteExprR letToCase :: RewriteH Core)
[ "let v = ev in e ==> case ev of v -> e" ] .+ Commute .+ Shallow .+ PreCondition
]
letIntro :: TH.Name -> RewriteH CoreExpr
letIntro nm = prefixFailMsg "Let introduction failed: " $
contextfreeT $ \ e -> do letvar <- newVarH (show nm) (exprType e)
return $ Let (NonRec letvar e) (Var letvar)
letFloatApp :: RewriteH CoreExpr
letFloatApp = prefixFailMsg "Let floating from App function failed: " $
do vs <- appT letVarsT freeVarsT intersect
let letAction = if null vs then idR else alphaLet
appT letAction idR $ \ (Let bnds e) x -> Let bnds $ App e x
letFloatArg :: RewriteH CoreExpr
letFloatArg = prefixFailMsg "Let floating from App argument failed: " $
do vs <- appT freeVarsT letVarsT intersect
let letAction = if null vs then idR else alphaLet
appT idR letAction $ \ f (Let bnds e) -> Let bnds $ App f e
letFloatLet :: RewriteH CoreExpr
letFloatLet = prefixFailMsg "Let floating from Let failed: " $
do vs <- letNonRecT letVarsT freeVarsT (\ _ -> intersect)
let bdsAction = if null vs then idR else nonRecR alphaLet
letT bdsAction idR $ \ (NonRec v (Let bds ev)) e -> Let bds $ Let (NonRec v ev) e
letFloatExpr :: RewriteH CoreExpr
letFloatExpr = setFailMsg "Unsuitable expression for Let floating." $
letFloatApp <+ letFloatArg <+ letFloatLet
letFloatLetTop :: RewriteH CoreProgram
letFloatLetTop = setFailMsg ("Let floating to top level failed: " ++ wrongExprForm "NonRec v (Let (NonRec w ew) ev) : bds") $
do NonRec v (Let (NonRec w ew) ev) : bds <- idR
return (NonRec w ew : NonRec v ev : bds)
letToCase :: RewriteH CoreExpr
letToCase = prefixFailMsg "Converting Let to Case failed: " $
do Let (NonRec v ev) _ <- idR
nameModifier <- freshNameGenT Nothing
caseBndr <- constT (cloneIdH nameModifier v)
letT mempty (renameIdR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')]