GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-05 17:22:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

Use GF.Grammar.Printer everywhere instead of PrGrammar

Browse Source
This commit is contained in:
krasimir
2009-09-14 15:13:11 +00:00
parent 4426120eff
commit 9f3534b3bb
19 changed files with 189 additions and 169 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
src/GF/Compile/AbsCompute.hs
View File

@@ -30,6 +30,7 @@ import GF.Compile.Compute
import Debug.Trace
import Data.List(intersperse)
import Control.Monad (liftM, liftM2)
import Text.PrettyPrint
-- for debugging
tracd m t = t
@@ -45,7 +46,7 @@ computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
compt vv t = case t of
-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
-- Abs x b -> liftM (Abs x) (compt (x:vv) b)
@@ -55,21 +56,21 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
let vv' = yy ++ vv
aa' <- mapM (compt vv') aa
case look f of
Just eqs -> tracd ("\nmatching" +++ prt f) $
Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $
case findMatch eqs aa' of
Ok (d,g) -> do
--- let (xs,ts) = unzip g
--- ts' <- alphaFreshAll vv' ts
let g' = g --- zip xs ts'
d' <- compt vv' $ substTerm vv' g' d
tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d'
_ -> tracd ("no match" +++ prt t') $
tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
_ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $
do
let v = mkApp f aa'
return $ mkAbs yy $ v
_ -> do
let t2 = mkAbs yy $ mkApp f aa'
tracd ("not defined" +++ prt_ t2) $ return t2
tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2
look t = case t of
(Q m f) -> case lookd m f of
@@ -93,12 +94,12 @@ beta vv c = case c of
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
[] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms)))
(patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
Bad (render (text "wrong number of args for patterns :" <+>
hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs)
Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
@@ -127,7 +128,7 @@ tryMatch (p,t) = do
(PAs x p',_) -> do
subst <- trym p' t'
return $ (x,t) : subst
_ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t)
_ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t))
notMeta e = case e of
Meta _ -> False
@@ -136,4 +137,4 @@ tryMatch (p,t) = do
_ -> True
prtm p g =
prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g]
ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g])

2
src/GF/Compile/CheckGrammar.hs
View File

@@ -129,7 +129,7 @@ checkAbsInfo st m mo c info = do
where
mkCheck cat ss = case ss of
[] -> return info
_ -> checkError (vcat (map text ss) $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c)
_ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c)
compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g

30
src/GF/Compile/Compute.hs
View File

@@ -18,9 +18,9 @@ import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Data.Str
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Data.Str
import GF.Grammar.Printer
import GF.Grammar.Predef
import GF.Grammar.Macros
import GF.Grammar.Lookup
@@ -32,8 +32,7 @@ import GF.Grammar.AppPredefined
import Data.List (nub,intersperse)
import Control.Monad (liftM2, liftM)
---- import Debug.Trace ----
import Text.PrettyPrint
-- | computation of concrete syntax terms into normal form
-- used mainly for partial evaluation
@@ -57,7 +56,7 @@ computeTermOpt rec gr = comput True where
| otherwise -> look p c
Vr x -> do
t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g
t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) return $ lookup x g
case t' of
_ | t == t' -> return t
_ -> comp g t'
@@ -113,7 +112,7 @@ computeTermOpt rec gr = comput True where
t' <- comp g t
case t' of
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
R r -> maybe (prtBad "no value for label" l) (comp g . snd) $
R r -> maybe (Bad (render (text "no value for label" <+> ppLabel l))) (comp g . snd) $
lookup l $ reverse r
ExtR a (R b) ->
@@ -275,7 +274,7 @@ computeTermOpt rec gr = comput True where
compPatternMacro p = case p of
PM m c -> case look m c of
Ok (EPatt p') -> compPatternMacro p'
_ -> prtBad "pattern expected as value of" p ---- should be in CheckGr
_ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p)))
PAs x p -> do
p' <- compPatternMacro p
return $ PAs x p'
@@ -325,7 +324,7 @@ computeTermOpt rec gr = comput True where
_ -> v'
case matchPattern cc v2 of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v2 -> prtBad ("missing case" +++ prt v2 +++ "in") t
_ | isCan v2 -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v2 <+> text "in" <+> ppTerm Unqualified 0 t))
_ -> return $ S t' v' -- if v' is not canonical
S (T i cs) e -> prawitz g i (flip S v') cs e
@@ -422,7 +421,7 @@ computeTermOpt rec gr = comput True where
as <- getPatts a
bs <- getPatts b
return [K (s ++ t) | K s <- as, K t <- bs]
_ -> fail $ "not valid pattern in pre expression" +++ prt p
_ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
{- ----
uncurrySelect g fs t v = do
@@ -450,18 +449,15 @@ computeTermOpt rec gr = comput True where
-- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term
checkNoArgVars t = case t of
Vr (IA _ _) -> Bad $ glueErrorMsg $ prt t
Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ prt t
Vr (IA _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t
Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t
_ -> composOp checkNoArgVars t
glueErrorMsg s =
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
"Use Prelude.bind instead."
render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$
text "Use Prelude.bind instead.")
getArgType t = case t of
V ty _ -> return ty
T (TComp ty) _ -> return ty
_ -> prtBad "cannot get argument type of table" t
_ -> Bad (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t)))

50
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -11,7 +11,7 @@ import qualified PGF.Macros as CM
import qualified PGF.Data as C
import qualified PGF.Data as D
import GF.Grammar.Predef
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import GF.Grammar.Grammar
import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar.Abstract as A
@@ -28,6 +28,7 @@ import Data.List
import Data.Char (isDigit,isSpace)
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
import Debug.Trace ----
-- when developing, swap commenting
@@ -60,7 +61,7 @@ addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toL
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
(if dump opts DumpCanon then trace (prGrammar cgr) else id) $
(if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $
D.PGF an cns gflags abs cncs
where
-- abstract
@@ -181,7 +182,7 @@ mkTerm tr = case tr of
Abs _ t -> mkTerm t ---- only on toplevel
Alts (td,tvs) ->
C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs])
_ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
_ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging
where
mkLab (LIdent l) = case BS.unpack l of
'_':ds -> (read ds) :: Int
@@ -218,7 +219,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
mkPType typ = case typ of
RecType lts -> do
ts <- mapM (mkPType . snd) lts
return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts]
return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts]
Table (RecType lts) v -> do
ps <- mapM (mkPType . snd) lts
v' <- mkPType v
@@ -229,7 +230,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
return $ C.S [p',v']
Sort s | s == cStr -> return $ C.S []
_ -> return $
C.FV $ map (kks . filter showable . prt_) $
C.FV $ map (kks . filter showable . render . ppTerm Qualified 0) $
errVal [] $ Look.allParamValues sgr typ
showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records
kks = C.K . C.KS
@@ -275,7 +276,7 @@ repartition abs cg =
[] -> [abs] -- to make pgf nonempty even when there are no concretes
cncs -> cncs,
let mo = errVal
(error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang
(error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang
]
-- translate tables and records to arrays, parameters and labels to indices
@@ -292,7 +293,7 @@ canon2canon opts abs cg0 =
c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo))
j2j cg (f,j) =
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ prt f) else id in
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
case j of
CncFun x (Just tr) z -> CncFun x (Just (debug (t2t tr))) z
CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t x)) y
@@ -313,23 +314,22 @@ canon2canon opts abs cg0 =
_ -> [(x,ty)]
----
trs v = traceD (tr v) v
trs v = traceD (render (tr v)) v
tr (labels,untyps,typs) =
("LABELS:" ++++
unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i |
((c,l),i) <- Map.toList labels]) ++++
("UNTYPS:" ++++ unlines [A.prt t +++ "=" +++ show i |
(t,i) <- Map.toList untyps]) ++++
("TYPS:" ++++ unlines [A.prt t +++ "=" +++ show (Map.assocs i) |
(t,i) <- Map.toList typs])
(text "LABELS:" <+>
vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$
(text "UNTYPS:" <+>
vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$
(text "TYPS: " <+>
vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs])
----
purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
purgeGrammar abstr gr =
(M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr
where
list ms = traceD ("MODULES" +++ unwords (map (prt . fst) ms)) ms
list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
acncs = abstr : M.allConcretes gr abstr
@@ -384,7 +384,7 @@ paramValues cgr = (labels,untyps,typs) where
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
_ -> GM.composOp typsFromTrm tr
mods = traceD (unwords (map (prt . fst) ms)) ms where ms = M.modules cgr
mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr
jments =
[(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo]
@@ -435,7 +435,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
P t l -> r2r tr
PI t l i -> EInt $ toInteger i
T (TWild _) _ -> error $ "wild" +++ prt tr
T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr))
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
@@ -468,8 +468,8 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
Just vs -> (ty,[t |
(t,_) <- sortBy (\x y -> compare (snd x) (snd y))
(Map.assocs vs)])
_ -> error $ "doVar1" +++ A.prt ty
_ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug
_ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty)
_ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug
updateSTM ((tyvs, (tr', tr)):)
return tr'
_ -> GM.composOp doVar tr
@@ -480,7 +480,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
Ok (cat,labs) -> P (t2t p) . mkLab $
maybe (prtTrace tr $ 66664) snd $
Map.lookup (cat,labs) labels
_ -> K ((A.prt tr +++ prtTrace tr "66665"))
_ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665)))
-- this goes recursively into tables (ignored) and records (accumulated)
getLab tr = case tr of
@@ -511,8 +511,8 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
(FV ts,_) -> ts
_ -> [tr]
valNumFV ts = case ts of
[tr] -> let msg = ("DEBUG" +++ prt fun ++ ": error in valNum" +++ prt tr) in
trace msg $ error (prt fun)
[tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in
trace msg $ error (showIdent fun)
_ -> FV $ map valNum ts
mkCurry trm = case trm of
@@ -553,8 +553,8 @@ unlockTy ty = case ty of
prtTrace tr n =
trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n
prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n
-- | this function finds out what modules are really needed in the canonical gr.

2
src/GF/Compile/ModDeps.hs
View File

@@ -23,7 +23,7 @@ module GF.Compile.ModDeps (mkSourceGrammar,
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import GF.Compile.Update
import GF.Grammar.Lookup
import GF.Infra.Modules

33
src/GF/Compile/Optimize.hs
View File

@@ -18,7 +18,7 @@ module GF.Compile.Optimize (optimizeModule) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Predef
@@ -35,15 +35,10 @@ import GF.Infra.Option
import Control.Monad
import Data.List
import qualified Data.Set as Set
import Text.PrettyPrint
import Debug.Trace
-- conditional trace
prtIf :: (Print a) => Bool -> a -> a
prtIf b t = if b then trace (" " ++ prt t) t else t
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
type EEnv = () --- not used
@@ -81,7 +76,7 @@ evalModule oopts (ms,eenv) mo@(name,m0)
gr = MGrammar $ mo : ms
evalOp g@(MGrammar ((_,m) : _)) i = do
info <- lookupTree prt i $ jments m
info <- lookupTree showIdent i $ jments m
info' <- evalResInfo oopts gr (i,info)
return $ updateRes g name i info'
@@ -97,7 +92,7 @@ updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
evalResInfo oopts gr (c,info) = case info of
ResOper pty pde -> eIn "operation" $ do
ResOper pty pde -> eIn (text "operation") $ do
pde' <- case pde of
Just de | optres -> liftM Just $ comp de
_ -> return pde
@@ -106,7 +101,7 @@ evalResInfo oopts gr (c,info) = case info of
_ -> return info
where
comp = if optres then computeConcrete gr else computeConcreteRec gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
optim = flag optOptimizations oopts
optres = OptExpand `Set.member` optim
@@ -115,9 +110,9 @@ evalCncInfo ::
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info
evalCncInfo opts gr cnc abs (c,info) = do
seq (prtIf (verbAtLeast opts Verbose) c) $ return ()
(if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
errIn ("optimizing" +++ prt c) $ case info of
errIn ("optimizing " ++ showIdent c) $ case info of
CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of
@@ -127,12 +122,12 @@ evalCncInfo opts gr cnc abs (c,info) = do
liftM Just $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
_ -> return pde -- indirection
ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ prt c)
ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c)
return (CncCat ptyp pde' ppr')
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd (cont,val,[])) $$ text "of function") $ do
pde' <- case pde of
Just de -> liftM Just $ pEval ty de
Nothing -> return pde
@@ -142,11 +137,11 @@ evalCncInfo opts gr cnc abs (c,info) = do
_ -> return info
where
pEval = partEval opts gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
-- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
partEval opts gr (context, val) trm = errIn (render (text "parteval" <+> ppTerm Qualified 0 trm)) $ do
let vars = map fst context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
@@ -199,7 +194,7 @@ mkLinDefault gr typ = do
ts' <- mapM mkDefField ts
return $ R $ [assign l t | (l,t) <- zip ls ts']
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> prtBad "linearization type field cannot be" typ
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
-- | Form the printname: if given, compute. If not, use the computed
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
@@ -210,8 +205,8 @@ evalPrintname gr c ppr lin =
case ppr of
Just pr -> comp pr
Nothing -> case lin of
Just t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
Nothing -> return $ K $ prt c ----
Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t))
Nothing -> return $ K $ showIdent c ----
where
comp = computeConcrete gr

3
src/GF/Compile/OptimizeGF.hs
View File

@@ -23,7 +23,6 @@ import GF.Grammar.Grammar
import GF.Grammar.Lookup
import GF.Infra.Ident
import qualified GF.Grammar.Macros as C
import GF.Grammar.PrGrammar (prt)
import qualified GF.Infra.Modules as M
import GF.Data.Operations
@@ -86,7 +85,7 @@ factor c i t = case t of
--- we hope this will be fresh and don't check... in GFC would be safe
qqIdent c i = identC (BS.pack ("q_" ++ prt c ++ "__" ++ show i))
qqIdent c i = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i))
-- we need to replace subterms

26
src/GF/Compile/Rename.hs
View File

@@ -33,7 +33,7 @@ import GF.Grammar.Predef
import GF.Infra.Modules
import GF.Infra.Ident
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import GF.Grammar.AppPredefined
import GF.Grammar.Lookup
import GF.Grammar.Printer
@@ -55,7 +55,7 @@ renameSourceTerm g m t = do
renameTerm status [] t
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
renameModule ms (name,mo) = errIn ("renaming module" +++ prt name) $ do
renameModule ms (name,mo) = errIn ("renaming module" +++ showIdent name) $ do
let js1 = jments mo
status <- buildStatus (MGrammar ms) name mo
js2 <- mapsErrTree (renameInfo mo status) js1
@@ -69,19 +69,19 @@ type StatusInfo = Ident -> Term
renameIdentTerm :: Status -> Term -> Err Term
renameIdentTerm env@(act,imps) t =
errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
errIn (render (text "atomic term" <+> ppTerm Unqualified 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
Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
Q m' c -> do
m <- lookupErr m' qualifs
f <- lookupTree prt c m
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
f <- lookupTree prt c m
f <- lookupTree showIdent c m
return $ f c
_ -> return t
where
@@ -94,14 +94,14 @@ renameIdentTerm env@(act,imps) t =
| isPredefCat c = return $ Q cPredefAbs c
| otherwise = Bad s
ident alt c = case lookupTree prt c act of
ident alt c = case lookupTree showIdent c act of
Ok f -> return $ f c
_ -> case lookupTreeManyAll prt opens c of
_ -> case lookupTreeManyAll showIdent opens c of
[f] -> return $ f c
[] -> alt c ("constant not found:" +++ prt c)
[] -> alt c (render (text "constant not found:" <+> ppIdent c))
fs -> case nub [f c | f <- fs] of
[tr] -> return tr
ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t)
ts@(t:_) -> trace (render (text "Warning: 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)
@@ -152,7 +152,7 @@ forceQualif o = case o of
renameInfo :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo mo status (i,info) = errIn
("renaming definition of" +++ prt i +++ showPosition mo i) $
(render (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i)) $
liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
@@ -210,7 +210,7 @@ renameTerm env vars = ren vars where
Ok t -> return t
_ -> case liftM (flip P l) $ renid t of
Ok t -> return t -- const proj last
_ -> prtBad "unknown qualified constant" trm
_ -> Bad (render (text "unknown qualified constant" <+> ppTerm Qualified 0 trm))
EPatt p -> do
(p',_) <- renpatt p
@@ -233,7 +233,7 @@ renamePattern env patt = case patt of
c' <- renid $ Vr c
case c' of
Q p d -> renp $ PM p d
_ -> prtBad "unresolved pattern" patt
_ -> Bad (render (text "unresolved pattern" <+> ppPatt Unqualified 0 patt))
PC c ps -> do
c' <- renid $ Cn c
@@ -254,7 +254,7 @@ renamePattern env patt = case patt of
PM p c -> do
(p', c') <- case renid (Q p c) of
Ok (Q p' c') -> return (p',c')
_ -> prtBad "not a pattern macro" patt
_ -> Bad (render (text "not a pattern macro" <+> ppPatt Unqualified 0 patt))
return (PM p' c', [])
PV x -> do case renid (Vr x) of

18
src/GF/Compile/TC.hs
View File

@@ -58,7 +58,7 @@ lookupConst :: Theory -> QIdent -> Err Val
lookupConst th f = th f
lookupVar :: Env -> Ident -> Err Val
lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g)
lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent x))) return $ lookup x ((IW,uVal):g)
-- wild card IW: no error produced, ?0 instead.
type TCEnv = (Int,Env,Env)
@@ -130,7 +130,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
(t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs)
_ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ
_ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))
Prod x a b -> do
testErr (typ == vType) "expected Type"
@@ -146,7 +146,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
r <- mapM (checkAssign th tenv ys) xs
let (xs,css) = unzip r
return (AR xs, concat css)
_ -> prtBad ("record type expected for" +++ prt e +++ "instead of") typ
_ -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ))
P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
return (AP r' l typ,cs)
@@ -181,8 +181,8 @@ inferExp th tenv@(k,rho,gamma) e = case e of
(a',csa) <- checkExp th tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
_ -> prtBad "cannot infer type of expression" e
_ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e))
checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
checkLabelling th tenv (lbl,typ) = do
@@ -224,7 +224,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
_ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ
_ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 typ))
[] -> do
(e,cs) <- checkExp th tenv t ty
return (([],e),cs)
@@ -242,7 +242,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
PFloat n -> (EFloat n : ps, i, g, k)
PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
_ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
_ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch")
upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
@@ -280,8 +280,8 @@ checkPatt th tenv exp val = do
(a',_,csa) <- checkExpP tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
_ -> prtBad "cannot typecheck pattern" exp
_ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
-- auxiliaries

12
src/GF/Compile/TypeCheck.hs
View File

@@ -21,6 +21,7 @@ module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should n
import GF.Data.Operations
import GF.Infra.CheckM
import GF.Grammar.Abstract
import GF.Grammar.Lookup
import GF.Grammar.Unify
@@ -29,6 +30,7 @@ import GF.Compile.Refresh
import GF.Compile.AbsCompute
import GF.Compile.TC
import Text.PrettyPrint
import Control.Monad (foldM, liftM, liftM2)
-- | invariant way of creating TCEnv from context
@@ -65,14 +67,14 @@ grammar2theory gr (m,f) = case lookupFunType gr m f of
Ok cont -> return $ cont2val cont
_ -> Bad s
checkContext :: Grammar -> Context -> [String]
checkContext :: Grammar -> Context -> [Message]
checkContext st = checkTyp st . cont2exp
checkTyp :: Grammar -> Type -> [String]
checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType
checkTyp :: Grammar -> Type -> [Message]
checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType
checkDef :: Grammar -> Fun -> Type -> [Equation] -> [String]
checkDef gr (m,fun) typ eqs = err singleton prConstrs $ do
checkDef :: Grammar -> Fun -> Type -> [Equation] -> [Message]
checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do
bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs
let (bs,css) = unzip bcs
(constrs,_) <- unifyVal (concat css)