mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Use GF.Grammar.Printer everywhere instead of PrGrammar
This commit is contained in:
krasimir
@@ -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])
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)))
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -19,7 +19,7 @@ module GF.Grammar.Values,
|
||||
module GF.Grammar.Macros,
|
||||
module GF.Infra.Ident,
|
||||
module GF.Grammar.MMacros,
|
||||
module GF.Grammar.PrGrammar,
|
||||
module GF.Grammar.Printer,
|
||||
|
||||
Grammar
|
||||
|
||||
@@ -30,7 +30,7 @@ import GF.Grammar.Values
|
||||
import GF.Grammar.Macros
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.MMacros
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Grammar.Printer
|
||||
|
||||
type Grammar = SourceGrammar ---
|
||||
|
||||
|
||||
@@ -20,8 +20,9 @@ import GF.Data.Operations
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar (prt,prt_,prtBad)
|
||||
import GF.Grammar.Printer
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Text.PrettyPrint
|
||||
|
||||
-- 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,[])
|
||||
| f == cTake = 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 = 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 == cLessInt -> retb $ if i<j then predefTrue else predefFalse
|
||||
(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
|
||||
(_, t) | f == cToStr -> trm2str t >>= retb
|
||||
_ -> retb t ---- prtBad "cannot compute predefined" t
|
||||
@@ -137,11 +138,11 @@ trm2str t = case t of
|
||||
T _ ((_,s):_) -> trm2str s
|
||||
TSh _ ((_,s):_) -> trm2str s
|
||||
V _ (s:_) -> trm2str s
|
||||
C _ _ -> return $ t
|
||||
K _ -> return $ t
|
||||
S c _ -> trm2str c
|
||||
Empty -> return $ t
|
||||
_ -> prtBad "cannot get Str from term" t
|
||||
C _ _ -> return $ t
|
||||
K _ -> return $ t
|
||||
S c _ -> trm2str c
|
||||
Empty -> return $ t
|
||||
_ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
|
||||
|
||||
-- simultaneous recursion on type and term: type arg is essential!
|
||||
-- But simplify the task by assuming records are type-annotated
|
||||
|
||||
@@ -21,14 +21,13 @@ import qualified Data.ByteString.Char8 as BS
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
lockRecType :: Ident -> Type -> Err Type
|
||||
lockRecType c t@(RecType rs) =
|
||||
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
|
||||
else RecType (rs ++ [(lockLabel c, RecType [])])
|
||||
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]
|
||||
|
||||
@@ -16,20 +16,20 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.Lookup (
|
||||
lookupIdent,
|
||||
lookupIdentInfo,
|
||||
lookupIdentInfoIn,
|
||||
lookupOrigInfo,
|
||||
lookupResDef,
|
||||
lookupResDefKind,
|
||||
lookupIdent,
|
||||
lookupIdentInfo,
|
||||
lookupIdentInfoIn,
|
||||
lookupOrigInfo,
|
||||
lookupResDef,
|
||||
lookupResDefKind,
|
||||
lookupResType,
|
||||
lookupOverload,
|
||||
lookupOverload,
|
||||
lookupParams,
|
||||
lookupParamValues,
|
||||
lookupFirstTag,
|
||||
lookupValueIndex,
|
||||
lookupIndexValue,
|
||||
allOrigInfos,
|
||||
lookupValueIndex,
|
||||
lookupIndexValue,
|
||||
allOrigInfos,
|
||||
allParamValues,
|
||||
lookupAbsDef,
|
||||
lookupLincat,
|
||||
@@ -39,13 +39,17 @@ module GF.Grammar.Lookup (
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Printer
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Lockfield
|
||||
|
||||
import Data.List (nub,sortBy)
|
||||
import Control.Monad
|
||||
import Text.PrettyPrint
|
||||
|
||||
-- whether lock fields are added in reuse
|
||||
lock c = lockRecType c -- return
|
||||
@@ -92,7 +96,7 @@ lookupResDefKind gr m c
|
||||
AnyInd _ n -> look False n c
|
||||
ResParam _ -> 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 =
|
||||
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
|
||||
ResParam _ -> return $ typePType
|
||||
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
|
||||
lookFunType e m c = do
|
||||
a <- abstractOfConcrete gr m
|
||||
@@ -124,7 +128,7 @@ lookupResType gr m c = do
|
||||
AbsFun (Just ty) _ _ -> return $ redirectTerm e ty
|
||||
AbsCat _ _ -> return typeType
|
||||
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 gr m c = do
|
||||
@@ -138,7 +142,7 @@ lookupOverload gr m c = do
|
||||
concat tss
|
||||
|
||||
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
|
||||
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
|
||||
@@ -157,7 +161,7 @@ lookupParams gr = look True where
|
||||
case info of
|
||||
ResParam (Just psm) -> return psm
|
||||
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 =
|
||||
checks [look False n c | n <- allExtensions gr m]
|
||||
|
||||
@@ -177,21 +181,21 @@ lookupFirstTag gr m c = do
|
||||
vs <- lookupParamValues gr m c
|
||||
case vs of
|
||||
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 gr ty tr = do
|
||||
ts <- allParamValues gr ty
|
||||
case lookup tr $ zip ts [0..] of
|
||||
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 gr ty i = do
|
||||
ts <- allParamValues gr ty
|
||||
if i < length ts
|
||||
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 gr m = errVal [] $ do
|
||||
@@ -209,7 +213,7 @@ allParamValues cnc ptyp = case ptyp of
|
||||
let (ls,tys) = unzip $ sortByFst r
|
||||
tss <- mapM allPV tys
|
||||
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
|
||||
allPV = allParamValues cnc
|
||||
-- to normalize records and record types
|
||||
@@ -228,7 +232,7 @@ qualifAnnotPar m t = case t of
|
||||
_ -> composSafeOp (qualifAnnotPar m) t
|
||||
|
||||
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
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
@@ -244,7 +248,7 @@ lookupLincat gr m c = do
|
||||
case info of
|
||||
CncCat (Just t) _ _ -> return t
|
||||
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
|
||||
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
|
||||
@@ -254,7 +258,7 @@ lookupFunType gr m c = do
|
||||
case info of
|
||||
AbsFun (Just t) _ _ -> return t
|
||||
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
|
||||
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
|
||||
@@ -264,7 +268,7 @@ lookupCatContext gr m c = do
|
||||
case info of
|
||||
AbsCat (Just co) _ -> return co
|
||||
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.
|
||||
-- This is a hack to find implicit (= reused) opers.
|
||||
|
||||
@@ -18,7 +18,7 @@ import GF.Data.Operations
|
||||
--import GF.Data.Zipper
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Grammar.Printer
|
||||
import GF.Infra.Ident
|
||||
import GF.Compile.Refresh
|
||||
import GF.Grammar.Values
|
||||
@@ -27,6 +27,8 @@ import GF.Grammar.Macros
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Text.PrettyPrint
|
||||
|
||||
{-
|
||||
nodeTree :: Tree -> TrNode
|
||||
argsTree :: Tree -> [Tree]
|
||||
@@ -178,13 +180,13 @@ val2expP :: Bool -> Val -> Err Exp
|
||||
val2expP safe v = case v of
|
||||
|
||||
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
|
||||
VClos g e -> substVal g e
|
||||
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
|
||||
VCn c -> return $ qq c
|
||||
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
|
||||
VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs
|
||||
return (RecType xs)
|
||||
|
||||
@@ -24,11 +24,12 @@ import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Grammar.Printer
|
||||
|
||||
import Control.Monad (liftM, liftM2)
|
||||
import Data.Char (isDigit)
|
||||
import Data.List (sortBy)
|
||||
import Text.PrettyPrint
|
||||
|
||||
firstTypeForm :: Type -> Err (Context, Type)
|
||||
firstTypeForm t = case t of
|
||||
@@ -50,7 +51,7 @@ qTypeForm t = case t of
|
||||
QC 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 (m,c) = Q m c
|
||||
@@ -94,7 +95,7 @@ getMCat t = case t of
|
||||
QC m c -> return (m,c)
|
||||
Sort c -> return (identW, c)
|
||||
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 typ = do
|
||||
@@ -231,7 +232,7 @@ mkRecType = mkRecTypeN 0
|
||||
record2subst :: Term -> Err Substitution
|
||||
record2subst t = case t of
|
||||
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
|
||||
|
||||
@@ -304,8 +305,8 @@ plusRecType t1 t2 = case (t1, t2) of
|
||||
(RecType r1, RecType r2) -> case
|
||||
filter (`elem` (map fst r1)) (map fst r2) of
|
||||
[] -> return (RecType (r1 ++ r2))
|
||||
ls -> Bad $ "clashing labels" +++ unwords (map prt ls)
|
||||
_ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2)
|
||||
ls -> Bad $ render (text "clashing labels" <+> hsep (map ppLabel ls))
|
||||
_ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
|
||||
|
||||
plusRecord :: Term -> Term -> Err Term
|
||||
plusRecord t1 t2 =
|
||||
@@ -314,7 +315,7 @@ plusRecord t1 t2 =
|
||||
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
|
||||
(_, FV rs) -> mapM (plusRecord t1) 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
|
||||
defLinType :: Type
|
||||
@@ -463,7 +464,7 @@ term2patt trm = case termForm trm of
|
||||
Ok ([], Cn c, []) -> do
|
||||
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 pt = case pt of
|
||||
@@ -529,7 +530,7 @@ strsFromTerm t = case t of
|
||||
FV ts -> mapM strsFromTerm ts >>= return . concat
|
||||
Strs ts -> mapM strsFromTerm ts >>= return . concat
|
||||
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
|
||||
stringFromTerm :: Term -> String
|
||||
@@ -708,10 +709,11 @@ isInOneType t = case t of
|
||||
|
||||
sortRec :: [(Label,a)] -> [(Label,a)]
|
||||
sortRec = sortBy ordLabel where
|
||||
ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of
|
||||
("s",_) -> LT
|
||||
(_,"s") -> GT
|
||||
(s1,s2) -> compare s1 s2
|
||||
ordLabel (r1,_) (r2,_) =
|
||||
case (showIdent (label2ident r1), showIdent (label2ident r2)) of
|
||||
("s",_) -> LT
|
||||
(_,"s") -> GT
|
||||
(s1,s2) -> compare s1 s2
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -21,20 +21,20 @@ import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Grammar.Printer
|
||||
|
||||
import Data.List
|
||||
import Control.Monad
|
||||
|
||||
import Text.PrettyPrint
|
||||
import Debug.Trace
|
||||
|
||||
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
|
||||
matchPattern pts term =
|
||||
if not (isInConstantForm term)
|
||||
then prtBad "variables occur in" term
|
||||
then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
|
||||
else do
|
||||
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']
|
||||
where
|
||||
-- to capture all Str with string pattern matching
|
||||
@@ -48,7 +48,7 @@ matchPattern pts term =
|
||||
K w -> return [w]
|
||||
C v w -> liftM2 (++) (getS v) (getS w)
|
||||
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 pts vs = do
|
||||
@@ -59,10 +59,10 @@ testOvershadow pts vs = do
|
||||
|
||||
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" <+> hsep (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 (val, concat substs)
|
||||
_ -> findMatch cc terms
|
||||
@@ -122,7 +122,7 @@ tryMatch (p,t) = do
|
||||
|
||||
(PNeg p',_) -> case tryMatch (p',t) of
|
||||
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
|
||||
let cuts = [splitAt n s | n <- [0 .. length s]]
|
||||
@@ -138,7 +138,7 @@ tryMatch (p,t) = do
|
||||
(PChar, ([],K [_], [])) -> 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 trm = case trm of
|
||||
|
||||
@@ -16,11 +16,14 @@ module GF.Grammar.Printer
|
||||
, ppTerm
|
||||
, ppTermTabular
|
||||
, ppPatt
|
||||
, ppValue
|
||||
, ppConstrs
|
||||
) where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.Values
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Data.Operations
|
||||
import Text.PrettyPrint
|
||||
@@ -225,6 +228,22 @@ ppPatt q d (PFloat f) = double f
|
||||
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]))
|
||||
|
||||
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)
|
||||
|
||||
ppDecl q (id,typ)
|
||||
|
||||
@@ -18,9 +18,9 @@
|
||||
module GF.Grammar.Unify (unifyVal) where
|
||||
|
||||
import GF.Grammar.Abstract
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Text.PrettyPrint
|
||||
import Data.List (partition)
|
||||
|
||||
unifyVal :: Constraints -> Err (Constraints,MetaSubst)
|
||||
@@ -64,13 +64,13 @@ unify e1 e2 g =
|
||||
unify b c' g
|
||||
(App c a, App d b) -> case unify c d g of
|
||||
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
|
||||
_ -> prtBad "fail unify" e1
|
||||
_ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
|
||||
|
||||
extend :: Unifier -> MetaSymb -> Term -> Err Unifier
|
||||
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)
|
||||
|
||||
subst_all :: Unifier -> Term -> Err Term
|
||||
|
||||
Reference in New Issue
Block a user