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

CheckGrammar is now using the printer in GF.Grammar.Printer. Fixed bug that was hiding the warnings

Browse Source
This commit is contained in:
krasimir
2009-09-14 12:16:02 +00:00
parent cc151c4279
commit 62ef772a2c
17 changed files with 224 additions and 299 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -21,7 +21,6 @@ import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import qualified GF.Grammar.Macros as C
import GF.Grammar.PrGrammar (prt)
import GF.Data.Operations
import Data.List
import qualified GF.Infra.Modules as M
@@ -72,7 +71,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

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

@@ -32,7 +32,7 @@ import GF.Compile.TypeCheck
import GF.Compile.Refresh
import GF.Grammar.Lexer
import GF.Grammar.Grammar
import GF.Grammar.PrGrammar
import GF.Grammar.Printer
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Grammar.Macros
@@ -45,43 +45,37 @@ import GF.Infra.CheckM
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad
import Debug.Trace ---
import Text.PrettyPrint
showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String)
showCheckModule mos m = do
(st,(_,msg)) <- checkStart $ checkModule mos m
return (st, unlines $ reverse msg)
mapsCheckTree ::
(Ord a) => ((a,b) -> Check (a,c)) -> BinTree a b -> Check (BinTree a c)
mapsCheckTree f = checkErr . mapsErrTree (\t -> checkStart (f t) >>= return . fst)
showCheckModule mos m =
case runCheck (checkModule mos m) of
Left msgs -> Bad ( render (vcat (reverse msgs)))
Right (st,_,msgs) -> Ok (st, render (vcat (reverse msgs)))
-- | checking is performed in the dependency order of modules
checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
checkModule ms (name,mo) = checkIn ("checking module" +++ prt name) $ do
checkModule ms (name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do
let js = jments mo
checkRestrictedInheritance ms (name, mo)
js' <- case mtype mo of
MTAbstract -> mapsCheckTree (checkAbsInfo gr name mo) js
MTAbstract -> checkMap (checkAbsInfo gr name mo) js
MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name mo) js
MTTransfer a b -> checkMap (checkAbsInfo gr name mo) js
MTResource -> mapsCheckTree (checkResInfo gr name mo) js
MTResource -> checkMap (checkResInfo gr name mo) js
MTConcrete a -> do
checkErr $ topoSortOpers $ allOperDependencies name js
abs <- checkErr $ lookupModule gr a
js1 <- checkCompleteGrammar gr abs mo
mapsCheckTree (checkCncInfo gr name mo (a,abs)) js1
checkMap (checkCncInfo gr name mo (a,abs)) js1
MTInterface -> mapsCheckTree (checkResInfo gr name mo) js
MTInterface -> checkMap (checkResInfo gr name mo) js
MTInstance a -> do
mapsCheckTree (checkResInfo gr name mo) js
checkMap (checkResInfo gr name mo) js
return $ (name, replaceJudgements mo js') : ms
where
@@ -104,22 +98,21 @@ checkRestrictedInheritance mos (name,mo) = do
(f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
case illegals of
[] -> return ()
cs -> fail $ "In inherited module" +++ prt i ++
", dependence of excluded constants:" ++++
unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) |
(f,is) <- cs]
cs -> checkError (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$
nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs]))
allDeps = concatMap (allDependencies (const True) . jments . snd) mos
-- | check if a term is typable
justCheckLTerm :: SourceGrammar -> Term -> Err Term
justCheckLTerm src t = do
((t',_),_) <- checkStart (inferLType src t)
return t'
justCheckLTerm src t =
case runCheck (inferLType src t) of
Left msgs -> Bad ( render (vcat (reverse msgs)))
Right ((t',_),_,_) -> Ok t'
checkAbsInfo ::
SourceGrammar -> Ident -> SourceModInfo -> (Ident,Info) -> Check (Ident,Info)
checkAbsInfo st m mo (c,info) = do
---- checkReservedId c
SourceGrammar -> Ident -> SourceModInfo -> Ident -> Info -> Check Info
checkAbsInfo st m mo c info = do
checkReservedId c
case info of
AbsCat (Just cont) _ -> mkCheck "category" $
checkContext st cont ---- also cstrs
@@ -130,25 +123,16 @@ checkAbsInfo st m mo (c,info) = do
case md of
Just eqs -> mkCheck "definition of function" $
checkDef st (m,c) typ eqs
Nothing -> return (c,info)
return $ (c,AbsFun (Just typ) ma md)
_ -> return (c,info)
Nothing -> return info
return $ (AbsFun (Just typ) ma md)
_ -> return info
where
mkCheck cat ss = case ss of
[] -> return (c,info)
_ -> checkErr $ Bad (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c)
---- temporary solution when tc of defs is incomplete
mkCheckWarn cat ss = case ss of
[] -> return (c,info)
["[]"] -> return (c,info) ----
_ -> do
checkWarn (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c)
return (c,info)
pos c = showPosition mo c
[] -> return info
_ -> checkError (vcat (map text ss) $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c)
compAbsTyp g t = case t of
Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
Let (x,(_,a)) b -> do
a' <- compAbsTyp g a
compAbsTyp ((x, a'):g) b
@@ -169,8 +153,7 @@ checkCompleteGrammar gr abs cnc = do
-- remove those lincat and lin in concrete that are not in abstract
let unkn = filter (not . flip isInBinTree jsa) fsc
jsc1 <- if (null unkn) then return jsc else do
checkWarn $ "ignoring constants not in abstract:" +++
unwords (map prt unkn)
checkWarn $ text "ignoring constants not in abstract:" <+> fsep (map ppIdent unkn)
return $ filterBinTree (\f _ -> notElem f unkn) jsc
-- check that all abstract constants are in concrete; build default lincats
@@ -196,32 +179,30 @@ checkCompleteGrammar gr abs cnc = do
Ok (CncFun cty Nothing pn) ->
case mb_def of
Ok def -> return $ updateTree (c,CncFun cty (Just def) pn) js
Bad _ -> do checkWarn $ "no linearization of" +++ prt c
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js
_ -> do
case mb_def of
Ok def -> return $ updateTree (c,CncFun Nothing (Just def) Nothing) js
Bad _ -> do checkWarn $ "no linearization of" +++ prt c
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js
AbsCat (Just _) _ -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _) -> return js
Ok (CncCat _ mt mp) -> do
checkWarn $
"no linearization type for" +++ prt c ++
", inserting default {s : Str}"
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
return $ updateTree (c,CncCat (Just defLinType) mt mp) js
_ -> do
checkWarn $
"no linearization type for" +++ prt c ++
", inserting default {s : Str}"
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
return $ updateTree (c,CncCat (Just defLinType) Nothing Nothing) js
_ -> return js
-- | General Principle: only Just-values are checked.
-- A May-value has always been checked in its origin module.
checkResInfo :: SourceGrammar -> Ident -> SourceModInfo -> (Ident,Info) -> Check (Ident,Info)
checkResInfo gr mo mm (c,info) = do
checkResInfo :: SourceGrammar -> Ident -> SourceModInfo -> Ident -> Info -> Check Info
checkResInfo gr mo mm c info = do
checkReservedId c
case info of
ResOper pty pde -> chIn "operation" $ do
@@ -234,47 +215,43 @@ checkResInfo gr mo mm (c,info) = do
(de',ty') <- infer de
return (Just ty', Just de')
(_ , Nothing) -> do
raise "No definition given to oper"
return (c, ResOper pty' pde')
checkError (text "No definition given to the operation")
return (ResOper pty' pde')
ResOverload os tysts -> chIn "overloading" $ do
tysts' <- mapM (uncurry $ flip check) tysts -- return explicit ones
tysts0 <- checkErr $ lookupOverload gr mo c -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip check)
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
let tysts2 = [(y,x) | (x,y) <- tysts1]
--- this can only be a partial guarantee, since matching
--- with value type is only possible if expected type is given
checkUniq $
sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]]
return (c,ResOverload os [(y,x) | (x,y) <- tysts'])
sort [t : map snd xs | (_,x) <- tysts1, Ok (xs,t) <- [typeFormCnc x]]
return (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just (pcs,_)) -> chIn "parameter type" $ do
---- mapM ((mapM (computeLType gr . snd)) . snd) pcs
mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs
ts <- checkErr $ lookupParamValues gr mo c
return (c,ResParam (Just (pcs, Just ts)))
return (ResParam (Just (pcs, Just ts)))
_ -> return (c,info)
_ -> return info
where
infer = inferLType gr
check = checkLType gr
chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":")
chIn cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition mm c <+> colon)
comp = computeLType gr
pos c = showPosition mm c
checkUniq xss = case xss of
x:y:xs
| x == y -> raise $ "ambiguous for type" +++
prtType gr (mkFunType (tail x) (head x))
| x == y -> checkError $ text "ambiguous for type" <+>
ppType gr (mkFunType (tail x) (head x))
| otherwise -> checkUniq $ y:xs
_ -> return ()
checkCncInfo :: SourceGrammar -> Ident -> SourceModInfo ->
(Ident,SourceModInfo) ->
(Ident,Info) -> Check (Ident,Info)
checkCncInfo gr m mo (a,abs) (c,info) = do
Ident -> Info -> Check Info
checkCncInfo gr m mo (a,abs) c info = do
checkReservedId c
case info of
@@ -285,73 +262,28 @@ checkCncInfo gr m mo (a,abs) (c,info) = do
(trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars
checkPrintname gr mpr
cat <- return $ snd cat0
return (c, CncFun (Just (cat,(cont,val))) (Just trm') mpr)
return (CncFun (Just (cat,(cont,val))) (Just trm') mpr)
-- cat for cf, typ for pe
CncCat (Just typ) mdef mpr -> chIn "linearization type of" $ do
checkErr $ lookupCatContext gr a c
typ' <- checkIfLinType gr typ
typ' <- computeLType gr typ
mdef' <- case mdef of
Just def -> do
(def',_) <- checkLType gr def (mkFunType [typeStr] typ)
return $ Just def'
_ -> return mdef
checkPrintname gr mpr
return (c,CncCat (Just typ') mdef' mpr)
return (CncCat (Just typ') mdef' mpr)
_ -> checkResInfo gr m mo (c,info)
_ -> checkResInfo gr m mo c info
where
env = gr
infer = inferLType gr
comp = computeLType gr
check = checkLType gr
chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":")
pos c = showPosition mo c
checkIfParType :: SourceGrammar -> Type -> Check ()
checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ)
where
isParType ty = True ----
{- case ty of
Cn typ -> case lookupConcrete st typ of
Ok (CncParType _ _ _) -> True
Ok (CncOper _ ty' _) -> isParType ty'
_ -> False
Q p t -> case lookupInPackage st (p,t) of
Ok (CncParType _ _ _) -> True
_ -> False
RecType r -> all (isParType . snd) r
_ -> False
-}
checkIfStrType :: SourceGrammar -> Type -> Check ()
checkIfStrType st typ = case typ of
Table arg val -> do
checkIfParType st arg
checkIfStrType st val
_ | typ == typeStr -> return ()
_ -> prtFail "not a string type" typ
checkIfLinType :: SourceGrammar -> Type -> Check Type
checkIfLinType st typ0 = do
typ <- computeLType st typ0
{- ---- should check that not fun type
case typ of
RecType r -> do
let (lins,ihs) = partition (isLinLabel .fst) r
--- checkErr $ checkUnique $ map fst r
mapM_ checkInh ihs
mapM_ checkLin lins
_ -> prtFail "a linearization type cannot be" typ
-}
return typ
where
checkInh (label,typ) = checkIfParType st typ
checkLin (label,typ) = return () ---- checkIfStrType st typ
chIn cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition mo c <> colon)
computeLType :: SourceGrammar -> Type -> Check Type
computeLType gr t = do
@@ -363,7 +295,7 @@ computeLType gr t = do
_ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
| isPredefConstant ty -> return ty ---- shouldn't be needed
Q m ident -> checkIn ("module" +++ prt m) $ do
Q m ident -> checkIn (text "module" <+> ppIdent m) $ do
ty' <- checkErr (lookupResDef gr m ident)
if ty' == ty then return ty else comp ty' --- is this necessary to test?
@@ -412,17 +344,9 @@ checkPrintname _ _ = return ()
-- | for grammars obtained otherwise than by parsing ---- update!!
checkReservedId :: Ident -> Check ()
checkReservedId x
| isReservedWord (ident2bs x) = checkWarn ("reserved word used as identifier:" +++ prt x)
| isReservedWord (ident2bs x) = checkWarn (text "reserved word used as identifier:" <+> ppIdent x)
| otherwise = return ()
-- to normalize records and record types
labelIndex :: Type -> Label -> Int
labelIndex ty lab = case ty of
RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts
_ -> error $ "label index" +++ prt ty
where
labs ts = zip (map fst (sortRec ts)) [0..]
-- the underlying algorithms
inferLType :: SourceGrammar -> Term -> Check (Term, Type)
@@ -435,7 +359,7 @@ inferLType gr trm = case trm of
,
checkErr (lookupResDef gr m ident) >>= infer
,
prtFail "cannot infer type of constant" trm
checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
]
QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
@@ -445,7 +369,7 @@ inferLType gr trm = case trm of
,
checkErr (lookupResDef gr m ident) >>= infer
,
prtFail "cannot infer type of canonical constant" trm
checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
]
Val _ ty i -> termWith trm $ return ty
@@ -471,8 +395,7 @@ inferLType gr trm = case trm of
then return val
else substituteLType [(z,a')] val
return (App f' a',ty)
_ -> raise ("function type expected for"+++
prt f +++"instead of" +++ prtType env fty)
_ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType env fty)
S f x -> do
(f', fty) <- infer f
@@ -480,24 +403,25 @@ inferLType gr trm = case trm of
Table arg val -> do
x'<- justCheck x arg
return (S f' x', val)
_ -> prtFail "table lintype expected for the table in" trm
_ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
P t i -> do
(t',ty) <- infer t --- ??
ty' <- comp ty
----- let tr2 = PI t' i (labelIndex ty' i)
let tr2 = P t' i
termWith tr2 $ checkErr $ case ty' of
RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $
lookup i ts
_ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty'
termWith tr2 $ case ty' of
RecType ts -> case lookup i ts of
Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
Just x -> return x
_ -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$
text " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
PI t i _ -> infer $ P t i
R r -> do
let (ls,fs) = unzip r
fsts <- mapM inferM fs
let ts = [ty | (Just ty,_) <- fsts]
checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts)
checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
return $ (R (zip ls fsts), RecType (zip ls ts))
T (TTyped arg) pts -> do
@@ -509,7 +433,7 @@ inferLType gr trm = case trm of
T ti pts -> do -- tries to guess: good in oper type inference
let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
case pts' of
[] -> prtFail "cannot infer table type of" trm
[] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm)
---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
_ -> do
(arg,val) <- checks $ map (inferCase Nothing) pts'
@@ -542,9 +466,8 @@ inferLType gr trm = case trm of
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
Strs (Cn c : ts) | c == cConflict -> do
trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts)
-- checkWarn ("unresolved constant, could be any of" +++ unwords (map prt ts))
-- infer $ head ts
checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
infer (head ts)
Strs ts -> do
ts' <- mapM (\t -> justCheck t typeStr) ts
@@ -576,7 +499,7 @@ inferLType gr trm = case trm of
rt <- checkErr $ plusRecType rT' sT'
check trm' rt ---- return (trm', rt)
_ | rT' == typeType && sT' == typeType -> return (trm', typeType)
_ -> prtFail "records or record types expected in" trm
_ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
Sort _ ->
termWith trm $ return typeType
@@ -608,7 +531,7 @@ inferLType gr trm = case trm of
ty' <- checkErr $ lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
return $ (ELin c trm', ty')
_ -> prtFail "cannot infer lintype of" trm
_ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
where
env = gr
@@ -685,28 +608,23 @@ getOverload env@gr mt ot = case appForm ot of
case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
([(val,fun)],_) -> return (mkApp fun tts, val)
([],[(val,fun)]) -> do
checkWarn ("ignoring lock fields in resolving" +++ prt ot)
checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
return (mkApp fun tts, val)
([],[]) -> do
---- let prtType _ = prt -- to debug grammars
let sought = unwords (map (prtType env) tys)
let showTypes ty = case unwords (map (prtType env) ty) of
s | s == sought ->
s +++ " -- i.e." +++ unwords (map prt ty) ++++
" where we sought" +++ unwords (map prt tys)
s -> s
raise $ "no overload instance of" +++ prt f +++
"for" +++
sought +++
"among" ++++
unlines [" " ++ showTypes ty | (ty,_) <- typs] ++
maybe [] (("with value type" +++) . prtType env) mt
let showTypes ty = vcat (map (ppType env) ty)
checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$
text "for" $$
nest 2 (showTypes tys) $$
text "among" $$
nest 2 (vcat [showTypes ty | (ty,_) <- typs]) $$
maybe empty (\x -> text "with value type" <+> ppType env x) mt
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
([(val,fun)],_) -> do
return (mkApp fun tts, val)
([],[(val,fun)]) -> do
checkWarn ("ignoring lock fields in resolving" +++ prt ot)
checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
return (mkApp fun tts, val)
----- unsafely exclude irritating warning AR 24/5/2008
@@ -715,9 +633,10 @@ getOverload env@gr mt ot = case appForm ot of
----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
_ -> raise $ "ambiguous overloading of" +++ prt f +++
"for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++
unlines [prtType env ty | (ty,_) <- if (null vfs1) then vfs2 else vfs2]
_ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
text "for" <+> hsep (map (ppType env) tys) $$
text "with alternatives" $$
nest 2 (vcat [ppType env ty | (ty,_) <- if null vfs1 then vfs2 else vfs2])
matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
@@ -755,11 +674,11 @@ checkLType env trm typ0 = do
(c',b') <- if isWildIdent z
then check c b
else do
b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b
b' <- checkIn (text "abs") $ substituteLType [(z,Vr x)] b
check c b'
checkReset
return $ (Abs x c', Prod x a b')
_ -> raise $ "function type expected instead of" +++ prtType env typ
_ -> checkError $ text "function type expected instead of" <+> ppType env typ
App f a -> do
over <- getOverload env (Just typ) trm
@@ -778,7 +697,7 @@ checkLType env trm typ0 = do
termWith trm' $ checkEq typ ty' trm'
T _ [] ->
prtFail "found empty table in type" typ
checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ)
T _ cs -> case typ of
Table arg val -> do
case allParamValues env arg of
@@ -787,20 +706,12 @@ checkLType env trm typ0 = do
ps <- checkErr $ testOvershadow ps0 vs
if null ps
then return ()
---- use this if you want to see where the error is
-- else raise $ "patterns never reached:" +++
-- concat (intersperse ", " (map prt ps))
---- else use this
else trace ("WARNING: patterns never reached:" +++
concat (intersperse ", " (map prt ps))) (return ())
---- AR 6/4/2009: this would be the best but checkWarn doesn't show because of laziness (?)
---- else checkWarn $ "patterns never reached:" +++
---- concat (intersperse ", " (map prt ps))
else checkWarn (text "patterns never reached:" $$
nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
_ -> return () -- happens with variable types
cs' <- mapM (checkCase arg val) cs
return (T (TTyped arg) cs', typ)
_ -> raise $ "table type expected for table instead of" +++ prtType env typ
_ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType env typ)
R r -> case typ of --- why needed? because inference may be too difficult
RecType rr -> do
@@ -808,7 +719,7 @@ checkLType env trm typ0 = do
fsts <- mapM (checkM r) rr -- check that they are found in the record
return $ (R fsts, typ) -- normalize record
_ -> prtFail "record type expected in type checking instead of" typ
_ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
ExtR r s -> case typ of
_ | typ == typeType -> do
@@ -817,7 +728,7 @@ checkLType env trm typ0 = do
RecType _ -> termWith trm $ return typeType
ExtR (Vr _) (RecType _) -> termWith trm $ return typeType
-- ext t = t ** ...
_ -> prtFail "invalid record type extension" trm
_ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
RecType rr -> do
(r',ty,s') <- checks [
do (r',ty) <- infer r
@@ -832,15 +743,15 @@ checkLType env trm typ0 = do
r2 <- justCheck r' rr0
s2 <- justCheck s' rr2
return $ (ExtR r2 s2, typ)
_ -> raise ("record type expected in extension of" +++ prt r +++
"but found" +++ prt ty)
_ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$
text "but found" <+> ppTerm Unqualified 0 ty)
ExtR ty ex -> do
r' <- justCheck r ty
s' <- justCheck s ex
return $ (ExtR r' s', typ) --- is this all?
_ -> prtFail "record extension not meaningful for" typ
_ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
FV vs -> do
ttys <- mapM (flip check typ) vs
@@ -855,8 +766,7 @@ checkLType env trm typ0 = do
(arg',val) <- check arg p
checkEq typ t trm
return (S tab' arg', t)
_ -> raise $ "table type expected for applied table instead of" +++
prtType env ty'
_ -> checkError (text "table type expected for applied table instead of" <+> ppType env ty')
, do
(arg',ty) <- infer arg
ty' <- comp ty
@@ -903,14 +813,12 @@ checkLType env trm typ0 = do
Just (_,t) -> do
(t',ty') <- check t ty
return (l,(Just ty',t'))
_ -> raise $
if isLockLabel l
then
let cat = drop 5 (prt l) in
prt_ (R rms) +++ "is not in the lincat of" +++ cat ++
"; try wrapping it with lin " ++ cat
else
"cannot find value for label" +++ prt l +++ "in" +++ prt_ (R rms)
_ -> checkError $
if isLockLabel l
then let cat = drop 5 (showIdent (label2ident l))
in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <>
text "; try wrapping it with lin" <+> text cat
else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms)
checkCase arg val (p,t) = do
cont <- pattContext env arg p
@@ -925,7 +833,7 @@ pattContext env typ p = case p of
PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- checkErr $ lookupResType cnc q c
(cont,v) <- checkErr $ typeFormCnc t
checkCond ("wrong number of arguments for constructor in" +++ prt p)
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
(length cont == length ps)
checkEqLType env typ v (patt2term p)
mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat
@@ -936,7 +844,7 @@ pattContext env typ p = case p of
let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
----- checkWarn $ prt p ++++ show pts ----- debug
mapM (uncurry (pattContext env)) pts >>= return . concat
_ -> prtFail "record type expected for pattern instead of" typ'
_ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
PT t p' -> do
checkEqLType env typ t (patt2term p')
pattContext env typ p'
@@ -948,11 +856,11 @@ pattContext env typ p = case p of
PAlt p' q -> do
g1 <- pattContext env typ p'
g2 <- pattContext env typ q
let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1]
let pts = nub ([fst pt | pt <- g1, notElem pt g2] ++ [fst pt | pt <- g2, notElem pt g1])
checkCond
("incompatible bindings of" +++
unwords (nub (map (prt . fst) pts))+++
"in pattern alterantives" +++ prt p) (null pts)
(text "incompatible bindings of" <+>
fsep (map ppIdent pts) <+>
text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
return g1 -- must be g1 == g2
PSeq p q -> do
g1 <- pattContext env typ p
@@ -967,7 +875,7 @@ pattContext env typ p = case p of
noBind typ p' = do
co <- pattContext env typ p'
if not (null co)
then checkWarn ("no variable bound inside pattern" +++ prt p)
then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
>> return []
else return []
@@ -999,9 +907,9 @@ checkEqLType env t u trm = do
(b,t',u',s) <- checkIfEqLType env t u trm
case b of
True -> return t'
False -> raise $ s +++ "type of" +++ prt trm +++
": expected:" +++ prtType env t ++++
"inferred:" +++ prtType env u
False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$
text "expected:" <+> ppType env t $$
text "inferred:" <+> ppType env u
checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
checkIfEqLType env t u trm = do
@@ -1013,7 +921,7 @@ checkIfEqLType env t u trm = do
--- better: use a flag to forgive? (AR 31/1/2006)
_ -> case missingLock [] t' u' of
Ok lo -> do
checkWarn $ "missing lock field" +++ unwords (map prt lo)
checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo)
return (True,t',u',[])
Bad s -> return (False,t',u',s)
@@ -1066,7 +974,7 @@ checkIfEqLType env t u trm = do
not (any (\ (k,b) -> alpha g a b && l == k) ts)]
(locks,others) = partition isLockLabel ls
in case others of
_:_ -> Bad $ "missing record fields" +++ unwords (map prt others)
_:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others))
_ -> return locks
-- contravariance
(Prod x a b, Prod y c d) -> do
@@ -1079,24 +987,15 @@ checkIfEqLType env t u trm = do
sTypes = [typeStr, typeTok, typeString]
comp = computeLType env
-- if prtType is misleading, print the full type
prtTypeF :: LTEnv -> Type -> Type -> String
prtTypeF env exp ty =
let pty = prtType env ty
in if pty == prtType env exp then prt ty else pty
-- printing a type with a lock field lock_C as C
prtType :: LTEnv -> Type -> String
prtType env ty = case ty of
RecType fs -> case filter isLockLabel $ map fst fs of
[lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty
_ -> prtt ty
Prod x a b -> prtType env a +++ "->" +++ prtType env b
_ -> prtt ty
where
prtt t = prt t
---- use computeLType gr to check if really equal to the cat with lock
ppType :: LTEnv -> Type -> Doc
ppType env ty =
case ty of
RecType fs -> case filter isLockLabel $ map fst fs of
[lock] -> text (drop 5 (showIdent (label2ident lock)))
_ -> ppTerm Unqualified 0 ty
Prod x a b -> ppType env a <+> text "->" <+> ppType env b
_ -> ppTerm Unqualified 0 ty
-- | linearization types and defaults
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
@@ -1111,8 +1010,11 @@ linTypeOfType cnc m typ = do
let vars = mkRecType varLabel $ replicate n typeStr
symb = argIdent n cat i
rec <- if n==0 then return val else
checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $
plusRecType vars val
checkErr $ errIn (render (text "extending" $$
nest 2 (ppTerm Unqualified 0 vars) $$
text "with" $$
nest 2 (ppTerm Unqualified 0 val))) $
plusRecType vars val
return (symb,rec)
lookLin (_,c) = checks [ --- rather: update with defLinType ?
checkErr (lookupLincat cnc m c) >>= computeLType cnc
@@ -1148,5 +1050,5 @@ topoSortOpers st = do
let eops = topoTest st
either
return
(\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops))))
(\ops -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head ops)))))
eops

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

@@ -38,7 +38,7 @@ traceD s t = t
-- the main function: generate PGF from GF.
mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF)
mkCanon2gfcc opts cnc gr =
(prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr)
(showIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr)
where
abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc)
pars = mkParamLincat gr

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

@@ -198,7 +198,7 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
depInst (m,n) xs = modName m:modName n:xs
modName = prIdent
modName = showIdent
-- | options can be passed to the compiler by comments in @--#@, in the main file
getOptionsFromFile :: FilePath -> IOE Options

8
src/GF/Compile/Update.hs
View File

@@ -58,7 +58,7 @@ extendModule gr (name,m)
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) (mtype mo))
("illegal extension type to module" +++ prIdent name)
("illegal extension type to module" +++ showIdent name)
let isCompl = isCompleteModule m0
@@ -86,12 +86,12 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
-- add the information given in interface into an instance module
Nothing -> do
testErr (null is || mstatus mi == MSIncomplete)
("module" +++ prIdent i +++
("module" +++ showIdent i +++
"has open interfaces and must therefore be declared incomplete")
case mt of
MTInstance i0 -> do
m1 <- lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ prIdent i0)
testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0)
js' <- extendMod gr False (i0,const True) i (jments m1) (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of
@@ -110,7 +110,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ prIdent i +++ "remains incomplete")
("module" +++ showIdent i +++ "remains incomplete")
ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext
let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already