GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32: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 Debug.Trace
import Data.List(intersperse) import Data.List(intersperse)
import Control.Monad (liftM, liftM2) import Control.Monad (liftM, liftM2)
import Text.PrettyPrint
-- for debugging -- for debugging
tracd m t = t tracd m t = t
@@ -45,7 +46,7 @@ computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp 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 compt vv t = case t of
-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) -- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
-- Abs x b -> liftM (Abs x) (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 let vv' = yy ++ vv
aa' <- mapM (compt vv') aa aa' <- mapM (compt vv') aa
case look f of case look f of
Just eqs -> tracd ("\nmatching" +++ prt f) $ Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $
case findMatch eqs aa' of case findMatch eqs aa' of
Ok (d,g) -> do Ok (d,g) -> do
--- let (xs,ts) = unzip g --- let (xs,ts) = unzip g
--- ts' <- alphaFreshAll vv' ts --- ts' <- alphaFreshAll vv' ts
let g' = g --- zip xs ts' let g' = g --- zip xs ts'
d' <- compt vv' $ substTerm vv' g' d d' <- compt vv' $ substTerm vv' g' d
tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d' tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
_ -> tracd ("no match" +++ prt t') $ _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $
do do
let v = mkApp f aa' let v = mkApp f aa'
return $ mkAbs yy $ v return $ mkAbs yy $ v
_ -> do _ -> do
let t2 = mkAbs yy $ mkApp f aa' 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 look t = case t of
(Q m f) -> case lookd m f 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 :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of 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 -> (patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++ Bad (render (text "wrong number of args for patterns :" <+>
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) 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 (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 _ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)] tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
@@ -127,7 +128,7 @@ tryMatch (p,t) = do
(PAs x p',_) -> do (PAs x p',_) -> do
subst <- trym p' t' subst <- trym p' t'
return $ (x,t) : subst 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 notMeta e = case e of
Meta _ -> False Meta _ -> False
@@ -136,4 +137,4 @@ tryMatch (p,t) = do
_ -> True _ -> True
prtm p g = 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 where
mkCheck cat ss = case ss of mkCheck cat ss = case ss of
[] -> return info [] -> 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 compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g 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.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Option import GF.Infra.Option
import GF.Data.Str
import GF.Grammar.PrGrammar
import GF.Infra.Modules import GF.Infra.Modules
import GF.Data.Str
import GF.Grammar.Printer
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.Lookup import GF.Grammar.Lookup
@@ -32,8 +32,7 @@ import GF.Grammar.AppPredefined
import Data.List (nub,intersperse) import Data.List (nub,intersperse)
import Control.Monad (liftM2, liftM) import Control.Monad (liftM2, liftM)
import Text.PrettyPrint
---- import Debug.Trace ----
-- | computation of concrete syntax terms into normal form -- | computation of concrete syntax terms into normal form
-- used mainly for partial evaluation -- used mainly for partial evaluation
@@ -57,7 +56,7 @@ computeTermOpt rec gr = comput True where
| otherwise -> look p c | otherwise -> look p c
Vr x -> do 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 case t' of
_ | t == t' -> return t _ | t == t' -> return t
_ -> comp g t' _ -> comp g t'
@@ -113,7 +112,7 @@ computeTermOpt rec gr = comput True where
t' <- comp g t t' <- comp g t
case t' of case t' of
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants 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 lookup l $ reverse r
ExtR a (R b) -> ExtR a (R b) ->
@@ -275,7 +274,7 @@ computeTermOpt rec gr = comput True where
compPatternMacro p = case p of compPatternMacro p = case p of
PM m c -> case look m c of PM m c -> case look m c of
Ok (EPatt p') -> compPatternMacro p' 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 PAs x p -> do
p' <- compPatternMacro p p' <- compPatternMacro p
return $ PAs x p' return $ PAs x p'
@@ -325,7 +324,7 @@ computeTermOpt rec gr = comput True where
_ -> v' _ -> v'
case matchPattern cc v2 of case matchPattern cc v2 of
Ok (c,g') -> comp (g' ++ g) c 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 _ -> return $ S t' v' -- if v' is not canonical
S (T i cs) e -> prawitz g i (flip S v') cs e 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 as <- getPatts a
bs <- getPatts b bs <- getPatts b
return [K (s ++ t) | K s <- as, K t <- bs] 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 uncurrySelect g fs t v = do
@@ -450,18 +449,15 @@ computeTermOpt rec gr = comput True where
-- | argument variables cannot be glued -- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term checkNoArgVars :: Term -> Err Term
checkNoArgVars t = case t of checkNoArgVars t = case t of
Vr (IA _ _) -> Bad $ glueErrorMsg $ prt t Vr (IA _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t
Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ prt t Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t
_ -> composOp checkNoArgVars t _ -> composOp checkNoArgVars t
glueErrorMsg s = glueErrorMsg s =
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$
"Use Prelude.bind instead." text "Use Prelude.bind instead.")
getArgType t = case t of getArgType t = case t of
V ty _ -> return ty V ty _ -> return ty
T (TComp 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 C
import qualified PGF.Data as D import qualified PGF.Data as D
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.PrGrammar import GF.Grammar.Printer
import GF.Grammar.Grammar import GF.Grammar.Grammar
import qualified GF.Grammar.Lookup as Look import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar.Abstract as A import qualified GF.Grammar.Abstract as A
@@ -28,6 +28,7 @@ import Data.List
import Data.Char (isDigit,isSpace) import Data.Char (isDigit,isSpace)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
import Debug.Trace ---- import Debug.Trace ----
-- when developing, swap commenting -- 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 :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = 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 D.PGF an cns gflags abs cncs
where where
-- abstract -- abstract
@@ -181,7 +182,7 @@ mkTerm tr = case tr of
Abs _ t -> mkTerm t ---- only on toplevel Abs _ t -> mkTerm t ---- only on toplevel
Alts (td,tvs) -> Alts (td,tvs) ->
C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- 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 where
mkLab (LIdent l) = case BS.unpack l of mkLab (LIdent l) = case BS.unpack l of
'_':ds -> (read ds) :: Int '_':ds -> (read ds) :: Int
@@ -218,7 +219,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
mkPType typ = case typ of mkPType typ = case typ of
RecType lts -> do RecType lts -> do
ts <- mapM (mkPType . snd) lts 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 Table (RecType lts) v -> do
ps <- mapM (mkPType . snd) lts ps <- mapM (mkPType . snd) lts
v' <- mkPType v v' <- mkPType v
@@ -229,7 +230,7 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
return $ C.S [p',v'] return $ C.S [p',v']
Sort s | s == cStr -> return $ C.S [] Sort s | s == cStr -> return $ C.S []
_ -> return $ _ -> return $
C.FV $ map (kks . filter showable . prt_) $ C.FV $ map (kks . filter showable . render . ppTerm Qualified 0) $
errVal [] $ Look.allParamValues sgr typ errVal [] $ Look.allParamValues sgr typ
showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records
kks = C.K . C.KS kks = C.K . C.KS
@@ -275,7 +276,7 @@ repartition abs cg =
[] -> [abs] -- to make pgf nonempty even when there are no concretes [] -> [abs] -- to make pgf nonempty even when there are no concretes
cncs -> cncs, cncs -> cncs,
let mo = errVal 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 -- 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)) c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo))
j2j cg (f,j) = 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 case j of
CncFun x (Just tr) z -> CncFun x (Just (debug (t2t tr))) z 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 CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t x)) y
@@ -313,23 +314,22 @@ canon2canon opts abs cg0 =
_ -> [(x,ty)] _ -> [(x,ty)]
---- ----
trs v = traceD (tr v) v trs v = traceD (render (tr v)) v
tr (labels,untyps,typs) = tr (labels,untyps,typs) =
("LABELS:" ++++ (text "LABELS:" <+>
unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$
((c,l),i) <- Map.toList labels]) ++++ (text "UNTYPS:" <+>
("UNTYPS:" ++++ unlines [A.prt t +++ "=" +++ show i | vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$
(t,i) <- Map.toList untyps]) ++++ (text "TYPS: " <+>
("TYPS:" ++++ unlines [A.prt t +++ "=" +++ show (Map.assocs i) | vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs])
(t,i) <- Map.toList typs])
---- ----
purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
purgeGrammar abstr gr = purgeGrammar abstr gr =
(M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr (M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr
where 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) purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
needed = nub $ concatMap (requiredCanModules isSingle gr) acncs needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
acncs = abstr : M.allConcretes gr abstr 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 updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
_ -> GM.composOp typsFromTrm 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 = jments =
[(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo] [(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 P t l -> r2r tr
PI t l i -> EInt $ toInteger i 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 (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 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] 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 | Just vs -> (ty,[t |
(t,_) <- sortBy (\x y -> compare (snd x) (snd y)) (t,_) <- sortBy (\x y -> compare (snd x) (snd y))
(Map.assocs vs)]) (Map.assocs vs)])
_ -> error $ "doVar1" +++ A.prt ty _ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty)
_ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug
updateSTM ((tyvs, (tr', tr)):) updateSTM ((tyvs, (tr', tr)):)
return tr' return tr'
_ -> GM.composOp doVar 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 $ Ok (cat,labs) -> P (t2t p) . mkLab $
maybe (prtTrace tr $ 66664) snd $ maybe (prtTrace tr $ 66664) snd $
Map.lookup (cat,labs) labels 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) -- this goes recursively into tables (ignored) and records (accumulated)
getLab tr = case tr of getLab tr = case tr of
@@ -511,8 +511,8 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
(FV ts,_) -> ts (FV ts,_) -> ts
_ -> [tr] _ -> [tr]
valNumFV ts = case ts of valNumFV ts = case ts of
[tr] -> let msg = ("DEBUG" +++ prt fun ++ ": error in valNum" +++ prt tr) in [tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in
trace msg $ error (prt fun) trace msg $ error (showIdent fun)
_ -> FV $ map valNum ts _ -> FV $ map valNum ts
mkCurry trm = case trm of mkCurry trm = case trm of
@@ -553,8 +553,8 @@ unlockTy ty = case ty of
prtTrace tr n = prtTrace tr n =
trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) 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. -- | 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.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Option import GF.Infra.Option
import GF.Grammar.PrGrammar import GF.Grammar.Printer
import GF.Compile.Update import GF.Compile.Update
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Infra.Modules 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.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Modules import GF.Infra.Modules
import GF.Grammar.PrGrammar import GF.Grammar.Printer
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Predef import GF.Grammar.Predef
@@ -35,15 +35,10 @@ import GF.Infra.Option
import Control.Monad import Control.Monad
import Data.List import Data.List
import qualified Data.Set as Set import qualified Data.Set as Set
import Text.PrettyPrint
import Debug.Trace 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. -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
type EEnv = () --- not used type EEnv = () --- not used
@@ -81,7 +76,7 @@ evalModule oopts (ms,eenv) mo@(name,m0)
gr = MGrammar $ mo : ms gr = MGrammar $ mo : ms
evalOp g@(MGrammar ((_,m) : _)) i = do evalOp g@(MGrammar ((_,m) : _)) i = do
info <- lookupTree prt i $ jments m info <- lookupTree showIdent i $ jments m
info' <- evalResInfo oopts gr (i,info) info' <- evalResInfo oopts gr (i,info)
return $ updateRes g name 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 :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
evalResInfo oopts gr (c,info) = case info of 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 pde' <- case pde of
Just de | optres -> liftM Just $ comp de Just de | optres -> liftM Just $ comp de
_ -> return pde _ -> return pde
@@ -106,7 +101,7 @@ evalResInfo oopts gr (c,info) = case info of
_ -> return info _ -> return info
where where
comp = if optres then computeConcrete gr else computeConcreteRec gr 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 optim = flag optOptimizations oopts
optres = OptExpand `Set.member` optim optres = OptExpand `Set.member` optim
@@ -115,9 +110,9 @@ evalCncInfo ::
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info
evalCncInfo opts gr cnc abs (c,info) = do 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 CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of 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) liftM Just $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
_ -> return pde -- indirection _ -> 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') return (CncCat ptyp pde' ppr')
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> --trace (prt c) $ 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 pde' <- case pde of
Just de -> liftM Just $ pEval ty de Just de -> liftM Just $ pEval ty de
Nothing -> return pde Nothing -> return pde
@@ -142,11 +137,11 @@ evalCncInfo opts gr cnc abs (c,info) = do
_ -> return info _ -> return info
where where
pEval = partEval opts gr 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 -- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term 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 let vars = map fst context
args = map Vr vars args = map Vr vars
subst = [(v, Vr v) | v <- vars] subst = [(v, Vr v) | v <- vars]
@@ -199,7 +194,7 @@ mkLinDefault gr typ = do
ts' <- mapM mkDefField ts ts' <- mapM mkDefField ts
return $ R $ [assign l t | (l,t) <- zip ls ts'] return $ R $ [assign l t | (l,t) <- zip ls ts']
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val _ | 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 -- | Form the printname: if given, compute. If not, use the computed
-- lin for functions, cat name for cats (dispatch made in evalCncDef above). -- lin for functions, cat name for cats (dispatch made in evalCncDef above).
@@ -210,8 +205,8 @@ evalPrintname gr c ppr lin =
case ppr of case ppr of
Just pr -> comp pr Just pr -> comp pr
Nothing -> case lin of Nothing -> case lin of
Just t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t))
Nothing -> return $ K $ prt c ---- Nothing -> return $ K $ showIdent c ----
where where
comp = computeConcrete gr 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.Grammar.Lookup
import GF.Infra.Ident import GF.Infra.Ident
import qualified GF.Grammar.Macros as C import qualified GF.Grammar.Macros as C
import GF.Grammar.PrGrammar (prt)
import qualified GF.Infra.Modules as M import qualified GF.Infra.Modules as M
import GF.Data.Operations 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 --- 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 -- 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.Modules
import GF.Infra.Ident import GF.Infra.Ident
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.PrGrammar import GF.Grammar.Printer
import GF.Grammar.AppPredefined import GF.Grammar.AppPredefined
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Printer import GF.Grammar.Printer
@@ -55,7 +55,7 @@ renameSourceTerm g m t = do
renameTerm status [] t renameTerm status [] t
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] 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 let js1 = jments mo
status <- buildStatus (MGrammar ms) name mo status <- buildStatus (MGrammar ms) name mo
js2 <- mapsErrTree (renameInfo mo status) js1 js2 <- mapsErrTree (renameInfo mo status) js1
@@ -69,19 +69,19 @@ type StatusInfo = Ident -> Term
renameIdentTerm :: Status -> Term -> Err Term renameIdentTerm :: Status -> Term -> Err Term
renameIdentTerm env@(act,imps) t = 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 case t of
Vr c -> ident predefAbs c Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> Bad s) c Cn c -> ident (\_ s -> Bad s) c
Q m' c | m' == cPredef {- && isInPredefined c -} -> return t Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
Q m' c -> do Q m' c -> do
m <- lookupErr m' qualifs m <- lookupErr m' qualifs
f <- lookupTree prt c m f <- lookupTree showIdent c m
return $ f c return $ f c
QC m' c | m' == cPredef {- && isInPredefined c -} -> return t QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
QC m' c -> do QC m' c -> do
m <- lookupErr m' qualifs m <- lookupErr m' qualifs
f <- lookupTree prt c m f <- lookupTree showIdent c m
return $ f c return $ f c
_ -> return t _ -> return t
where where
@@ -94,14 +94,14 @@ renameIdentTerm env@(act,imps) t =
| isPredefCat c = return $ Q cPredefAbs c | isPredefCat c = return $ Q cPredefAbs c
| otherwise = Bad s | 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 Ok f -> return $ f c
_ -> case lookupTreeManyAll prt opens c of _ -> case lookupTreeManyAll showIdent opens c of
[f] -> return $ f c [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 fs -> case nub [f c | f <- fs] of
[tr] -> return tr [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 -- a warning will be generated in CheckGrammar, and the head returned
-- in next V: -- in next V:
-- Bad $ "conflicting imports:" +++ unwords (map prt ts) -- 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 :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo mo status (i,info) = errIn 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 liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs) (renPerh (mapM rent) pfs)
@@ -210,7 +210,7 @@ renameTerm env vars = ren vars where
Ok t -> return t Ok t -> return t
_ -> case liftM (flip P l) $ renid t of _ -> case liftM (flip P l) $ renid t of
Ok t -> return t -- const proj last 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 EPatt p -> do
(p',_) <- renpatt p (p',_) <- renpatt p
@@ -233,7 +233,7 @@ renamePattern env patt = case patt of
c' <- renid $ Vr c c' <- renid $ Vr c
case c' of case c' of
Q p d -> renp $ PM p d Q p d -> renp $ PM p d
_ -> prtBad "unresolved pattern" patt _ -> Bad (render (text "unresolved pattern" <+> ppPatt Unqualified 0 patt))
PC c ps -> do PC c ps -> do
c' <- renid $ Cn c c' <- renid $ Cn c
@@ -254,7 +254,7 @@ renamePattern env patt = case patt of
PM p c -> do PM p c -> do
(p', c') <- case renid (Q p c) of (p', c') <- case renid (Q p c) of
Ok (Q p' c') -> return (p',c') 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', []) return (PM p' c', [])
PV x -> do case renid (Vr x) of 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 lookupConst th f = th f
lookupVar :: Env -> Ident -> Err Val 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. -- wild card IW: no error produced, ?0 instead.
type TCEnv = (Int,Env,Env) type TCEnv = (Int,Env,Env)
@@ -130,7 +130,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
(t',cs) <- checkExp th (t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs) 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 Prod x a b -> do
testErr (typ == vType) "expected Type" 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 r <- mapM (checkAssign th tenv ys) xs
let (xs,css) = unzip r let (xs,css) = unzip r
return (AR xs, concat css) 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)]) P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
return (AP r' l typ,cs) 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) (a',csa) <- checkExp th tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa) return $ (AApp f' a' b', b', csf ++ csa)
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
_ -> prtBad "cannot infer type of expression" e _ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e))
checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)]) checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
checkLabelling th tenv (lbl,typ) = do 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) let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt 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 [] -> do
(e,cs) <- checkExp th tenv t ty (e,cs) <- checkExp th tenv t ty
return (([],e),cs) 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) PFloat n -> (EFloat n : ps, i, g, k)
PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, 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 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 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) (a',_,csa) <- checkExpP tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa) return $ (AApp f' a' b', b', csf ++ csa)
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ))
_ -> prtBad "cannot typecheck pattern" exp _ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
-- auxiliaries -- 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.Data.Operations
import GF.Infra.CheckM
import GF.Grammar.Abstract import GF.Grammar.Abstract
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Unify import GF.Grammar.Unify
@@ -29,6 +30,7 @@ import GF.Compile.Refresh
import GF.Compile.AbsCompute import GF.Compile.AbsCompute
import GF.Compile.TC import GF.Compile.TC
import Text.PrettyPrint
import Control.Monad (foldM, liftM, liftM2) import Control.Monad (foldM, liftM, liftM2)
-- | invariant way of creating TCEnv from context -- | 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 Ok cont -> return $ cont2val cont
_ -> Bad s _ -> Bad s
checkContext :: Grammar -> Context -> [String] checkContext :: Grammar -> Context -> [Message]
checkContext st = checkTyp st . cont2exp checkContext st = checkTyp st . cont2exp
checkTyp :: Grammar -> Type -> [String] checkTyp :: Grammar -> Type -> [Message]
checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType
checkDef :: Grammar -> Fun -> Type -> [Equation] -> [String] checkDef :: Grammar -> Fun -> Type -> [Equation] -> [Message]
checkDef gr (m,fun) typ eqs = err singleton prConstrs $ do checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do
bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs
let (bs,css) = unzip bcs let (bs,css) = unzip bcs
(constrs,_) <- unifyVal (concat css) (constrs,_) <- unifyVal (concat css)

4
src/GF/Grammar/Abstract.hs
View File

@@ -19,7 +19,7 @@ module GF.Grammar.Values,
module GF.Grammar.Macros, module GF.Grammar.Macros,
module GF.Infra.Ident, module GF.Infra.Ident,
module GF.Grammar.MMacros, module GF.Grammar.MMacros,
module GF.Grammar.PrGrammar, module GF.Grammar.Printer,
Grammar Grammar
@@ -30,7 +30,7 @@ import GF.Grammar.Values
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Infra.Ident import GF.Infra.Ident
import GF.Grammar.MMacros import GF.Grammar.MMacros
import GF.Grammar.PrGrammar import GF.Grammar.Printer
type Grammar = SourceGrammar --- type Grammar = SourceGrammar ---

17
src/GF/Grammar/AppPredefined.hs
View File

@@ -20,8 +20,9 @@ import GF.Data.Operations
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.PrGrammar (prt,prt_,prtBad) import GF.Grammar.Printer
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
-- predefined function type signatures and definitions. AR 12/3/2003. -- predefined function type signatures and definitions. AR 12/3/2003.
@@ -56,7 +57,7 @@ typPredefined f
([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[]) ([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
| f == cTake = return $ mkFunType [typeInt,typeTok] typeTok | f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
| f == cTk = return $ mkFunType [typeInt,typeTok] typeTok | f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
| otherwise = prtBad "unknown in Predef:" f | otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f))
varL :: Ident varL :: Ident
varL = identC (BS.pack "L") varL = identC (BS.pack "L")
@@ -89,7 +90,7 @@ appPredefined t = case t of
(EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse (EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse
(EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse (EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
(EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j (EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
(_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ prt t (_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ render (ppTerm Unqualified 0 t)
(_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags (_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
(_, t) | f == cToStr -> trm2str t >>= retb (_, t) | f == cToStr -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t _ -> retb t ---- prtBad "cannot compute predefined" t
@@ -137,11 +138,11 @@ trm2str t = case t of
T _ ((_,s):_) -> trm2str s T _ ((_,s):_) -> trm2str s
TSh _ ((_,s):_) -> trm2str s TSh _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s V _ (s:_) -> trm2str s
C _ _ -> return $ t C _ _ -> return $ t
K _ -> return $ t K _ -> return $ t
S c _ -> trm2str c S c _ -> trm2str c
Empty -> return $ t Empty -> return $ t
_ -> prtBad "cannot get Str from term" t _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- simultaneous recursion on type and term: type arg is essential! -- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated -- But simplify the task by assuming records are type-annotated

3
src/GF/Grammar/Lockfield.hs
View File

@@ -21,14 +21,13 @@ import qualified Data.ByteString.Char8 as BS
import GF.Infra.Ident import GF.Infra.Ident
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Data.Operations import GF.Data.Operations
lockRecType :: Ident -> Type -> Err Type lockRecType :: Ident -> Type -> Err Type
lockRecType c t@(RecType rs) = lockRecType c t@(RecType rs) =
let lab = lockLabel c in let lab = lockLabel c in
return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"] return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
then t --- don't add an extra copy of lock field, nor predef cats then t --- don't add an extra copy of lock field, nor predef cats
else RecType (rs ++ [(lockLabel c, RecType [])]) else RecType (rs ++ [(lockLabel c, RecType [])])
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])] lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]

52
src/GF/Grammar/Lookup.hs
View File

@@ -16,20 +16,20 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Grammar.Lookup ( module GF.Grammar.Lookup (
lookupIdent, lookupIdent,
lookupIdentInfo, lookupIdentInfo,
lookupIdentInfoIn, lookupIdentInfoIn,
lookupOrigInfo, lookupOrigInfo,
lookupResDef, lookupResDef,
lookupResDefKind, lookupResDefKind,
lookupResType, lookupResType,
lookupOverload, lookupOverload,
lookupParams, lookupParams,
lookupParamValues, lookupParamValues,
lookupFirstTag, lookupFirstTag,
lookupValueIndex, lookupValueIndex,
lookupIndexValue, lookupIndexValue,
allOrigInfos, allOrigInfos,
allParamValues, allParamValues,
lookupAbsDef, lookupAbsDef,
lookupLincat, lookupLincat,
@@ -39,13 +39,17 @@ module GF.Grammar.Lookup (
) where ) where
import GF.Data.Operations import GF.Data.Operations
import GF.Grammar.Abstract import GF.Infra.Ident
import GF.Infra.Modules import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Grammar
import GF.Grammar.Printer
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Lockfield import GF.Grammar.Lockfield
import Data.List (nub,sortBy) import Data.List (nub,sortBy)
import Control.Monad import Control.Monad
import Text.PrettyPrint
-- whether lock fields are added in reuse -- whether lock fields are added in reuse
lock c = lockRecType c -- return lock c = lockRecType c -- return
@@ -92,7 +96,7 @@ lookupResDefKind gr m c
AnyInd _ n -> look False n c AnyInd _ n -> look False n c
ResParam _ -> return (QC m c,2) ResParam _ -> return (QC m c,2)
ResValue _ -> return (QC m c,2) ResValue _ -> return (QC m c,2)
_ -> Bad $ prt c +++ "is not defined in resource" +++ prt m _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
lookExt m c = lookExt m c =
checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)]) checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])
@@ -112,7 +116,7 @@ lookupResType gr m c = do
AnyInd _ n -> lookupResType gr n c AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType ResParam _ -> return $ typePType
ResValue (Just (t,_)) -> return $ qualifAnnotPar m t ResValue (Just (t,_)) -> return $ qualifAnnotPar m t
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
where where
lookFunType e m c = do lookFunType e m c = do
a <- abstractOfConcrete gr m a <- abstractOfConcrete gr m
@@ -124,7 +128,7 @@ lookupResType gr m c = do
AbsFun (Just ty) _ _ -> return $ redirectTerm e ty AbsFun (Just ty) _ _ -> return $ redirectTerm e ty
AbsCat _ _ -> return typeType AbsCat _ _ -> return typeType
AnyInd _ n -> lookFun e m c n AnyInd _ n -> lookFun e m c n
_ -> prtBad "cannot find type of reused function" c _ -> Bad (render (text "cannot find type of reused function" <+> ppIdent c))
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
lookupOverload gr m c = do lookupOverload gr m c = do
@@ -138,7 +142,7 @@ lookupOverload gr m c = do
concat tss concat tss
AnyInd _ n -> lookupOverload gr n c AnyInd _ n -> lookupOverload gr n c
_ -> Bad $ prt c +++ "is not an overloaded operation" _ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found -- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info) lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
@@ -157,7 +161,7 @@ lookupParams gr = look True where
case info of case info of
ResParam (Just psm) -> return psm ResParam (Just psm) -> return psm
AnyInd _ n -> look False n c AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m _ -> Bad $ render (ppIdent c <+> text "has no parameters defined in resource" <+> ppIdent m)
lookExt m c = lookExt m c =
checks [look False n c | n <- allExtensions gr m] checks [look False n c | n <- allExtensions gr m]
@@ -177,21 +181,21 @@ lookupFirstTag gr m c = do
vs <- lookupParamValues gr m c vs <- lookupParamValues gr m c
case vs of case vs of
v:_ -> return v v:_ -> return v
_ -> prtBad "no parameter values given to type" c _ -> Bad (render (text "no parameter values given to type" <+> ppIdent c))
lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
lookupValueIndex gr ty tr = do lookupValueIndex gr ty tr = do
ts <- allParamValues gr ty ts <- allParamValues gr ty
case lookup tr $ zip ts [0..] of case lookup tr $ zip ts [0..] of
Just i -> return $ Val tr ty i Just i -> return $ Val tr ty i
_ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty _ -> Bad $ render (text "no index for" <+> ppTerm Unqualified 0 tr <+> text "in" <+> ppTerm Unqualified 0 ty)
lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
lookupIndexValue gr ty i = do lookupIndexValue gr ty i = do
ts <- allParamValues gr ty ts <- allParamValues gr ty
if i < length ts if i < length ts
then return $ ts !! i then return $ ts !! i
else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty else Bad $ render (text "no value for index" <+> int i <+> text "in" <+> ppTerm Unqualified 0 ty)
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
allOrigInfos gr m = errVal [] $ do allOrigInfos gr m = errVal [] $ do
@@ -209,7 +213,7 @@ allParamValues cnc ptyp = case ptyp of
let (ls,tys) = unzip $ sortByFst r let (ls,tys) = unzip $ sortByFst r
tss <- mapM allPV tys tss <- mapM allPV tys
return [R (zipAssign ls ts) | ts <- combinations tss] return [R (zipAssign ls ts) | ts <- combinations tss]
_ -> prtBad "cannot find parameter values for" ptyp _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
where where
allPV = allParamValues cnc allPV = allParamValues cnc
-- to normalize records and record types -- to normalize records and record types
@@ -228,7 +232,7 @@ qualifAnnotPar m t = case t of
_ -> composSafeOp (qualifAnnotPar m) t _ -> composSafeOp (qualifAnnotPar m) t
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
mo <- lookupModule gr m mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
@@ -244,7 +248,7 @@ lookupLincat gr m c = do
case info of case info of
CncCat (Just t) _ _ -> return t CncCat (Just t) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c AnyInd _ n -> lookupLincat gr n c
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time -- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
@@ -254,7 +258,7 @@ lookupFunType gr m c = do
case info of case info of
AbsFun (Just t) _ _ -> return t AbsFun (Just t) _ _ -> return t
AnyInd _ n -> lookupFunType gr n c AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c _ -> Bad (render (text "cannot find type of" <+> ppIdent c))
-- | this is needed at compile time -- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -264,7 +268,7 @@ lookupCatContext gr m c = do
case info of case info of
AbsCat (Just co) _ -> return co AbsCat (Just co) _ -> return co
AnyInd _ n -> lookupCatContext gr n c AnyInd _ n -> lookupCatContext gr n c
_ -> prtBad "unknown category" c _ -> Bad (render (text "unknown category" <+> ppIdent c))
-- The first type argument is uncomputed, usually a category symbol. -- The first type argument is uncomputed, usually a category symbol.
-- This is a hack to find implicit (= reused) opers. -- This is a hack to find implicit (= reused) opers.

8
src/GF/Grammar/MMacros.hs
View File

@@ -18,7 +18,7 @@ import GF.Data.Operations
--import GF.Data.Zipper --import GF.Data.Zipper
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.PrGrammar import GF.Grammar.Printer
import GF.Infra.Ident import GF.Infra.Ident
import GF.Compile.Refresh import GF.Compile.Refresh
import GF.Grammar.Values import GF.Grammar.Values
@@ -27,6 +27,8 @@ import GF.Grammar.Macros
import Control.Monad import Control.Monad
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
{- {-
nodeTree :: Tree -> TrNode nodeTree :: Tree -> TrNode
argsTree :: Tree -> [Tree] argsTree :: Tree -> [Tree]
@@ -178,13 +180,13 @@ val2expP :: Bool -> Val -> Err Exp
val2expP safe v = case v of val2expP safe v = case v of
VClos g@(_:_) e@(Meta _) -> if safe VClos g@(_:_) e@(Meta _) -> if safe
then prtBad "unsafe value substitution" v then Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 v))
else substVal g e else substVal g e
VClos g e -> substVal g e VClos g e -> substVal g e
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c) VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
VCn c -> return $ qq c VCn c -> return $ qq c
VGen i x -> if safe VGen i x -> if safe
then prtBad "unsafe val2exp" v then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v))
else return $ Vr $ x --- in editing, no alpha conversions presentv else return $ Vr $ x --- in editing, no alpha conversions presentv
VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs
return (RecType xs) return (RecType xs)

28
src/GF/Grammar/Macros.hs
View File

@@ -24,11 +24,12 @@ import GF.Infra.Ident
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Values import GF.Grammar.Values
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.PrGrammar import GF.Grammar.Printer
import Control.Monad (liftM, liftM2) import Control.Monad (liftM, liftM2)
import Data.Char (isDigit) import Data.Char (isDigit)
import Data.List (sortBy) import Data.List (sortBy)
import Text.PrettyPrint
firstTypeForm :: Type -> Err (Context, Type) firstTypeForm :: Type -> Err (Context, Type)
firstTypeForm t = case t of firstTypeForm t = case t of
@@ -50,7 +51,7 @@ qTypeForm t = case t of
QC m c -> QC m c ->
return ([],(m,c),[]) return ([],(m,c),[])
_ -> _ ->
prtBad "no normal form of type" t Bad (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
qq :: QIdent -> Term qq :: QIdent -> Term
qq (m,c) = Q m c qq (m,c) = Q m c
@@ -94,7 +95,7 @@ getMCat t = case t of
QC m c -> return (m,c) QC m c -> return (m,c)
Sort c -> return (identW, c) Sort c -> return (identW, c)
App f _ -> getMCat f App f _ -> getMCat f
_ -> prtBad "no qualified constant" t _ -> Bad (render (text "no qualified constant" <+> ppTerm Unqualified 0 t))
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat) typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do typeSkeleton typ = do
@@ -231,7 +232,7 @@ mkRecType = mkRecTypeN 0
record2subst :: Term -> Err Substitution record2subst :: Term -> Err Substitution
record2subst t = case t of record2subst t = case t of
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs] R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
_ -> prtBad "record expected, found" t _ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t))
typeType, typePType, typeStr, typeTok, typeStrs :: Term typeType, typePType, typeStr, typeTok, typeStrs :: Term
@@ -304,8 +305,8 @@ plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case (RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2)) [] -> return (RecType (r1 ++ r2))
ls -> Bad $ "clashing labels" +++ unwords (map prt ls) ls -> Bad $ render (text "clashing labels" <+> hsep (map ppLabel ls))
_ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) _ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
plusRecord :: Term -> Term -> Err Term plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 = plusRecord t1 t2 =
@@ -314,7 +315,7 @@ plusRecord t1 t2 =
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2)) (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2) _ -> Bad $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
-- | default linearization type -- | default linearization type
defLinType :: Type defLinType :: Type
@@ -463,7 +464,7 @@ term2patt trm = case termForm trm of
Ok ([], Cn c, []) -> do Ok ([], Cn c, []) -> do
return (PMacro c) return (PMacro c)
_ -> prtBad "no pattern corresponds to term" trm _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
patt2term :: Patt -> Term patt2term :: Patt -> Term
patt2term pt = case pt of patt2term pt = case pt of
@@ -529,7 +530,7 @@ strsFromTerm t = case t of
FV ts -> mapM strsFromTerm ts >>= return . concat FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat Strs ts -> mapM strsFromTerm ts >>= return . concat
Alias _ _ d -> strsFromTerm d --- should not be needed... Alias _ _ d -> strsFromTerm d --- should not be needed...
_ -> prtBad "cannot get Str from term" t _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String stringFromTerm :: Term -> String
@@ -708,10 +709,11 @@ isInOneType t = case t of
sortRec :: [(Label,a)] -> [(Label,a)] sortRec :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where sortRec = sortBy ordLabel where
ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of ordLabel (r1,_) (r2,_) =
("s",_) -> LT case (showIdent (label2ident r1), showIdent (label2ident r2)) of
(_,"s") -> GT ("s",_) -> LT
(s1,s2) -> compare s1 s2 (_,"s") -> GT
(s1,s2) -> compare s1 s2

20
src/GF/Grammar/PatternMatch.hs
View File

@@ -21,20 +21,20 @@ import GF.Data.Operations
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.PrGrammar import GF.Grammar.Printer
import Data.List import Data.List
import Control.Monad import Control.Monad
import Text.PrettyPrint
import Debug.Trace import Debug.Trace
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
matchPattern pts term = matchPattern pts term =
if not (isInConstantForm term) if not (isInConstantForm term)
then prtBad "variables occur in" term then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
else do else do
term' <- mkK term term' <- mkK term
errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $ errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
findMatch [([p],t) | (p,t) <- pts] [term'] findMatch [([p],t) | (p,t) <- pts] [term']
where where
-- to capture all Str with string pattern matching -- to capture all Str with string pattern matching
@@ -48,7 +48,7 @@ matchPattern pts term =
K w -> return [w] K w -> return [w]
C v w -> liftM2 (++) (getS v) (getS w) C v w -> liftM2 (++) (getS v) (getS w)
Empty -> return [] Empty -> return []
_ -> prtBad "cannot get string from" s _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
testOvershadow :: [Patt] -> [Term] -> Err [Patt] testOvershadow :: [Patt] -> [Term] -> Err [Patt]
testOvershadow pts vs = do testOvershadow pts vs = do
@@ -59,10 +59,10 @@ testOvershadow pts vs = do
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) [] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
(patts,_):_ | length patts /= length terms -> (patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++ Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of (patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs) Ok substs -> return (val, concat substs)
_ -> findMatch cc terms _ -> findMatch cc terms
@@ -122,7 +122,7 @@ tryMatch (p,t) = do
(PNeg p',_) -> case tryMatch (p',t) of (PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return [] Bad _ -> return []
_ -> prtBad "no match with negative pattern" p _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
(PSeq p1 p2, ([],K s, [])) -> do (PSeq p1 p2, ([],K s, [])) -> do
let cuts = [splitAt n s | n <- [0 .. length s]] let cuts = [splitAt n s | n <- [0 .. length s]]
@@ -138,7 +138,7 @@ tryMatch (p,t) = do
(PChar, ([],K [_], [])) -> return [] (PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return [] (PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> prtBad "no match in case expr for" t _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
isInConstantForm :: Term -> Bool isInConstantForm :: Term -> Bool
isInConstantForm trm = case trm of isInConstantForm trm = case trm of

19
src/GF/Grammar/Printer.hs
View File

@@ -16,11 +16,14 @@ module GF.Grammar.Printer
, ppTerm , ppTerm
, ppTermTabular , ppTermTabular
, ppPatt , ppPatt
, ppValue
, ppConstrs
) where ) where
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Modules import GF.Infra.Modules
import GF.Infra.Option import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Data.Operations import GF.Data.Operations
import Text.PrettyPrint import Text.PrettyPrint
@@ -225,6 +228,22 @@ ppPatt q d (PFloat f) = double f
ppPatt q d (PString s) = str s ppPatt q d (PString s) = str s
ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))
ppValue :: TermPrintQual -> Int -> Val -> Doc
ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging
ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
ppValue q d (VCn (_,c)) = ppIdent c
ppValue q d (VClos env e) = case e of
Meta _ -> ppTerm q d e <> ppEnv env
_ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs]))
ppValue q d VType = text "Type"
ppConstrs :: Constraints -> [Doc]
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w))
ppEnv :: Env -> Doc
ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
str s = doubleQuotes (text s) str s = doubleQuotes (text s)
ppDecl q (id,typ) ppDecl q (id,typ)

8
src/GF/Grammar/Unify.hs
View File

@@ -18,9 +18,9 @@
module GF.Grammar.Unify (unifyVal) where module GF.Grammar.Unify (unifyVal) where
import GF.Grammar.Abstract import GF.Grammar.Abstract
import GF.Data.Operations import GF.Data.Operations
import Text.PrettyPrint
import Data.List (partition) import Data.List (partition)
unifyVal :: Constraints -> Err (Constraints,MetaSubst) unifyVal :: Constraints -> Err (Constraints,MetaSubst)
@@ -64,13 +64,13 @@ unify e1 e2 g =
unify b c' g unify b c' g
(App c a, App d b) -> case unify c d g of (App c a, App d b) -> case unify c d g of
Ok g1 -> unify a b g1 Ok g1 -> unify a b g1
_ -> prtBad "fail unify" e1 _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
(RecType xs,RecType ys) | xs == ys -> return g (RecType xs,RecType ys) | xs == ys -> return g
_ -> prtBad "fail unify" e1 _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
extend :: Unifier -> MetaSymb -> Term -> Err Unifier extend :: Unifier -> MetaSymb -> Term -> Err Unifier
extend g s t | (t == Meta s) = return g extend g s t | (t == Meta s) = return g
| occCheck s t = prtBad "occurs check" t | occCheck s t = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t))
| True = return ((s, t) : g) | True = return ((s, t) : g)
subst_all :: Unifier -> Term -> Err Term subst_all :: Unifier -> Term -> Err Term