forked from GitHub/gf-core
refactor GF.Infra.CheckM and use the CheckM monad in the renamer as well
This commit is contained in:
krasimir
+51
-59
@@ -22,7 +22,7 @@
|
||||
-- Hence we can proceed by @fold@ing "from left to right".
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.Rename (renameGrammar,
|
||||
module GF.Compile.Rename (
|
||||
renameSourceTerm,
|
||||
renameModule
|
||||
) where
|
||||
@@ -32,6 +32,7 @@ import GF.Grammar.Values
|
||||
import GF.Grammar.Predef
|
||||
import GF.Infra.Modules
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.CheckM
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Printer
|
||||
import GF.Grammar.AppPredefined
|
||||
@@ -41,25 +42,21 @@ import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (nub)
|
||||
import Debug.Trace (trace)
|
||||
import Text.PrettyPrint
|
||||
|
||||
renameGrammar :: SourceGrammar -> Err SourceGrammar
|
||||
renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
|
||||
|
||||
-- | this gives top-level access to renaming term input in the cc command
|
||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
|
||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
|
||||
renameSourceTerm g m t = do
|
||||
mo <- lookupModule g m
|
||||
mo <- checkErr $ lookupModule g m
|
||||
status <- buildStatus g m mo
|
||||
renameTerm status [] t
|
||||
|
||||
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
|
||||
renameModule ms (name,mo) = errIn ("renaming module" +++ showIdent name) $ do
|
||||
renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
|
||||
renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do
|
||||
let js1 = jments mo
|
||||
status <- buildStatus (MGrammar ms) name mo
|
||||
js2 <- mapsErrTree (renameInfo mo status) js1
|
||||
return $ (name, mo {opens = map forceQualif (opens mo), jments = js2}) : ms
|
||||
js2 <- checkMap (renameInfo mo status) js1
|
||||
return (name, mo {opens = map forceQualif (opens mo), jments = js2})
|
||||
|
||||
type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
|
||||
|
||||
@@ -67,20 +64,20 @@ type StatusTree = BinTree Ident StatusInfo
|
||||
|
||||
type StatusInfo = Ident -> Term
|
||||
|
||||
renameIdentTerm :: Status -> Term -> Err Term
|
||||
renameIdentTerm :: Status -> Term -> Check Term
|
||||
renameIdentTerm env@(act,imps) t =
|
||||
errIn (render (text "atomic term" <+> ppTerm Unqualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs)))) $
|
||||
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 -> Bad s) c
|
||||
Cn c -> ident (\_ s -> checkError s) c
|
||||
Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
|
||||
Q m' c -> do
|
||||
m <- lookupErr m' qualifs
|
||||
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 <- lookupErr m' qualifs
|
||||
m <- checkErr (lookupErr m' qualifs)
|
||||
f <- lookupTree showIdent c m
|
||||
return $ f c
|
||||
_ -> return t
|
||||
@@ -92,28 +89,21 @@ renameIdentTerm env@(act,imps) t =
|
||||
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
|
||||
predefAbs c s
|
||||
| isPredefCat c = return $ Q cPredefAbs c
|
||||
| otherwise = Bad s
|
||||
| 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 (render (text "constant not found:" <+> ppIdent c))
|
||||
[] -> alt c (text "constant not found:" <+> ppIdent c)
|
||||
fs -> case nub [f c | f <- fs] of
|
||||
[tr] -> return tr
|
||||
ts@(t:_) -> trace (render (text "Warning: conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))) (return t)
|
||||
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)
|
||||
|
||||
|
||||
--- | 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'
|
||||
|
||||
info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
|
||||
info2status mq (c,i) = case i of
|
||||
AbsFun _ _ Nothing -> maybe Con QC mq
|
||||
@@ -128,11 +118,11 @@ 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 :: SourceGrammar -> Ident -> SourceModInfo -> Check Status
|
||||
buildStatus gr c mo = let mo' = self2status c mo in do
|
||||
let gr1 = MGrammar ((c,mo) : modules gr)
|
||||
ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo
|
||||
mods <- mapM (lookupModule gr1 . openedModule) ops
|
||||
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
|
||||
@@ -148,10 +138,10 @@ forceQualif o = case o of
|
||||
OSimple i -> OQualif i i
|
||||
OQualif _ i -> OQualif i i
|
||||
|
||||
renameInfo :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info)
|
||||
renameInfo mo status (i,info) = errIn
|
||||
(render (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i)) $
|
||||
liftM ((,) i) $ case info of
|
||||
renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info
|
||||
renameInfo mo status i info = checkIn
|
||||
(text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $
|
||||
case info of
|
||||
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
|
||||
(renPerh (mapM rent) pfs)
|
||||
AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr)
|
||||
@@ -175,7 +165,7 @@ renameInfo mo status (i,info) = errIn
|
||||
renPerh ren (Just t) = liftM Just $ ren t
|
||||
renPerh ren Nothing = return Nothing
|
||||
|
||||
renameTerm :: Status -> [Ident] -> Term -> Err Term
|
||||
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)
|
||||
@@ -202,13 +192,13 @@ renameTerm env vars = ren vars where
|
||||
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
|
||||
_ -> case liftM (flip P l) $ renid t of
|
||||
Ok t -> return t -- const proj last
|
||||
_ -> Bad (render (text "unknown qualified constant" <+> ppTerm Qualified 0 trm))
|
||||
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
|
||||
@@ -224,40 +214,42 @@ renameTerm env vars = ren vars where
|
||||
renpatt = renamePattern env
|
||||
|
||||
-- | vars not needed in env, since patterns always overshadow old vars
|
||||
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
|
||||
renamePattern :: Status -> Patt -> Check (Patt,[Ident])
|
||||
renamePattern env patt = case patt of
|
||||
|
||||
PMacro c -> do
|
||||
c' <- renid $ Vr c
|
||||
case c' of
|
||||
Q p d -> renp $ PM p d
|
||||
_ -> Bad (render (text "unresolved pattern" <+> ppPatt Unqualified 0 patt))
|
||||
_ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
|
||||
|
||||
PC c ps -> do
|
||||
c' <- renid $ Cn c
|
||||
case c' of
|
||||
QC m c -> renp $ PP m c ps
|
||||
Q _ _ -> Bad $ render (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
|
||||
_ -> Bad $ render (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
|
||||
QC m c -> do psvss <- mapM renp ps
|
||||
let (ps,vs) = unzip psvss
|
||||
return (PP m 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 p c ps -> do
|
||||
|
||||
(p', c') <- case renid (QC p c) of
|
||||
Ok (QC p' c') -> return (p',c')
|
||||
_ -> return (p,c) --- temporarily, for bw compat
|
||||
(QC p' c') <- renid (QC p c)
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs) = unzip psvss
|
||||
return (PP p' c' ps', concat vs)
|
||||
|
||||
PM p c -> do
|
||||
(p', c') <- case renid (Q p c) of
|
||||
Ok (Q p' c') -> return (p',c')
|
||||
_ -> Bad (render (text "not a pattern macro" <+> ppPatt Unqualified 0 patt))
|
||||
x <- renid (Q p c)
|
||||
(p',c') <- case x of
|
||||
(Q p' c') -> return (p',c')
|
||||
_ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
|
||||
return (PM p' c', [])
|
||||
|
||||
PV x -> do case renid (Vr x) of
|
||||
Ok (QC m c) -> return (PP m c [],[])
|
||||
_ -> return (patt, [x])
|
||||
PV x -> checks [ renid (Vr x) >>= \t' -> case t' of
|
||||
QC m c -> return (PP m c [],[])
|
||||
_ -> checkError (text "not a constructor")
|
||||
, return (patt, [x])
|
||||
]
|
||||
|
||||
PR r -> do
|
||||
let (ls,ps) = unzip r
|
||||
@@ -293,12 +285,12 @@ renamePattern env patt = case patt of
|
||||
renp = renamePattern env
|
||||
renid = renameIdentTerm env
|
||||
|
||||
renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
|
||||
renameParam :: Status -> (Ident, Context) -> Check (Ident, Context)
|
||||
renameParam env (c,co) = do
|
||||
co' <- renameContext env co
|
||||
return (c,co')
|
||||
|
||||
renameContext :: Status -> Context -> Err Context
|
||||
renameContext :: Status -> Context -> Check Context
|
||||
renameContext b = renc [] where
|
||||
renc vs cont = case cont of
|
||||
(bt,x,t) : xts
|
||||
@@ -315,7 +307,7 @@ renameContext b = renc [] where
|
||||
ren = renameTerm b
|
||||
|
||||
-- | vars not needed in env, since patterns always overshadow old vars
|
||||
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
|
||||
renameEquation :: Status -> [Ident] -> Equation -> Check Equation
|
||||
renameEquation b vs (ps,t) = do
|
||||
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
|
||||
t' <- renameTerm b (concat vs' ++ vs) t
|
||||
|
||||
Reference in New Issue
Block a user