module HERMIT.Dictionary.AlphaConversion
(
externals
, alphaR
, alphaLamR
, alphaCaseBinderR
, alphaAltWithR
, alphaAltVarsR
, alphaAltR
, alphaCaseR
, alphaLetWithR
, alphaLetVarsR
, alphaLetR
, alphaProgConsWithR
, alphaProgConsIdsR
, alphaProgConsR
, alphaProgR
, unshadowR
, unshadowExprR
, unshadowAltR
, unshadowProgR
, visibleVarsT
, cloneVarAvoidingT
, freshNameGenAvoiding
, detectShadowsM
, replaceVarR
)
where
import Control.Applicative
import Control.Arrow
import Control.Monad (liftM2)
import Data.Char (isDigit)
import Data.Function (on)
import Data.List (intersect)
import Data.Maybe (fromMaybe, listToMaybe)
import HERMIT.Core
import HERMIT.Context
import HERMIT.Monad
import HERMIT.Kure
import HERMIT.External
import HERMIT.GHC
import HERMIT.Utilities(dupsBy)
import HERMIT.Dictionary.GHC hiding (externals)
import HERMIT.Dictionary.Common
import Prelude hiding (exp)
externals :: [External]
externals = map (.+ Deep)
[ external "alpha" (alphaR :: RewriteH Core)
[ "Renames the bound variables at the current node."]
, external "alpha-lam" (promoteExprR . alphaLamR . Just :: String -> RewriteH Core)
[ "Renames the bound variable in a Lambda expression to the given name."]
, external "alpha-lam" (promoteExprR (alphaLamR Nothing) :: RewriteH Core)
[ "Renames the bound variable in a Lambda expression."]
, external "alpha-case-binder" (promoteExprR . alphaCaseBinderR . Just :: String -> RewriteH Core)
[ "Renames the binder in a Case expression to the given name."]
, external "alpha-case-binder" (promoteExprR (alphaCaseBinderR Nothing) :: RewriteH Core)
[ "Renames the binder in a Case expression."]
, external "alpha-alt" (promoteAltR alphaAltR :: RewriteH Core)
[ "Renames all binders in a Case alternative."]
, external "alpha-alt" (promoteAltR . alphaAltWithR :: [String] -> RewriteH Core)
[ "Renames all binders in a Case alternative using the user-provided list of new names."]
, external "alpha-case" (promoteExprR alphaCaseR :: RewriteH Core)
[ "Renames all binders in a Case alternative."]
, external "alpha-let" (promoteExprR . alphaLetWithR :: [String] -> RewriteH Core)
[ "Renames the bound variables in a Let expression using a list of suggested names."]
, external "alpha-let" (promoteExprR alphaLetR :: RewriteH Core)
[ "Renames the bound variables in a Let expression."]
, external "alpha-top" (promoteProgR . alphaProgConsWithR :: [String] -> RewriteH Core)
[ "Renames the bound identifiers in the top-level binding group at the head of the program using a list of suggested names."]
, external "alpha-top" (promoteProgR alphaProgConsR :: RewriteH Core)
[ "Renames the bound identifiers in the top-level binding at the head of the program."]
, external "alpha-prog" (promoteProgR alphaProgR :: RewriteH Core)
[ "Rename all top-level identifiers in the program."]
, external "unshadow" (unshadowR :: RewriteH Core)
[ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]
]
visibleVarsT :: (BoundVars c, Monad m) => Transform c m CoreTC VarSet
visibleVarsT = liftM2 unionVarSet boundVarsT (arr freeVarsCoreTC)
cloneVarAvoidingT :: BoundVars c => Var -> Maybe String -> [Var] -> Transform c HermitM CoreTC Var
cloneVarAvoidingT v mn vs =
do vvs <- visibleVarsT
let nameModifier = freshNameGenAvoiding mn (extendVarSetList vvs vs)
constT (cloneVarH nameModifier v)
freshNameGenAvoiding :: Maybe String -> VarSet -> (String -> String)
freshNameGenAvoiding mn vs str = maybe (inventNames vs str) ((\(c:cs) -> reverse (c:(takeWhile (/='.') cs))) . reverse) mn
inventNames :: VarSet -> String -> String
inventNames curr old = head
[ nm
| nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]
, nm `notElem` names
]
where
names = map uqName (varSetElems 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
shadowedBy :: VarSet -> VarSet -> VarSet
shadowedBy vs fvs = let fvUqNames = map uqName (varSetElems fvs)
in filterVarSet (\ v -> uqName v `elem` fvUqNames) vs
detectShadowsM :: Monad m => [Var] -> VarSet -> m VarSet
detectShadowsM bs fvs = let ss = shadowedBy (mkVarSet bs) fvs `extendVarSetList` dupVars bs
in do guardMsg (not $ isEmptyVarSet ss) "No shadows detected."
return ss
unshadowR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb)
=> Rewrite c HermitM Core
unshadowR = setFailMsg "No shadows to eliminate." $
anytdR (promoteExprR unshadowExprR <+ promoteAltR unshadowAltR <+ promoteProgR unshadowProgR)
unshadowExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)
=> Rewrite c HermitM CoreExpr
unshadowExprR = do
bs <- letVarsT <+ (return <$> (caseBinderIdT <+ lamVarT))
fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsExpr
ss <- detectShadowsM bs fvs
alphaLamR Nothing <+ alphaLetVarsR (varSetElems ss) <+ alphaCaseBinderR Nothing
unshadowAltR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)
=> Rewrite c HermitM CoreAlt
unshadowAltR = do
bs <- arr altVars
fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsAlt
ss <- detectShadowsM bs fvs
alphaAltVarsR (varSetElems ss)
unshadowProgR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb)
=> Rewrite c HermitM CoreProg
unshadowProgR = do
bs <- progConsIdsT
fvs <- unionVarSet <$> boundVarsT <*> arr freeVarsProg
ss <- detectShadowsM bs fvs
alphaProgConsIdsR (varSetElems ss)
dupVars :: [Var] -> [Var]
dupVars = dupsBy ((==) `on` uqName)
replaceVarR :: (Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a
replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v'
replaceVar :: Var -> Var -> (Var -> Var)
replaceVar v v' = replaceVars [(v,v')]
replaceVars :: [(Var,Var)] -> (Var -> Var)
replaceVars kvs v = fromMaybe v (lookup v kvs)
alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr
alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $
do v <- lamVarT
v' <- extractT (cloneVarAvoidingT v mn [v])
lamAnyR (arr $ replaceVar v v') (replaceVarR v v')
alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr
alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e i ty alts") $
do i <- caseBinderIdT
i' <- extractT (cloneVarAvoidingT i mn [i])
caseAnyR idR (return i') idR (\ _ -> replaceVarR i i')
alphaAltVarR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Var -> Rewrite c HermitM CoreAlt
alphaAltVarR mn v = do
(con, vs, rhs) <- idR
v' <- extractT (cloneVarAvoidingT v mn vs)
case break (==v) vs of
(bs,_:bs') -> let (con',bs'',rhs') = substCoreAlt v (varToCoreExpr v') (con,bs',rhs)
in return (con',bs ++ (v':bs''),rhs')
_ -> fail "pattern binder not present."
alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Var)] -> Rewrite c HermitM CoreAlt
alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) . reverse
alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreAlt
alphaAltWithR ns =
do vs <- arr altVars
alphaAltVarsWithR $ zip (map Just ns) vs
alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt
alphaAltVarsR vs =
do bs <- arr altVars
alphaAltVarsWithR (zip (repeat Nothing) (bs `intersect` vs))
alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt
alphaAltR = arr altVars >>= alphaAltVarsR
alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr
alphaCaseR = alphaCaseBinderR Nothing >+> caseAllR idR idR idR (const alphaAltR)
alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreExpr
alphaLetNonRecR mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $
do v <- letNonRecVarT
v' <- extractT (cloneVarAvoidingT v mn [v])
letNonRecAnyR (return v') idR (replaceVarR v v')
alphaLetNonRecVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> [Var] -> Rewrite c HermitM CoreExpr
alphaLetNonRecVarsR mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRecR mn)
alphaLetRecIdsWithR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Id)] -> Rewrite c HermitM CoreExpr
alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR)
where
alphaLetRecIdR :: Maybe String -> Id -> Rewrite c HermitM CoreExpr
alphaLetRecIdR mn i = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $
do is <- letRecIdsT
i' <- extractT (cloneVarAvoidingT i mn is)
letRecDefAnyR (\ _ -> (arr (replaceVar i i'), replaceVarR i i')) (replaceVarR i i')
alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreExpr
alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns)
<+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns)))
alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr
alphaLetVarsR vs = alphaLetNonRecVarsR Nothing vs
<+ (do bs <- letT (arr bindVars) successT const
alphaLetRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs))
)
alphaLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr
alphaLetR = letVarsT >>= alphaLetVarsR
alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> Rewrite c HermitM CoreProg
alphaProgConsNonRecR mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $
do i <- progConsNonRecIdT
guardMsg (not $ isExportedId i) ("Identifier " ++ var2String i ++ " is exported, and thus cannot be alpha-renamed.")
i' <- extractT (cloneVarAvoidingT i mn [i])
consNonRecAnyR (return i') idR (replaceVarR i i')
alphaProgConsNonRecIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe String -> [Id] -> Rewrite c HermitM CoreProg
alphaProgConsNonRecIdsR mn is = whenM ((`elem` is) <$> progConsNonRecIdT) (alphaProgConsNonRecR mn)
alphaProgConsRecIdsWithR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe String,Id)] -> Rewrite c HermitM CoreProg
alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR) . filter (not . isExportedId . snd)
where
alphaProgConsRecIdR :: Maybe String -> Id -> Rewrite c HermitM CoreProg
alphaProgConsRecIdR mn i = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $
do is <- progConsRecIdsT
i' <- extractT (cloneVarAvoidingT i mn is)
consRecDefAnyR (\ _ -> (arr (replaceVar i i'), replaceVarR i i')) (replaceVarR i i')
alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [String] -> Rewrite c HermitM CoreProg
alphaProgConsWithR ns = alphaProgConsNonRecR (listToMaybe ns)
<+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (map Just ns)))
alphaProgConsIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Id] -> Rewrite c HermitM CoreProg
alphaProgConsIdsR vs = alphaProgConsNonRecIdsR Nothing vs
<+ (do bs <- progConsT (arr bindVars) successT const
alphaProgConsRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs))
)
alphaProgConsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg
alphaProgConsR = progConsIdsT >>= alphaProgConsIdsR
alphaProgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg
alphaProgR = alphaProgConsR >+> progConsAllR idR alphaProgR
alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core
alphaR = setFailMsg "Cannot alpha-rename here." $
promoteExprR (alphaLamR Nothing <+ alphaCaseBinderR Nothing <+ alphaLetR)
<+ promoteAltR alphaAltR
<+ promoteProgR alphaProgConsR
wrongFormForAlpha :: String -> String
wrongFormForAlpha s = "Cannot alpha-rename, " ++ wrongExprForm s