module HERMIT.Dictionary.AlphaConversion
(
externals
, alphaR
, alphaLamR
, alphaCaseBinderR
, alphaAltWithR
, alphaAltVarsR
, alphaAltR
, alphaCaseR
, alphaLetWithR
, alphaLetVarsR
, alphaLetR
, alphaProgConsWithR
, unshadowR
, visibleVarsT
, freshNameGenT
, freshNameGenAvoiding
, replaceVarR
)
where
import Control.Applicative
import Control.Arrow
import Control.Monad (liftM, liftM2)
import Data.Char (isDigit)
import Data.List (intersect)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Monoid
import HERMIT.Core
import HERMIT.Context
import HERMIT.Monad
import HERMIT.Kure
import HERMIT.External
import HERMIT.GHC
import HERMIT.Dictionary.GHC hiding (externals)
import HERMIT.Dictionary.Common
import qualified Language.Haskell.TH as TH
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 :: TH.Name -> 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 :: TH.Name -> 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 :: [TH.Name] -> 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 :: [TH.Name] -> 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 :: [TH.Name] -> 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 "unshadow" (unshadowR :: RewriteH Core)
[ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]
]
visibleVarsT :: (BoundVars c, Monad m) => Translate c m CoreExpr VarSet
visibleVarsT = liftM2 unionVarSet boundVarsT (arr freeVarsExpr)
freshNameGenT :: (BoundVars c, Monad m) => Maybe TH.Name -> Translate c m CoreExpr (String -> String)
freshNameGenT mn = freshNameGenAvoiding mn `liftM` visibleVarsT
freshNameGenAvoiding :: Maybe TH.Name -> VarSet -> (String -> String)
freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase 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
shadowedByT :: MonadCatch m => Translate c m a VarSet -> Translate c m a VarSet -> Translate c m a VarSet
shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (liftM2 shadowedBy t1 t2) >>> acceptR (not . isEmptyVarSet)
unshadowR :: forall c. (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core
unshadowR = setFailMsg "No shadows to eliminate." $
anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt)
where
unshadowExpr :: Rewrite c HermitM CoreExpr
unshadowExpr = do vs <- shadowedByT (mkVarSet <$> (letVarsT <+ (return <$> (caseWildIdT <+ lamVarT))))
(unionVarSet <$> boundVarsT <*> arr freeVarsExpr)
alphaLamR Nothing <+ alphaLetVarsR (varSetElems vs) <+ alphaCaseBinderR Nothing
unshadowAlt :: Rewrite c HermitM CoreAlt
unshadowAlt = do vs <- shadowedByT (arr (mkVarSet . altVars))
(unionVarSet <$> boundVarsT <*> arr freeVarsAlt)
alphaAltVarsR (varSetElems vs)
replaceVarR :: (ExtendPath c Crumb, AddBindings c, 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, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr
alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $
do (v, nameModifier) <- lamT idR (freshNameGenT mn) (,)
v' <- constT (cloneVarH nameModifier v)
lamAnyR (arr $ replaceVar v v') (replaceVarR v v')
alphaCaseBinderR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr
alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $
do Case _ v _ _ <- idR
nameModifier <- freshNameGenT mn
v' <- constT (cloneVarH nameModifier v)
caseAnyR idR (return v') idR (\ _ -> replaceVarR v v')
alphaAltVarR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt
alphaAltVarR mn v =
do nameModifier <- altT idR (\ _ -> idR) (freshNameGenT mn) (\ _ _ nameGen -> nameGen)
v' <- constT (cloneVarH nameModifier v)
altAnyR (fail "") (\ _ -> arr (replaceVar v v')) (replaceVarR v v')
alphaAltVarsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt
alphaAltVarsWithR = andR . map (uncurry alphaAltVarR)
alphaAltWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreAlt
alphaAltWithR ns =
do vs <- arr altVars
alphaAltVarsWithR $ zip (map Just ns) vs
alphaAltVarsR :: (ExtendPath 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, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt
alphaAltR = arr altVars >>= alphaAltVarsR
alphaCaseR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr
alphaCaseR = alphaCaseBinderR Nothing >+> caseAllR idR idR idR (const alphaAltR)
alphaLetNonRecR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr
alphaLetNonRecR mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $
do (v, nameModifier) <- letNonRecT idR mempty (freshNameGenT mn) (\ v () nameMod -> (v, nameMod))
v' <- constT (cloneVarH nameModifier v)
letNonRecAnyR (return v') idR (replaceVarR v v')
alphaLetNonRecVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr
alphaLetNonRecVarsR mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRecR mn)
alphaLetRecIdR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr
alphaLetRecIdR mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $
do usedVars <- unionVarSet <$> boundVarsT
<*> letRecT (\ _ -> defT idR (arr freeVarsExpr) (flip extendVarSet)) (arr freeVarsExpr) (\ bndfvs vs -> unionVarSets (vs:bndfvs))
v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)
letRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')
alphaLetRecIdsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr
alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR)
alphaLetWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr
alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns)
<+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns)))
alphaLetVarsR :: (ExtendPath 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, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr
alphaLetR = letVarsT >>= alphaLetVarsR
alphaProgConsNonRecR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg
alphaProgConsNonRecR n = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $
do ProgCons (NonRec v _) _ <- idR
v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)
consNonRecAnyR (return v') idR (replaceVarR v v')
alphaProgConsRecIdR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg
alphaProgConsRecIdR n v = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $
do v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)
consRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')
alphaProgConsRecIdsWithR :: (ExtendPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg
alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR)
alphaProgConsWithR :: (ExtendPath c Crumb, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg
alphaProgConsWithR [] = fail "At least one new name must be provided."
alphaProgConsWithR (n:ns) = alphaProgConsNonRecR n <+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (n:ns)))
alphaR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core
alphaR = setFailMsg "Cannot alpha-rename here." $
promoteExprR (alphaLamR Nothing <+ alphaCaseBinderR Nothing <+ alphaLetR)
<+ promoteAltR alphaAltR
wrongFormForAlpha :: String -> String
wrongFormForAlpha s = "Cannot alpha-rename, " ++ wrongExprForm s