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.Arrow
import Control.Monad (liftM, liftM2)
import Data.Char (isDigit)
import Data.Function (on)
import Data.List (intersect, delete, elemIndex)
import Data.Maybe (listToMaybe)
import HERMIT.Core
import HERMIT.Context
import HERMIT.Kure
import HERMIT.External
import HERMIT.GHC
import HERMIT.Name
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, MonadUnique m) => Var -> Maybe String -> [Var] -> Transform c m 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 = varSetToStrings 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 fvNames = varSetToStrings fvs
in filterVarSet (\ v -> unqualifiedName v `elem` fvNames) 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, MonadCatch m, MonadUnique m )
=> Rewrite c m 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, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
unshadowExprR = do
bs <- letVarsT <+ (liftM return (caseBinderIdT <+ lamVarT))
fvs <- liftM2 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, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreAlt
unshadowAltR = do
bs <- arr altVars
fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsAlt)
ss <- detectShadowsM bs fvs
alphaAltVarsR (varSetElems ss)
unshadowProgR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreProg
unshadowProgR = do
bs <- progConsIdsT
fvs <- liftM2 unionVarSet boundVarsT (arr freeVarsProg)
ss <- detectShadowsM bs fvs
alphaProgConsIdsR (varSetElems ss)
dupVars :: [Var] -> [Var]
dupVars = dupsBy ((==) `on` unqualifiedName)
replaceVarR :: (Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a
replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v'
replaceRecBindVarR :: Monad m => Id -> Id -> Rewrite c m CoreBind
replaceRecBindVarR v v' =
do Rec ies <- idR
let (is,es) = unzip ies
case elemIndex v is of
Nothing -> fail "Specified identifier does not occur in the current recursive binding group."
Just n -> let is0 = delete v is
(is1,is2) = splitAt n is0
is' = is1 ++ v' : is2
es' = map (substCoreExpr v (Var v')) es
sub = extendSubst emptySubst v (Var v')
in return $ snd $ substBind sub (Rec (zip is' es'))
alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Maybe String -> Rewrite c m CoreExpr
alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $
do v <- lamVarT
v' <- extractT (cloneVarAvoidingT v mn [v])
lamAnyR (return v') (replaceVarR v v')
alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Maybe String -> Rewrite c m 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, MonadCatch m, MonadUnique m)
=> Maybe String -> Var -> Rewrite c m 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, MonadCatch m, MonadUnique m)
=> [(Maybe String,Var)] -> Rewrite c m CoreAlt
alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) . reverse
alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> [String] -> Rewrite c m CoreAlt
alphaAltWithR ns =
do vs <- arr altVars
alphaAltVarsWithR $ zip (map Just ns) vs
alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> [Var] -> Rewrite c m 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, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreAlt
alphaAltR = arr altVars >>= alphaAltVarsR
alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
alphaCaseR = alphaCaseBinderR Nothing >+> caseAllR idR idR idR (const alphaAltR)
alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Maybe String -> Rewrite c m 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, MonadCatch m, MonadUnique m)
=> Maybe String -> [Var] -> Rewrite c m CoreExpr
alphaLetNonRecVarsR mn vs = whenM (liftM (`elem` vs) letNonRecVarT) (alphaLetNonRecR mn)
alphaLetRecIdsWithR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, BoundVars c, MonadCatch m, MonadUnique m )
=> [(Maybe String,Id)] -> Rewrite c m CoreExpr
alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR)
where
alphaLetRecIdR :: Maybe String -> Id -> Rewrite c m CoreExpr
alphaLetRecIdR mn i = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $
do is <- letRecIdsT
i' <- extractT (cloneVarAvoidingT i mn is)
letAnyR (replaceRecBindVarR i i') (replaceVarR i i')
alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> [String] -> Rewrite c m CoreExpr
alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns)
<+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns)))
alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> [Var] -> Rewrite c m 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, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
alphaLetR = letVarsT >>= alphaLetVarsR
alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Maybe String -> Rewrite c m CoreProg
alphaProgConsNonRecR mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $
do i <- progConsNonRecIdT
guardMsg (not $ isExportedId i) ("Identifier " ++ unqualifiedName 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, MonadCatch m, MonadUnique m)
=> Maybe String -> [Id] -> Rewrite c m CoreProg
alphaProgConsNonRecIdsR mn is = whenM (liftM (`elem` is) progConsNonRecIdT) (alphaProgConsNonRecR mn)
alphaProgConsRecIdsWithR :: forall c m. ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, BoundVars c, MonadCatch m, MonadUnique m )
=> [(Maybe String,Id)] -> Rewrite c m CoreProg
alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR) . filter (not . isExportedId . snd)
where
alphaProgConsRecIdR :: Maybe String -> Id -> Rewrite c m CoreProg
alphaProgConsRecIdR mn i = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $
do is <- progConsRecIdsT
i' <- extractT (cloneVarAvoidingT i mn is)
progConsAnyR (replaceRecBindVarR i i') (replaceVarR i i')
alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> [String] -> Rewrite c m CoreProg
alphaProgConsWithR ns = alphaProgConsNonRecR (listToMaybe ns)
<+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (map Just ns)))
alphaProgConsIdsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> [Id] -> Rewrite c m 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, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreProg
alphaProgConsR = progConsIdsT >>= alphaProgConsIdsR
alphaProgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreProg
alphaProgR = alphaProgConsR >+> progConsAllR idR alphaProgR
alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m 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