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" (promoteCoreR alphaR :: RewriteH LCore)
[ "Renames the bound variables at the current node."]
, external "alpha-lam" (promoteExprR . alphaLamR . Just :: String -> RewriteH LCore)
[ "Renames the bound variable in a Lambda expression to the given name."]
, external "alpha-lam" (promoteExprR (alphaLamR Nothing) :: RewriteH LCore)
[ "Renames the bound variable in a Lambda expression."]
, external "alpha-case-binder" (promoteExprR . alphaCaseBinderR . Just :: String -> RewriteH LCore)
[ "Renames the binder in a Case expression to the given name."]
, external "alpha-case-binder" (promoteExprR (alphaCaseBinderR Nothing) :: RewriteH LCore)
[ "Renames the binder in a Case expression."]
, external "alpha-alt" (promoteAltR alphaAltR :: RewriteH LCore)
[ "Renames all binders in a Case alternative."]
, external "alpha-alt" (promoteAltR . alphaAltWithR :: [String] -> RewriteH LCore)
[ "Renames all binders in a Case alternative using the user-provided list of new names."]
, external "alpha-case" (promoteExprR alphaCaseR :: RewriteH LCore)
[ "Renames all binders in a Case alternative."]
, external "alpha-let" (promoteExprR . alphaLetWithR :: [String] -> RewriteH LCore)
[ "Renames the bound variables in a Let expression using a list of suggested names."]
, external "alpha-let" (promoteExprR alphaLetR :: RewriteH LCore)
[ "Renames the bound variables in a Let expression."]
, external "alpha-top" (promoteProgR . alphaProgConsWithR :: [String] -> RewriteH LCore)
[ "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 LCore)
[ "Renames the bound identifiers in the top-level binding at the head of the program."]
, external "alpha-prog" (promoteProgR alphaProgR :: RewriteH LCore)
[ "Rename all top-level identifiers in the program."]
, external "unshadow" (promoteCoreR unshadowR :: RewriteH LCore)
[ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]
]
visibleVarsT :: (BoundVars c, Monad m) => Transform c m CoreTC VarSet
visibleVarsT =
liftM2 unionVarSet boundVarsT (promoteT $ 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