forked from GitHub/gf-core
327 lines
11 KiB
Haskell
327 lines
11 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Rename
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/05/30 18:39:44 $
|
|
-- > CVS $Author: aarne $
|
|
-- > CVS $Revision: 1.19 $
|
|
--
|
|
-- 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".
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Compile.Rename (
|
|
renameSourceTerm,
|
|
renameSourceJudgement,
|
|
renameModule
|
|
) where
|
|
|
|
import GF.Grammar.Grammar
|
|
import GF.Grammar.Values
|
|
import GF.Grammar.Predef
|
|
import GF.Infra.Ident
|
|
import GF.Infra.CheckM
|
|
import GF.Grammar.Macros
|
|
import GF.Grammar.Printer
|
|
import GF.Grammar.Lookup
|
|
import GF.Grammar.Printer
|
|
import GF.Data.Operations
|
|
|
|
import Control.Monad
|
|
import Data.List (nub)
|
|
import Text.PrettyPrint
|
|
|
|
-- | this gives top-level access to renaming term input in the cc command
|
|
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
|
|
renameSourceTerm g m t = do
|
|
mi <- checkErr $ lookupModule g m
|
|
status <- buildStatus g m mi
|
|
renameTerm status [] t
|
|
|
|
-- | this gives top-level access to renaming term input in the cj command
|
|
renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
|
|
renameSourceJudgement g m (i,t) = do
|
|
mi <- checkErr $ lookupModule g m
|
|
status <- buildStatus g m mi
|
|
t2 <- renameInfo status (m,mi) i t
|
|
return (i,t2)
|
|
|
|
renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
|
|
renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do
|
|
status <- buildStatus (mGrammar ms) m mi
|
|
js <- checkMap (renameInfo status mo) (jments mi)
|
|
return (m, mi{mopens = map forceQualif (mopens mi), jments = js})
|
|
|
|
type Status = (StatusTree, [(OpenSpec, StatusTree)])
|
|
|
|
type StatusTree = BinTree Ident StatusInfo
|
|
|
|
type StatusInfo = Ident -> Term
|
|
|
|
renameIdentTerm :: Status -> Term -> Check Term
|
|
renameIdentTerm env@(act,imps) t =
|
|
checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $
|
|
case t of
|
|
Vr c -> ident predefAbs c
|
|
Cn c -> ident (\_ s -> checkError s) c
|
|
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
|
|
Q (m',c) -> do
|
|
m <- checkErr (lookupErr m' qualifs)
|
|
f <- lookupTree showIdent c m
|
|
return $ f c
|
|
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
|
|
QC (m',c) -> do
|
|
m <- checkErr (lookupErr m' qualifs)
|
|
f <- lookupTree showIdent c m
|
|
return $ f c
|
|
_ -> return t
|
|
where
|
|
opens = [st | (OSimple _,st) <- imps]
|
|
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
|
|
[(m, st) | (OQualif _ m, st) <- imps] ++
|
|
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
|
|
|
|
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
|
|
predefAbs c s
|
|
| isPredefCat c = return $ Q (cPredefAbs,c)
|
|
| otherwise = checkError s
|
|
|
|
ident alt c = case lookupTree showIdent c act of
|
|
Ok f -> return $ f c
|
|
_ -> case lookupTreeManyAll showIdent opens c of
|
|
[f] -> return $ f c
|
|
[] -> alt c (text "constant not found:" <+> ppIdent c)
|
|
fs -> case nub [f c | f <- fs] of
|
|
[tr] -> return tr
|
|
ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))
|
|
return t
|
|
-- a warning will be generated in CheckGrammar, and the head returned
|
|
-- in next V:
|
|
-- Bad $ "conflicting imports:" +++ unwords (map prt ts)
|
|
|
|
info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
|
|
info2status mq (c,i) = case i of
|
|
AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
|
|
ResValue _ -> maybe Con (curry QC) mq
|
|
ResParam _ _ -> maybe Con (curry QC) mq
|
|
AnyInd True m -> maybe Con (const (curry QC m)) mq
|
|
AnyInd False m -> maybe Cn (const (curry Q m)) mq
|
|
_ -> maybe Cn (curry Q) mq
|
|
|
|
tree2status :: OpenSpec -> 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 -> Check Status
|
|
buildStatus gr c mo = let mo' = self2status c mo in do
|
|
let gr1 = prependModule gr (c,mo)
|
|
ops = [OSimple e | e <- allExtends gr1 c] ++ mopens mo
|
|
mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
|
|
let sts = map modInfo2status $ zip ops mods
|
|
return $ if isModCnc mo
|
|
then (emptyBinTree, reverse sts) -- the module itself does not define any names
|
|
else (mo',reverse sts) -- so the empty ident is not needed
|
|
|
|
modInfo2status :: (OpenSpec,SourceModInfo) -> (OpenSpec, StatusTree)
|
|
modInfo2status (o,mo) = (o,tree2status o (jments mo))
|
|
|
|
self2status :: Ident -> SourceModInfo -> StatusTree
|
|
self2status c m = mapTree (info2status (Just c)) (jments m)
|
|
|
|
forceQualif o = case o of
|
|
OSimple i -> OQualif i i
|
|
OQualif _ i -> OQualif i i
|
|
|
|
renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
|
|
renameInfo status (m,mi) i info =
|
|
case info of
|
|
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
|
|
AbsFun pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
|
|
ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
|
|
ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
|
|
ResParam (Just pp) m -> do
|
|
pp' <- renLoc (mapM (renParam status)) pp
|
|
return (ResParam (Just pp') m)
|
|
ResValue t -> do
|
|
t <- renLoc (renameTerm status []) t
|
|
return (ResValue t)
|
|
CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
|
|
CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
|
|
_ -> return info
|
|
where
|
|
renTerm = renPerh (renameTerm status [])
|
|
|
|
renPerh ren = renMaybe (renLoc ren)
|
|
|
|
renMaybe ren (Just x) = ren x >>= return . Just
|
|
renMaybe ren Nothing = return Nothing
|
|
|
|
renLoc ren (L loc x) =
|
|
checkIn (ppLocation (msrc mi) loc <> colon $$ text "Happened in the renaming of" <+> ppIdent i) $ do
|
|
x <- ren x
|
|
return (L loc x)
|
|
|
|
renPair ren (L locx x, L locy y) = do x <- ren x
|
|
y <- ren y
|
|
return (L locx x, L locy y)
|
|
|
|
renEquation :: Status -> Equation -> Check Equation
|
|
renEquation b (ps,t) = do
|
|
(ps',vs) <- liftM unzip $ mapM (renamePattern b) ps
|
|
t' <- renameTerm b (concat vs) t
|
|
return (ps',t')
|
|
|
|
renParam :: Status -> Param -> Check Param
|
|
renParam env (c,co) = do
|
|
co' <- renameContext env co
|
|
return (c,co')
|
|
|
|
renameTerm :: Status -> [Ident] -> Term -> Check Term
|
|
renameTerm env vars = ren vars where
|
|
ren vs trm = case trm of
|
|
Abs b x t -> liftM (Abs b x) (ren (x:vs) t)
|
|
Prod bt x a b -> liftM2 (Prod bt 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
|
|
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 -- Here we have $r.l$ and this is ambiguous it could be either
|
|
-- record projection from variable or constant $r$ or qualified expression with module $r$
|
|
| elem r vs -> return trm -- try var proj first ..
|
|
| otherwise -> checks [ renid (Q (r,label2ident l)) -- .. and qualified expression second.
|
|
, renid t >>= \t -> return (P t l) -- try as a constant at the end
|
|
, checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 trm)
|
|
]
|
|
|
|
EPatt p -> do
|
|
(p',_) <- renpatt p
|
|
return $ EPatt p'
|
|
|
|
_ -> 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 -> Check (Patt,[Ident])
|
|
renamePattern env patt = case patt of
|
|
|
|
PMacro c -> do
|
|
c' <- renid $ Vr c
|
|
case c' of
|
|
Q d -> renp $ PM d
|
|
_ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
|
|
|
|
PC c ps -> do
|
|
c' <- renid $ Cn c
|
|
case c' of
|
|
QC c -> do psvss <- mapM renp ps
|
|
let (ps,vs) = unzip psvss
|
|
return (PP c ps, concat vs)
|
|
Q _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
|
|
_ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
|
|
|
|
PP c ps -> do
|
|
(QC c') <- renid (QC c)
|
|
psvss <- mapM renp ps
|
|
let (ps',vs) = unzip psvss
|
|
return (PP c' ps', concat vs)
|
|
|
|
PM c -> do
|
|
x <- renid (Q c)
|
|
c' <- case x of
|
|
(Q c') -> return c'
|
|
_ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
|
|
return (PM c', [])
|
|
|
|
PV x -> checks [ renid (Vr x) >>= \t' -> case t' of
|
|
QC c -> return (PP c [],[])
|
|
_ -> checkError (text "not a constructor")
|
|
, 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')
|
|
|
|
PAlt p q -> do
|
|
(p',vs) <- renp p
|
|
(q',ws) <- renp q
|
|
return (PAlt p' q', vs ++ ws)
|
|
|
|
PSeq p q -> do
|
|
(p',vs) <- renp p
|
|
(q',ws) <- renp q
|
|
return (PSeq p' q', vs ++ ws)
|
|
|
|
PRep p -> do
|
|
(p',vs) <- renp p
|
|
return (PRep p', vs)
|
|
|
|
PNeg p -> do
|
|
(p',vs) <- renp p
|
|
return (PNeg p', vs)
|
|
|
|
PAs x p -> do
|
|
(p',vs) <- renp p
|
|
return (PAs x p', x:vs)
|
|
|
|
_ -> return (patt,[])
|
|
|
|
where
|
|
renp = renamePattern env
|
|
renid = renameIdentTerm env
|
|
|
|
renameContext :: Status -> Context -> Check Context
|
|
renameContext b = renc [] where
|
|
renc vs cont = case cont of
|
|
(bt,x,t) : xts
|
|
| isWildIdent x -> do
|
|
t' <- ren vs t
|
|
xts' <- renc vs xts
|
|
return $ (bt,x,t') : xts'
|
|
| otherwise -> do
|
|
t' <- ren vs t
|
|
let vs' = x:vs
|
|
xts' <- renc vs' xts
|
|
return $ (bt,x,t') : xts'
|
|
_ -> return cont
|
|
ren = renameTerm b
|