module Language.HERMIT.Primitive.AlphaConversion where
import GhcPlugins hiding (empty)
import Control.Arrow
import Data.Char (isDigit)
import Data.List (intersect, (\\), nub)
import Language.HERMIT.Context
import Language.HERMIT.Monad
import Language.HERMIT.Kure
import Language.HERMIT.External
import Language.HERMIT.Primitive.GHC(freeVarsT, substR)
import Language.HERMIT.Primitive.Common
import qualified Language.Haskell.TH as TH
import Prelude hiding (exp)
externals :: [External]
externals = map (.+ Deep)
[ external "alpha" alpha
[ "renames the bound variables at the current node."]
, external "alpha-lam" (promoteExprR . alphaLam . Just)
[ "renames the bound variable in a Lambda expression to the given name."]
, external "alpha-lam" (promoteExprR $ alphaLam Nothing)
[ "renames the bound variable in a Lambda expression."]
, external "alpha-case-binder" (promoteExprR . alphaCaseBinder . Just)
[ "renames the binder in a Case expression to the given name."]
, external "alpha-case-binder" (promoteExprR $ alphaCaseBinder Nothing)
[ "renames the binder in a Case expression."]
, external "alpha-alt" (promoteAltR alphaAlt)
[ "renames all binders in a Case alternative."]
, external "alpha-case" (promoteExprR alphaCase)
[ "renames all binders in a Case alternative."]
, external "alpha-let" (promoteExprR . alphaLetOne . Just)
[ "renames the bound variable in a Let expression with one binder to the given name."]
, external "alpha-let" (promoteExprR alphaLet)
[ "renames the bound variables in a Let expression."]
, external "alpha-top" (promoteProgramR . alphaConsOne . Just)
[ "renames the bound variable in a top-level binding with one binder to the given name."]
, external "alpha-top" (promoteProgramR alphaCons)
[ "renames the bound variables in a top-level binding."]
, external "shadow-query" (promoteExprT shadowedNamesQuery)
[ "List variable names shadowed by bindings in this expression." ] .+ Query
, external "if-shadow" (promoteExprR ifShadowingR)
[ "succeeds ONLY-IF bindings in this expression shadow free variable name(s)." ]
, external "unshadow" unshadow
[ "Rename local variable with manifestly unique names (x, x0, x1, ...)"]
]
visibleIds :: TranslateH CoreExpr [Id]
visibleIds = do ctx <- contextT
frees <- freeVarsT
return $ frees ++ (listBindings ctx)
freshNameGen :: (Maybe TH.Name) -> [Id] -> (String -> String)
freshNameGen newName idsToAvoid =
case newName of
Just name -> const (show name)
Nothing -> inventNames idsToAvoid
freshNameGenT :: (Maybe TH.Name) -> TranslateH CoreExpr (String -> String)
freshNameGenT newName =
case newName of
Just name -> return $ const (show name)
Nothing -> do idsToAvoid <- visibleIds
return $ freshNameGen Nothing idsToAvoid
inventNames :: [Id] -> String -> String
inventNames curr old = head
[ nm
| nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]
, nm `notElem` names
]
where
names = map getOccString curr
nums = reverse $ takeWhile isDigit (reverse old)
baseLeng = length $ drop (length nums) old
base = take baseLeng old
start = case reads nums of
[(v,_)] -> (v + 1)
_ -> 0
shadowedNamesT :: TranslateH CoreExpr [String]
shadowedNamesT = do ctx <- contextT
frees <- freeVarsT
bindingIds <- extractT bindingVarsT
let shadows = intersect (map getOccString bindingIds)
(map getOccString (frees ++ (listBindings ctx)))
return shadows
shadowedNamesQuery :: TranslateH CoreExpr String
shadowedNamesQuery = shadowedNamesT >>^ (("Names shadowed by bindings in the current expression: " ++) . show)
ifShadowingR :: RewriteH CoreExpr
ifShadowingR = do shadows <- shadowedNamesT
case shadows of
[] -> fail "Bindings at this node do not shadow."
_ -> idR
renameIdR :: (Injection a Core, Generic a ~ Core) => Id -> Id -> RewriteH a
renameIdR v v' = extractR $ tryR $ substR v (Var v')
replaceId :: Id -> Id -> (Id -> Id)
replaceId v v' i = if v == i then v' else i
alphaLam :: Maybe TH.Name -> RewriteH CoreExpr
alphaLam mn = setFailMsg (wrongFormForAlpha "Lam v e") $
do (v, nameModifier) <- lamT (freshNameGenT mn) (,)
v' <- constT (cloneIdH nameModifier v)
lamT (renameIdR v v') (\ _ -> Lam v')
alphaCaseBinder :: Maybe TH.Name -> RewriteH CoreExpr
alphaCaseBinder mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $
do Case _ v _ _ <- idR
nameModifier <- freshNameGenT mn
v' <- constT (cloneIdH nameModifier v)
caseT idR (\ _ -> renameIdR v v') (\ e _ t alts -> Case e v' t alts)
alphaAltId :: Maybe TH.Name -> Id -> RewriteH CoreAlt
alphaAltId mn v = do nameModifier <- altT (freshNameGenT mn) (\ _ _ nameGen -> nameGen)
v' <- constT (cloneIdH nameModifier v)
altT (renameIdR v v') (\ con vs e -> (con, map (replaceId v v') vs, e))
alphaAlt :: RewriteH CoreAlt
alphaAlt = setFailMsg (wrongFormForAlpha "(con,vs,e)") $
do (_, vs, _) <- idR
andR $ map (alphaAltId Nothing) vs
alphaCase :: RewriteH CoreExpr
alphaCase = alphaCaseBinder Nothing >+> caseAnyR (fail "") (const alphaAlt)
alphaLetNonRec :: Maybe TH.Name -> RewriteH CoreExpr
alphaLetNonRec mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $
do (v, nameModifier) <- letNonRecT idR (freshNameGenT mn) (\ v _ nameMod -> (v, nameMod))
v' <- constT (cloneIdH nameModifier v)
letNonRecT idR (renameIdR v v') (\ _ e1 e2 -> Let (NonRec v' e1) e2)
alphaLetRecId :: Maybe TH.Name -> Id -> RewriteH CoreExpr
alphaLetRecId mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $
do Let (Rec {}) _ <- idR
ctx <- contextT
frees <- letRecDefT (\ _ -> freeVarsT) freeVarsT (\ bindFrees exprFrees -> (concat (map snd bindFrees)) ++ exprFrees)
let nameGen = case mn of
Just name -> const (show name)
Nothing -> inventNames (frees ++ (listBindings ctx))
v' <- constT (cloneIdH nameGen v)
letRecDefT (\ _ -> renameIdR v v') (renameIdR v v') (\ bs e -> Let (Rec $ (map.first) (replaceId v v') bs) e)
alphaLetRec :: RewriteH CoreExpr
alphaLetRec = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $
do Let (Rec bs) _ <- idR
andR $ map (alphaLetRecId Nothing . fst) bs
alphaLetRecOne :: Maybe TH.Name -> RewriteH CoreExpr
alphaLetRecOne mn = setFailMsg (wrongFormForAlpha "Let (Rec [(v,e1)]) e2") $
do Let (Rec [(v, _)]) _ <- idR
alphaLetRecId mn v
alphaLetOne :: Maybe TH.Name -> RewriteH CoreExpr
alphaLetOne mn = alphaLetNonRec mn <+ alphaLetRecOne mn
alphaLet :: RewriteH CoreExpr
alphaLet = alphaLetRec <+ alphaLetNonRec Nothing
alphaConsNonRec :: Maybe TH.Name -> RewriteH CoreProgram
alphaConsNonRec mn = setFailMsg (wrongFormForAlpha "NonRec v e : prog") $
do NonRec v _ : _ <- idR
nameModifier <- consNonRecT (freshNameGenT mn) idR (\ _ nameGen _ -> nameGen)
v' <- constT (cloneIdH nameModifier v)
consNonRecT idR (renameIdR v v') (\ _ e1 e2 -> NonRec v' e1 : e2)
alphaConsRecId :: Maybe TH.Name -> Id -> RewriteH CoreProgram
alphaConsRecId mn v = setFailMsg (wrongFormForAlpha "Rec bs : prog") $
do rbs@(Rec _) : _ <- idR
ctx <- contextT
frees <- consRecDefT (\ _ -> freeVarsT) idR (\ frees _ -> concat (map snd frees))
let idsToAvoid = ((nub frees) \\ (bindings rbs)) ++ (listBindings ctx)
nameGen = case mn of
Just name -> const (show name)
Nothing -> inventNames idsToAvoid
v' <- constT (cloneIdH nameGen v)
consRecDefT (\ _ -> renameIdR v v') (renameIdR v v') (\ bs e -> Rec ((map.first) (replaceId v v') bs) : e)
alphaConsRec :: RewriteH CoreProgram
alphaConsRec = setFailMsg (wrongFormForAlpha "Rec bs : prog") $
do Rec bs : _ <- idR
andR $ map (alphaConsRecId Nothing . fst) bs
alphaConsRecOne :: Maybe TH.Name -> RewriteH CoreProgram
alphaConsRecOne mn = setFailMsg (wrongFormForAlpha "Rec [(v,e)] : prog") $
do Rec [(v, _)] : _ <- idR
alphaConsRecId mn v
alphaConsOne :: Maybe TH.Name -> RewriteH CoreProgram
alphaConsOne mn = alphaConsNonRec mn <+ alphaConsRecOne mn
alphaCons :: RewriteH CoreProgram
alphaCons = alphaConsRec <+ alphaConsNonRec Nothing
alpha :: RewriteH Core
alpha = setFailMsg "Cannot alpha-rename here." $
promoteExprR (alphaLam Nothing <+ alphaCaseBinder Nothing <+ alphaLet)
<+ promoteProgramR alphaCons
unshadow :: RewriteH Core
unshadow = setFailMsg "No shadows to eliminate." $
anytdR (promoteExprR (ifShadowingR >>> (alphaLam Nothing <+ alphaCase <+ alphaLet)))
wrongFormForAlpha :: String -> String
wrongFormForAlpha s = "Cannot alpha-rename: " ++ wrongExprForm s