module Language.HERMIT.Primitive.AlphaConversion
(
externals
, alpha
, alphaLam
, alphaCaseBinder
, alphaAltWith
, alphaAltVars
, alphaAlt
, alphaCase
, alphaLetWith
, alphaLetVars
, alphaLet
, alphaConsWith
, unshadow
, visibleVarsT
, freshNameGenT
, freshNameGenAvoiding
, replaceVarR
)
where
import GhcPlugins hiding (empty)
import Control.Arrow
import Control.Monad (liftM, liftM2)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Monoid
import Data.Set (Set, union, unions, member, notMember, toList, fromList)
import qualified Data.Set as S
import Language.HERMIT.Core
import Language.HERMIT.Context
import Language.HERMIT.Monad
import Language.HERMIT.Kure
import Language.HERMIT.External
import Language.HERMIT.Primitive.GHC hiding (externals)
import Language.HERMIT.Primitive.Common
import qualified Language.Haskell.TH as TH
import Prelude hiding (exp)
externals :: [External]
externals = map (.+ Deep)
[ external "alpha" (alpha :: RewriteH Core)
[ "Renames the bound variables at the current node."]
, external "alpha-lam" (promoteExprR . alphaLam . Just :: TH.Name -> RewriteH Core)
[ "Renames the bound variable in a Lambda expression to the given name."]
, external "alpha-lam" (promoteExprR (alphaLam Nothing) :: RewriteH Core)
[ "Renames the bound variable in a Lambda expression."]
, external "alpha-case-binder" (promoteExprR . alphaCaseBinder . Just :: TH.Name -> RewriteH Core)
[ "Renames the binder in a Case expression to the given name."]
, external "alpha-case-binder" (promoteExprR (alphaCaseBinder Nothing) :: RewriteH Core)
[ "Renames the binder in a Case expression."]
, external "alpha-alt" (promoteAltR alphaAlt :: RewriteH Core)
[ "Renames all binders in a Case alternative."]
, external "alpha-alt" (promoteAltR . alphaAltWith :: [TH.Name] -> RewriteH Core)
[ "Renames all binders in a Case alternative using the user-provided list of new names."]
, external "alpha-case" (promoteExprR alphaCase :: RewriteH Core)
[ "Renames all binders in a Case alternative."]
, external "alpha-let" (promoteExprR . alphaLetWith :: [TH.Name] -> RewriteH Core)
[ "Renames the bound variables in a Let expression using a list of suggested names."]
, external "alpha-let" (promoteExprR alphaLet :: RewriteH Core)
[ "Renames the bound variables in a Let expression."]
, external "alpha-top" (promoteProgR . alphaConsWith :: [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" (unshadow :: RewriteH Core)
[ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]
]
visibleVarsT :: (BoundVars c, Monad m) => Translate c m CoreExpr (Set Var)
visibleVarsT = liftM2 union boundVarsT freeVarsT
freshNameGenT :: (BoundVars c, Monad m) => Maybe TH.Name -> Translate c m CoreExpr (String -> String)
freshNameGenT mn = freshNameGenAvoiding mn `liftM` visibleVarsT
freshNameGenAvoiding :: Maybe TH.Name -> Set Var -> (String -> String)
freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase mn
inventNames :: Set Var -> String -> String
inventNames curr old = head
[ nm
| nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]
, nm `notMember` names
]
where
names = S.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
shadowedBy :: Set Var -> Set Var -> Set Var
shadowedBy vs fvs = S.filter (\ v -> getOccString v `member` S.map getOccString fvs) vs
shadowedByT :: MonadCatch m => Translate c m a (Set Var) -> Translate c m a (Set Var) -> Translate c m a (Set Var)
shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (liftM2 shadowedBy t1 t2) >>> acceptR (not . S.null)
unshadow :: forall c. (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core
unshadow = setFailMsg "No shadows to eliminate." $
anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt)
where
unshadowExpr :: Rewrite c HermitM CoreExpr
unshadowExpr = do vs <- shadowedByT (liftM2 union boundVarsT freeVarsT) (liftM fromList (letVarsT <+ fmap return (caseWildIdT <+ lamVarT)))
alphaLam Nothing <+ alphaLetVars (toList vs) <+ alphaCaseBinder Nothing
unshadowAlt :: Rewrite c HermitM CoreAlt
unshadowAlt = shadowedByT (liftM fromList altVarsT) (liftM2 union boundVarsT altFreeVarsT) >>= (alphaAltVars . toList)
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)
alphaLam :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr
alphaLam 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')
alphaCaseBinder :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr
alphaCaseBinder 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')
alphaAltVar :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt
alphaAltVar 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')
alphaAltVarsWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt
alphaAltVarsWith = andR . map (uncurry alphaAltVar)
alphaAltWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreAlt
alphaAltWith ns = do vs <- altVarsT
alphaAltVarsWith $ zip (map Just ns) vs
alphaAltVars :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt
alphaAltVars = alphaAltVarsWith . zip (repeat Nothing)
alphaAlt :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt
alphaAlt = altVarsT >>= alphaAltVars
alphaCase :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr
alphaCase = alphaCaseBinder Nothing >+> caseAllR idR idR idR (const alphaAlt)
alphaLetNonRec :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr
alphaLetNonRec 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')
alphaLetNonRecVars :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr
alphaLetNonRecVars mn vs = whenM ((`elem` vs) `liftM` letNonRecVarT) (alphaLetNonRec mn)
alphaLetRecId :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr
alphaLetRecId mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $
do usedVars <- liftM2 union boundVarsT
$ letRecT (\ _ -> defT idR freeVarsT S.insert) freeVarsT (\ bndfvs vs -> unions (vs:bndfvs))
v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)
letRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v')
alphaLetRecIdsWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr
alphaLetRecIdsWith = andR . map (uncurry alphaLetRecId)
alphaLetWith :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr
alphaLetWith ns = alphaLetNonRec (listToMaybe ns)
<+ (letRecIdsT >>= (alphaLetRecIdsWith . zip (map Just ns)))
alphaLetVars :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr
alphaLetVars vs = alphaLetNonRecVars Nothing vs <+ alphaLetRecIdsWith (zip (repeat Nothing) vs)
alphaLet :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr
alphaLet = letVarsT >>= alphaLetVars
alphaConsNonRec :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg
alphaConsNonRec 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')
alphaConsRecId :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg
alphaConsRecId 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')
alphaConsRecIdsWith :: (ExtendPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg
alphaConsRecIdsWith = andR . map (uncurry alphaConsRecId)
alphaConsWith :: (ExtendPath c Crumb, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg
alphaConsWith [] = fail "At least one new name must be provided."
alphaConsWith (n:ns) = alphaConsNonRec n <+ (consRecIdsT >>= (alphaConsRecIdsWith . zip (n:ns)))
alpha :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core
alpha = setFailMsg "Cannot alpha-rename here." $
promoteExprR (alphaLam Nothing <+ alphaCaseBinder Nothing <+ alphaLet)
<+ promoteAltR alphaAlt
wrongFormForAlpha :: String -> String
wrongFormForAlpha s = "Cannot alpha-rename, " ++ wrongExprForm s