forked from GitHub/gf-core
experiment with new Rename
This commit is contained in:
aarne
281
src/GF/Compile/NewRename.hs
Normal file
281
src/GF/Compile/NewRename.hs
Normal file
@@ -0,0 +1,281 @@
|
||||
module Rename where
|
||||
|
||||
import Grammar
|
||||
import Values
|
||||
import Modules
|
||||
import Ident
|
||||
import Macros
|
||||
import PrGrammar
|
||||
import AppPredefined
|
||||
import Lookup
|
||||
import Extend
|
||||
import Operations
|
||||
|
||||
import Monad
|
||||
|
||||
-- AR 14/5/2003
|
||||
|
||||
-- The top-level function $renameGrammar$ does several things:
|
||||
-- * extends each module symbol table by indirections to extended module
|
||||
-- * changes unqualified and as-qualified imports to absolutely qualified
|
||||
-- * goes through the definitions and resolves names
|
||||
-- Dependency analysis between modules has been performed before this pass.
|
||||
-- Hence we can proceed by $fold$ing 'from left to right'.
|
||||
|
||||
-- this gives top-level access to renaming term input in the cc command
|
||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
|
||||
renameSourceTerm g m t = do
|
||||
mo <- lookupErr m (modules g)
|
||||
let status = (modules g,(m,mo)) --- <- buildStatus g m mo
|
||||
renameTerm status [] t
|
||||
|
||||
-- this is used in the compiler, separately for each module
|
||||
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
|
||||
renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
|
||||
ModMod m@(Module mt st fs me ops js) -> do
|
||||
let js1 = jments m
|
||||
let status = (ms, (name, mod))
|
||||
js2 <- mapMTree (renameInfo status) js1
|
||||
let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
|
||||
return $ (name,mod2) : ms
|
||||
|
||||
type Status = ([SourceModule],SourceModule) --- (StatusTree, [(OpenSpec Ident, StatusTree)])
|
||||
|
||||
--- type StatusTree = BinTree (Ident,StatusInfo)
|
||||
|
||||
--- type StatusInfo = Ident -> Term
|
||||
|
||||
lookupStatusInfo :: Ident -> SourceModule -> Err Term
|
||||
lookupStatusInfo c (q,ModMod m) = do
|
||||
i <- lookupTree prt c $ jments m
|
||||
return $ case i of
|
||||
AbsFun _ (Yes EData) -> QC q c
|
||||
ResValue _ -> QC q c
|
||||
ResParam _ -> QC q c
|
||||
AnyInd True n -> QC n c --- should go further?
|
||||
AnyInd False n -> Q n c
|
||||
_ -> Q q c
|
||||
lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q
|
||||
|
||||
lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term
|
||||
lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of
|
||||
Ok v -> return v
|
||||
_ -> lookupStatusInfoMany ms c
|
||||
lookupStatusInfoMany [] x =
|
||||
prtBad "renaming failed to find unqualified constant" x
|
||||
---- should also give error if stg is found in more than one module
|
||||
|
||||
renameIdentTerm :: Status -> Term -> Err Term
|
||||
renameIdentTerm env@(imps,act@(_,ModMod this)) t =
|
||||
errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
|
||||
case t of
|
||||
Vr c -> do
|
||||
f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c
|
||||
return $ f
|
||||
Cn c -> do
|
||||
f <- lookupStatusInfoMany openeds c
|
||||
return $ f
|
||||
Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
|
||||
Q m' c -> do
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupStatusInfo c m
|
||||
return $ f
|
||||
QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
|
||||
QC m' c -> do
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupStatusInfo c m
|
||||
return $ f
|
||||
_ -> return t
|
||||
where
|
||||
openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
|
||||
qualifs =
|
||||
[(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]]
|
||||
++
|
||||
[(m, (m,st)) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
|
||||
-- qualif is always possible
|
||||
|
||||
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
|
||||
predefAbs c s = case c of
|
||||
IC "Int" -> return $ Q cPredefAbs cInt
|
||||
IC "String" -> return $ Q cPredefAbs cString
|
||||
_ -> Bad s
|
||||
|
||||
--- would it make sense to optimize this by inlining?
|
||||
renameIdentPatt :: Status -> Patt -> Err Patt
|
||||
renameIdentPatt env p = do
|
||||
let t = patt2term p
|
||||
t' <- renameIdentTerm env t
|
||||
term2patt t'
|
||||
|
||||
{- deprec !
|
||||
info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
|
||||
info2status mq (c,i) = (c, case i of
|
||||
AbsFun _ (Yes EData) -> maybe Con QC mq
|
||||
ResValue _ -> maybe Con QC mq
|
||||
ResParam _ -> maybe Con QC mq
|
||||
AnyInd True m -> maybe Con (const (QC m)) mq
|
||||
AnyInd False m -> maybe Cn (const (Q m)) mq
|
||||
_ -> maybe Cn Q mq
|
||||
)
|
||||
|
||||
tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
|
||||
tree2status o = case o of
|
||||
OSimple _ i -> mapTree (info2status (Just i))
|
||||
OQualif _ i j -> mapTree (info2status (Just j))
|
||||
|
||||
buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
|
||||
buildStatus gr c mo = let mo' = self2status c mo in case mo of
|
||||
ModMod m -> do
|
||||
let gr1 = MGrammar $ (c,mo) : modules gr
|
||||
ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m
|
||||
mods <- mapM (lookupModule gr1 . openedModule) ops
|
||||
let sts = map modInfo2status $ zip ops mods
|
||||
return $ if isModCnc m
|
||||
then (NT, reverse sts) -- the module itself does not define any names
|
||||
else (mo',reverse sts) -- so the empty ident is not needed
|
||||
|
||||
modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
|
||||
modInfo2status (o,i) = (o,case i of
|
||||
ModMod m -> tree2status o (jments m)
|
||||
)
|
||||
|
||||
self2status :: Ident -> SourceModInfo -> StatusTree
|
||||
self2status c i = mapTree (info2status (Just c)) js where -- qualify internal
|
||||
js = case i of
|
||||
ModMod m
|
||||
| isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m
|
||||
| otherwise -> jments m
|
||||
noTrans (_,d) = case d of -- to enable other than transfer js in transfer module
|
||||
AbsTrans _ -> False
|
||||
_ -> True
|
||||
-}
|
||||
|
||||
forceQualif o = case o of
|
||||
OSimple q i -> OQualif q i i
|
||||
OQualif q _ i -> OQualif q i i
|
||||
|
||||
renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
|
||||
renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $
|
||||
liftM ((,) i) $ case info of
|
||||
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
|
||||
(renPerh (mapM rent) pfs)
|
||||
AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
|
||||
AbsTrans f -> liftM AbsTrans (rent f)
|
||||
|
||||
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
|
||||
ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
|
||||
ResValue t -> liftM ResValue (ren t)
|
||||
CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
|
||||
CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr)
|
||||
_ -> return info
|
||||
where
|
||||
ren = renPerh rent
|
||||
rent = renameTerm status []
|
||||
|
||||
renPerh ren pt = case pt of
|
||||
Yes t -> liftM Yes $ ren t
|
||||
_ -> return pt
|
||||
|
||||
renameTerm :: Status -> [Ident] -> Term -> Err Term
|
||||
renameTerm env vars = ren vars where
|
||||
ren vs trm = case trm of
|
||||
Abs x b -> liftM (Abs x) (ren (x:vs) b)
|
||||
Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
|
||||
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
|
||||
Vr x
|
||||
| elem x vs -> return trm
|
||||
| otherwise -> renid trm
|
||||
Cn _ -> renid trm
|
||||
Con _ -> renid trm
|
||||
Q _ _ -> renid trm
|
||||
QC _ _ -> renid trm
|
||||
Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
|
||||
T i cs -> do
|
||||
i' <- case i of
|
||||
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
|
||||
_ -> return i
|
||||
liftM (T i') $ mapM (renCase vs) cs
|
||||
|
||||
Let (x,(m,a)) b -> do
|
||||
m' <- case m of
|
||||
Just ty -> liftM Just $ ren vs ty
|
||||
_ -> return m
|
||||
a' <- ren vs a
|
||||
b' <- ren (x:vs) b
|
||||
return $ Let (x,(m',a')) b'
|
||||
|
||||
P t@(Vr r) l -- for constant t we know it is projection
|
||||
| elem r vs -> return trm -- var proj first
|
||||
| otherwise -> case renid (Q r (label2ident l)) of -- qualif second
|
||||
Ok t -> return t
|
||||
_ -> liftM (flip P l) $ renid t -- const proj last
|
||||
|
||||
_ -> composOp (ren vs) trm
|
||||
|
||||
renid = renameIdentTerm env
|
||||
renCase vs (p,t) = do
|
||||
(p',vs') <- renpatt p
|
||||
t' <- ren (vs' ++ vs) t
|
||||
return (p',t')
|
||||
renpatt = renamePattern env
|
||||
|
||||
-- vars not needed in env, since patterns always overshadow old vars
|
||||
|
||||
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
|
||||
renamePattern env patt = case patt of
|
||||
|
||||
PC c ps -> do
|
||||
c' <- renameIdentTerm env $ Cn c
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs) = unzip psvss
|
||||
case c' of
|
||||
QC p d -> return (PP p d ps', concat vs)
|
||||
Q p d -> return (PP p d ps', concat vs) ---- should not happen
|
||||
_ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
|
||||
|
||||
---- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps
|
||||
|
||||
PV x -> case renid patt of
|
||||
Ok p -> return (p,[])
|
||||
_ -> return (patt, [x])
|
||||
|
||||
PR r -> do
|
||||
let (ls,ps) = unzip r
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs') = unzip psvss
|
||||
return (PR (zip ls ps'), concat vs')
|
||||
|
||||
_ -> return (patt,[])
|
||||
|
||||
where
|
||||
renp = renamePattern env
|
||||
renid = renameIdentPatt env
|
||||
|
||||
renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
|
||||
renameParam env (c,co) = do
|
||||
co' <- renameContext env co
|
||||
return (c,co')
|
||||
|
||||
renameContext :: Status -> Context -> Err Context
|
||||
renameContext b = renc [] where
|
||||
renc vs cont = case cont of
|
||||
(x,t) : xts
|
||||
| isWildIdent x -> do
|
||||
t' <- ren vs t
|
||||
xts' <- renc vs xts
|
||||
return $ (x,t') : xts'
|
||||
| otherwise -> do
|
||||
t' <- ren vs t
|
||||
let vs' = x:vs
|
||||
xts' <- renc vs' xts
|
||||
return $ (x,t') : xts'
|
||||
_ -> return cont
|
||||
ren = renameTerm b
|
||||
|
||||
-- vars not needed in env, since patterns always overshadow old vars
|
||||
|
||||
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
|
||||
renameEquation b vs (ps,t) = do
|
||||
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
|
||||
t' <- renameTerm b (concat vs' ++ vs) t
|
||||
return (ps',t')
|
||||
Reference in New Issue
Block a user