From bea6aa1d2d10669d62c1c5125dedac4cac0f8cfa Mon Sep 17 00:00:00 2001
From: Thomas Hallgren <th-github@altocumulus.org>
Date: Thu, 25 Apr 2019 17:02:42 +0200
Subject: [PATCH] =?UTF-8?q?GF.Compile.CheckGrammar:=20discard=20bad=20'lin?=
 =?UTF-8?q?cat=20C=20=3D=20=E2=80=A6'=20with=20a=20warning=20e.g.=20if=20C?=
 =?UTF-8?q?=20is=20a=20fun=20and=20not=20a=20cat=20in=20the=20abstract=20s?=
 =?UTF-8?q?yntax.=20Discarding=20bad=20lincats=20prevents=20GF=20from=20ge?=
 =?UTF-8?q?nerating=20malformed=20PGFs=20that=20are=20rejected=20by=20the?=
 =?UTF-8?q?=20C=20run-time=20system.=20I=20also=20added=20code=20to=20reje?=
 =?UTF-8?q?ct=20bad=20lincats=20with=20an=20error,=20but=20I=20left=20it?=
 =?UTF-8?q?=20commented=20out=20since=20it=20seems=20a=20bit=20pedantic=20?=
 =?UTF-8?q?compared=20to=20GF's=20otherwise=20rather=20sloppy=20grammar=20?=
 =?UTF-8?q?checking.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/compiler/GF/Compile/CheckGrammar.hs | 16 +++++++++++-----
 1 file changed, 11 insertions(+), 5 deletions(-)

diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 1348d8e41..5d6922704 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -147,11 +147,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                                            return $ updateTree (c,CncFun (Just linty) d mn mf) js
                              _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
                                            return js
-       CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
-                             Ok _ -> return $ updateTree i js
-                             _    -> do checkWarn ("category" <+> c <+> "is not in abstract")
-                                        return js
-       _                -> return $ updateTree i js
+       CncCat {} ->
+         case lookupOrigInfo gr (am,c) of
+           Ok (_,AbsCat _) -> return $ updateTree i js
+           {- -- This might be too pedantic:
+           Ok (_,AbsFun {}) ->
+                   checkError ("lincat:"<+>c<+>"is a fun, not a cat")
+           -}
+           _ -> do checkWarn ("category" <+> c <+> "is not in abstract")
+                   return js
+
+       _ -> return $ updateTree i js
 
 
 -- | General Principle: only Just-values are checked.