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.Applicative
import Control.Arrow
import Data.Char (isDigit)
import Data.List (nub)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Monoid
import Language.HERMIT.Core
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
[ "Renames the bound variables at the current node."]
, external "alpha-lam" (promoteExprR . alphaLam . Just)
[ "Renames the bound variable in a Lambda expression to the given name."]
, external "alpha-lam" (promoteExprR $ alphaLam Nothing)
[ "Renames the bound variable in a Lambda expression."]
, external "alpha-case-binder" (promoteExprR . alphaCaseBinder . Just)
[ "Renames the binder in a Case expression to the given name."]
, external "alpha-case-binder" (promoteExprR $ alphaCaseBinder Nothing)
[ "Renames the binder in a Case expression."]
, external "alpha-alt" (promoteAltR alphaAlt)
[ "Renames all binders in a Case alternative."]
, external "alpha-alt" (promoteAltR . alphaAltWith)
[ "Renames all binders in a Case alternative using the user-provided list of new names."]
, external "alpha-case" (promoteExprR alphaCase)
[ "Renames all binders in a Case alternative."]
, external "alpha-let" (promoteExprR . alphaLetWith)
[ "Renames the bound variables in a Let expression using a list of suggested names."]
, external "alpha-let" (promoteExprR alphaLet)
[ "Renames the bound variables in a Let expression."]
, external "alpha-top" (promoteProgR . alphaConsWith)
[ "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
[ "Rename local variables with manifestly unique names (x, x0, x1, ...)."]
]
visibleVarsT :: TranslateH CoreExpr [Var]
visibleVarsT = boundVarsT `mappend` freeVarsT
freshNameGenT :: Maybe TH.Name -> TranslateH CoreExpr (String -> String)
freshNameGenT mn = freshNameGenAvoiding mn <$> visibleVarsT
freshNameGenAvoiding :: Maybe TH.Name -> [Var] -> (String -> String)
freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase mn
inventNames :: [Var] -> String -> String
inventNames curr old = head
[ nm
| nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ]
, nm `notElem` names
]
where
names = nub (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 :: [Var] -> [Var] -> [Var]
shadowedBy vs fvs = filter (\ v -> getOccString v `elem` map getOccString fvs) vs
shadowedByT :: TranslateH a [Var] -> TranslateH a [Var] -> TranslateH a [Var]
shadowedByT t1 t2 = setFailMsg "No shadows detected." $ (shadowedBy <$> t1 <*> t2) >>> acceptR (not . null)
unshadow :: RewriteH Core
unshadow = setFailMsg "No shadows to eliminate." $
anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt)
where
unshadowExpr :: RewriteH CoreExpr
unshadowExpr = do vs <- shadowedByT (boundVarsT `mappend` freeVarsT) (letVarsT <+ fmap return (caseWildIdT <+ lamVarT))
alphaLam Nothing <+ alphaLetVars vs <+ alphaCaseBinder Nothing
unshadowAlt :: RewriteH CoreAlt
unshadowAlt = shadowedByT altVarsT (boundVarsT `mappend` altFreeVarsT) >>= alphaAltVars
replaceVarR :: (Injection a Core) => Var -> Var -> RewriteH 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 :: Maybe TH.Name -> RewriteH CoreExpr
alphaLam mn = setFailMsg (wrongFormForAlpha "Lam v e") $
do (v, nameModifier) <- lamT (freshNameGenT mn) (,)
v' <- constT (cloneVarH nameModifier v)
lamT (replaceVarR v v') (\ _ -> Lam v')
alphaCaseBinder :: Maybe TH.Name -> RewriteH CoreExpr
alphaCaseBinder mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $
do Case _ v _ _ <- idR
nameModifier <- freshNameGenT mn
v' <- constT (cloneVarH nameModifier v)
caseT idR (\ _ -> replaceVarR v v') (\ e _ t alts -> Case e v' t alts)
alphaAltVar :: Maybe TH.Name -> Var -> RewriteH CoreAlt
alphaAltVar mn v = do nameModifier <- altT (freshNameGenT mn) (\ _ _ nameGen -> nameGen)
v' <- constT (cloneVarH nameModifier v)
altT (replaceVarR v v') (\ con vs e -> (con, map (replaceVar v v') vs, e))
alphaAltVarsWith :: [(Maybe TH.Name,Var)] -> RewriteH CoreAlt
alphaAltVarsWith = andR . map (uncurry alphaAltVar)
alphaAltWith :: [TH.Name] -> RewriteH CoreAlt
alphaAltWith ns = do vs <- altVarsT
alphaAltVarsWith $ zip (map Just ns) vs
alphaAltVars :: [Var] -> RewriteH CoreAlt
alphaAltVars = alphaAltVarsWith . zip (repeat Nothing)
alphaAlt :: RewriteH CoreAlt
alphaAlt = altVarsT >>= alphaAltVars
alphaCase :: RewriteH CoreExpr
alphaCase = alphaCaseBinder Nothing >+> caseAnyR (fail "") (const alphaAlt)
alphaLetNonRec :: Maybe TH.Name -> RewriteH CoreExpr
alphaLetNonRec mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $
do (v, nameModifier) <- letNonRecT idR (freshNameGenT mn) (\ v _ nameMod -> (v, nameMod))
v' <- constT (cloneVarH nameModifier v)
letNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> Let (NonRec v' e1) e2)
alphaLetNonRecVars :: Maybe TH.Name -> [Var] -> RewriteH CoreExpr
alphaLetNonRecVars mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRec mn)
alphaLetRecId :: Maybe TH.Name -> Id -> RewriteH CoreExpr
alphaLetRecId mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $
do usedVars <- boundVarsT `mappend`
letVarsT `mappend`
letRecDefT (\ _ -> freeVarsT) freeVarsT (\ bndfvs vs -> concatMap snd bndfvs ++ vs)
v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v)
letRecDefT (\ _ -> replaceVarR v v')
(replaceVarR v v')
(\ bs e -> Let (Rec $ (map.first) (replaceVar v v') bs) e)
alphaLetRecIdsWith :: [(Maybe TH.Name,Id)] -> RewriteH CoreExpr
alphaLetRecIdsWith = andR . map (uncurry alphaLetRecId)
alphaLetWith :: [TH.Name] -> RewriteH CoreExpr
alphaLetWith ns = alphaLetNonRec (listToMaybe ns)
<+ (letRecIdsT >>= (alphaLetRecIdsWith . zip (map Just ns)))
alphaLetVars :: [Var] -> RewriteH CoreExpr
alphaLetVars vs = alphaLetNonRecVars Nothing vs <+ alphaLetRecIdsWith (zip (repeat Nothing) vs)
alphaLet :: RewriteH CoreExpr
alphaLet = letVarsT >>= alphaLetVars
alphaConsNonRec :: TH.Name -> RewriteH CoreProg
alphaConsNonRec n = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $
do ProgCons (NonRec v _) _ <- idR
v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)
consNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> ProgCons (NonRec v' e1) e2)
alphaConsRecId :: TH.Name -> Id -> RewriteH CoreProg
alphaConsRecId n v = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $
do v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v)
consRecDefT (\ _ -> replaceVarR v v')
(replaceVarR v v')
(\ bs e -> ProgCons (Rec $ (map.first) (replaceVar v v') bs) e)
alphaConsRecIdsWith :: [(TH.Name,Id)] -> RewriteH CoreProg
alphaConsRecIdsWith = andR . map (uncurry alphaConsRecId)
alphaConsWith :: [TH.Name] -> RewriteH CoreProg
alphaConsWith [] = fail "At least one new name must be provided."
alphaConsWith (n:ns) = alphaConsNonRec n <+ (consRecIdsT >>= (alphaConsRecIdsWith . zip (n:ns)))
alpha :: RewriteH 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