Merge pull request #118 from GrammaticalFramework/canonical

Fixes to canonical compilation

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -7,7 +7,7 @@ import GF.Text.Pretty
 --import GF.Grammar.Predef(cPredef,cInts)
 --import GF.Compile.Compute.Predef(predef)
 --import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
+import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
 import GF.Infra.Option
 import GF.Haskell as H
 import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
      | let Grammar abstr cncs = grammar2canonical opts absname gr,
        cncmod<-cncs,
        let ModId name = concName cncmod
-           filename = name ++ ".hs" :: FilePath
+           filename = showRawIdent name ++ ".hs" :: FilePath
   ]
 
 -- | Generate Haskell code for the given concrete module.
@@ -53,7 +53,7 @@ concrete2haskell opts
     labels = S.difference (S.unions (map S.fromList recs)) common_labels
     common_records = S.fromList [[label_s]]
     common_labels = S.fromList [label_s]
-    label_s = LabelId "s"
+    label_s = LabelId (rawIdentS "s")
 
     signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
       where
@@ -69,7 +69,7 @@ concrete2haskell opts
       where
      --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
        allcats = S.fromList [c | CatDef c _<-cats]
-      
+
     gId :: ToIdent i => i -> Ident
     gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
           . toIdent
@@ -116,7 +116,7 @@ concrete2haskell opts
               where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
             StrType -> tcon0 (identS "Str")
             TableType pt lt -> Fun (ppT pt) (ppT lt)
---          TupleType lts -> 
+--          TupleType lts ->
 
     lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
 
@@ -126,7 +126,7 @@ concrete2haskell opts
     linDefs = map eqn . sortOn fst . map linDef
       where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
 
-    linDef (LinDef f xs rhs0) = 
+    linDef (LinDef f xs rhs0) =
         (cat,(linfunName cat,(lhs,rhs)))
       where
         lhs = [ConP (aId f) (map VarP abs_args)]
@@ -144,7 +144,7 @@ concrete2haskell opts
           where
             vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
             env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
-            
+
         letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
           (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
 
@@ -187,7 +187,7 @@ concrete2haskell opts
 
         pId p@(ParamId s) =
           if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
-          
+
         table cs =
             if all (null.patVars) ps
             then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
@@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where
 
 -- | Record subtyping is converted into explicit coercions in Haskell
 coerce env ty t =
-  case (ty,t) of 
+  case (ty,t) of
     (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
     (TableType ti tv,TableValue _ cs) ->
       TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
     (RecordType rt,RecordValue r) ->
       RecordValue [RecordRow l (coerce env ft f) |
-                     RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
+                     RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
     (RecordType rt,VarValue x)->
       case lookup x env of
         Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
@@ -334,18 +334,17 @@ coerce env ty t =
     _ -> t
   where
     app f ts = ParamConstant (Param f ts) -- !! a hack
-    to_rcon = ParamId . Unqual . to_rcon' . labels
+    to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
 
 patVars p = []
 
-labels r = [l|RecordRow l _<-r]
+labels r = [l | RecordRow l _ <- r]
 
 proj = Var . identS . proj'
-proj' (LabelId l) = "proj_"++l
+proj' (LabelId l) = "proj_" ++ showRawIdent l
 rcon = Var . rcon'
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
-
 to_rcon' = ("to_"++) . rcon_name
 
 recordType ls =
@@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
 
 class ToIdent i where toIdent :: i -> Ident
 
-instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
-instance ToIdent PredefId where toIdent (PredefId s) = identS s
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
-instance ToIdent CatId   where toIdent (CatId s) = identS s
+instance ToIdent CatId   where toIdent (CatId s) = identC s
-instance ToIdent C.FunId where toIdent (FunId s) = identS s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
-instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
 
-qIdentS = identS . unqual
+qIdentC = identS . unqual
 
-unqual (Qual (ModId m) n) = m++"_"++n
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
-unqual (Unqual n) = n
+unqual (Unqual n) = showRawIdent n
 
 instance ToIdent VarId where
   toIdent Anonymous = identW
-  toIdent (VarId s) = identS s
+  toIdent (VarId s) = identC s

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -6,30 +6,35 @@ module GF.Compile.GrammarToCanonical(
        ) where
 import Data.List(nub,partition)
 import qualified Data.Map as M
+import Data.Maybe(fromMaybe)
 import qualified Data.Set as S
 import GF.Data.ErrM
 import GF.Text.Pretty
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar as G
 import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
+import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
-import GF.Infra.Option(optionsPGF)
+import GF.Infra.Option(Options,optionsPGF)
 import PGF.Internal(Literal(..))
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
-import Debug.Trace
+import System.FilePath ((</>), (<.>))
+import qualified Debug.Trace as T
+
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
 grammar2canonical opts absname gr =
    Grammar (abstract2canonical absname gr)
            (map snd (concretes2canonical opts absname gr))
 
 -- | Generate Canonical code for the named abstract syntax
+abstract2canonical :: ModuleName -> G.Grammar -> Abstract
 abstract2canonical absname gr =
     Abstract (modId absname) (convFlags gr absname) cats funs
   where
@@ -44,6 +49,7 @@ abstract2canonical absname gr =
     convHypo (bt,name,t) =
       case typeForm t of
         ([],(_,cat),[]) -> gId cat -- !!
+        tf -> error $ "abstract2canonical convHypo: " ++ show tf
 
     convType t =
       case typeForm t of
@@ -54,25 +60,26 @@ abstract2canonical absname gr =
 
     convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
 
-
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
+concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
 concretes2canonical opts absname gr =
   [(cncname,concrete2canonical gr cenv absname cnc cncmod)
      | let cenv = resourceValues opts gr,
        cnc<-allConcretes gr absname,
-       let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
+       let cncname = "canonical" </> render cnc <.> "gf"
            Ok cncmod = lookupModule gr cnc
   ]
 
 -- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
 concrete2canonical gr cenv absname cnc modinfo =
   Concrete (modId cnc) (modId absname) (convFlags gr cnc)
       (neededParamTypes S.empty (params defs))
-      [lincat|(_,Left lincat)<-defs]
+      [lincat | (_,Left lincat) <- defs]
-      [lin|(_,Right lin)<-defs]
+      [lin | (_,Right lin) <- defs]
   where
-    defs = concatMap (toCanonical gr absname cenv) . 
+    defs = concatMap (toCanonical gr absname cenv) .
            M.toList $
            jments modinfo
 
@@ -85,6 +92,7 @@ concrete2canonical gr cenv absname cnc modinfo =
         else let ((got,need),def) = paramType gr q
              in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
+toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
 toCanonical gr absname cenv (name,jment) =
   case jment of
     CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -97,7 +105,8 @@ toCanonical gr absname cenv (name,jment) =
       where
         tts = tableTypes gr [e']
 
-        e' = unAbs (length params) $
+        e' = cleanupRecordFields lincat $
+             unAbs (length params) $
              nf loc (mkAbs params (mkApp def (map Vr args)))
         params = [(b,x)|(b,x,_)<-ctx]
         args = map snd params
@@ -108,12 +117,12 @@ toCanonical gr absname cenv (name,jment) =
     _ -> []
   where
     nf loc = normalForm cenv (L loc name)
---  aId n = prefixIdent "A." (gId n)
 
     unAbs 0 t = t
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t
 
+tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
 tableTypes gr ts = S.unions (map tabtys ts)
   where
     tabtys t =
@@ -122,6 +131,7 @@ tableTypes gr ts = S.unions (map tabtys ts)
         T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
         _ -> collectOp tabtys t
 
+paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
 paramTypes gr t =
   case t of
     RecType fs -> S.unions (map (paramTypes gr.snd) fs)
@@ -140,11 +150,26 @@ paramTypes gr t =
                  Ok (_,ResParam {}) -> S.singleton q
                  _ -> ignore
 
-    ignore = trace ("Ignore: "++show t) S.empty
+    ignore = T.trace ("Ignore: " ++ show t) S.empty
 
+-- | Filter out record fields from definitions which don't appear in lincat.
+cleanupRecordFields :: G.Type -> Term -> Term
+cleanupRecordFields (RecType ls) (R as) =
+  let defnFields = M.fromList ls
+  in R
+      [ (lbl, (mty, t'))
+      | (lbl, (mty, t)) <- as
+      , M.member lbl defnFields
+      , let Just ty = M.lookup lbl defnFields
+      , let t' = cleanupRecordFields ty t
+      ]
+cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
+cleanupRecordFields _ t = t
 
+convert :: G.Grammar -> Term -> LinValue
 convert gr = convert' gr []
 
+convert' :: G.Grammar -> [Ident] -> Term -> LinValue
 convert' gr vs = ppT
   where
     ppT0 = convert' gr vs
@@ -162,20 +187,20 @@ convert' gr vs = ppT
         S t p -> selection (ppT t) (ppT p)
         C t1 t2 -> concatValue (ppT t1) (ppT t2)
         App f a -> ap (ppT f) (ppT a)
-        R r -> RecordValue (fields r)
+        R r -> RecordValue (fields (sortRec r))
         P t l -> projection (ppT t) (lblId l)
         Vr x -> VarValue (gId x)
         Cn x -> VarValue (gId x) -- hmm
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
         EInt n -> LiteralValue (IntConstant n)
-        Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
-        QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
+        QC (m,n) -> ParamConstant (Param (gQId m n) [])
         K s -> LiteralValue (StrConstant s)
         Empty -> LiteralValue (StrConstant "")
         FV ts -> VariantValue (map ppT ts)
         Alts t' vs -> alts vs (ppT t')
-        _ -> error $ "convert' "++show t
+        _ -> error $ "convert' ppT: " ++ show t
 
     ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
@@ -188,12 +213,12 @@ convert' gr vs = ppT
         Ok ALL_CAPIT  -> p "ALL_CAPIT"
         _ -> VarValue (gQId cPredef n) -- hmm
       where
-       p = PredefValue . PredefId
+       p = PredefValue . PredefId . rawIdentS
-      
+
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
-        PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
+        PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
         PR r -> RecordPattern (fields r) {-
         PW -> WildPattern
         PV x -> VarP x
@@ -202,6 +227,7 @@ convert' gr vs = ppT
         PFloat x -> Lit (show x)
         PT _ p -> ppP p
         PAs x p -> AsP x (ppP p) -}
+        _ -> error $ "convert' ppP: " ++ show p
       where
         fields = map field . filter (not.isLockLabel.fst)
         field (l,p) = RecordRow (lblId l) (ppP p)
@@ -218,12 +244,12 @@ convert' gr vs = ppT
         pre Empty = [""]  -- Empty == K ""
         pre (Strs ts) = concatMap pre ts
         pre (EPatt p) = pat p
-        pre t = error $ "pre "++show t
+        pre t = error $ "convert' alts pre: " ++ show t
 
         pat (PString s) = [s]
         pat (PAlt p1 p2) = pat p1++pat p2
         pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
-        pat p = error $ "pat "++show p
+        pat p = error $ "convert' alts pat: "++show p
 
     fields = map field . filter (not.isLockLabel.fst)
     field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -236,6 +262,7 @@ convert' gr vs = ppT
                  ParamConstant (Param p (ps++[a]))
                _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
 
+concatValue :: LinValue -> LinValue -> LinValue
 concatValue v1 v2 =
   case (v1,v2) of
     (LiteralValue (StrConstant ""),_) -> v2
@@ -243,21 +270,24 @@ concatValue v1 v2 =
     _ -> ConcatValue v1 v2
 
 -- | Smart constructor for projections
-projection r l = maybe (Projection r l) id (proj r l)
+projection :: LinValue -> LabelId -> LinValue
+projection r l = fromMaybe (Projection r l) (proj r l)
 
+proj :: LinValue -> LabelId -> Maybe LinValue
 proj r l =
   case r of
-    RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
+    RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
                           [v] -> Just v
                           _ -> Nothing
     _ -> Nothing
 
 -- | Smart constructor for selections
+selection :: LinValue -> LinValue -> LinValue
 selection t v =
   -- Note: impossible cases can become possible after grammar transformation
   case t of
     TableValue tt r ->
-        case nub [rv|TableRow _ rv<-keep] of
+        case nub [rv | TableRow _ rv <- keep] of
           [rv] -> rv
           _ -> Selection (TableValue tt r') v
       where
@@ -276,13 +306,16 @@ selection t v =
         (keep,discard) = partition (mightMatchRow v) r
     _ -> Selection t v
 
+impossible :: LinValue -> LinValue
 impossible = CommentedValue "impossible"
 
+mightMatchRow :: LinValue -> TableRow rhs -> Bool
 mightMatchRow v (TableRow p _) =
   case p of
     WildPattern -> True
     _ -> mightMatch v p
 
+mightMatch :: LinValue -> LinPattern -> Bool
 mightMatch v p =
   case v of
     ConcatValue _ _ -> False
@@ -294,16 +327,18 @@ mightMatch v p =
     RecordValue rv ->
       case p of
         RecordPattern rp ->
-          and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
+          and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
         _ -> False
     _ -> True
 
+patVars :: Patt -> [Ident]
 patVars p =
   case p of
     PV x -> [x]
     PAs x p -> x:patVars p
     _ -> collectPattOp patVars p
 
+convType :: Term -> LinType
 convType = ppT
   where
     ppT t =
@@ -315,9 +350,9 @@ convType = ppT
         Sort k -> convSort k
 --      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
         FV (t:ts) -> ppT t -- !!
-        QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
+        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
-        Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
+        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
-        _ -> error $ "Missing case in convType for: "++show t
+        _ -> error $ "convType ppT: " ++ show t
 
     convFields = map convField . filter (not.isLockLabel.fst)
     convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -326,15 +361,20 @@ convType = ppT
                    "Float" -> FloatType
                    "Int" -> IntType
                    "Str" -> StrType
-                   _ -> error ("convSort "++show k)
+                   _ -> error $ "convType convSort: " ++ show k
 
+toParamType :: Term -> ParamType
 toParamType t = case convType t of
                   ParamType pt -> pt
-                  _ -> error ("toParamType "++show t)
+                  _ -> error $ "toParamType: " ++ show t
 
+toParamId :: Term -> ParamId
 toParamId t = case toParamType t of
                    ParamTypeId p -> p
 
+paramType :: G.Grammar
+             -> (ModuleName, Ident)
+             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
 paramType gr q@(_,n) =
     case lookupOrigInfo gr q of
       Ok (m,ResParam (Just (L _ ps)) _)
@@ -342,7 +382,7 @@ paramType gr q@(_,n) =
          ((S.singleton (m,n),argTypes ps),
           [ParamDef name (map (param m) ps)]
          )
-       where name = (gQId m n)
+       where name = gQId m n
       Ok (m,ResOper  _ (Just (L _ t)))
         | m==cPredef && n==cInts ->
            ((S.empty,S.empty),[]) {-
@@ -350,36 +390,46 @@ paramType gr q@(_,n) =
             [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
         | otherwise ->
            ((S.singleton (m,n),paramTypes gr t),
-            [ParamAliasDef ((gQId m n)) (convType t)])
+            [ParamAliasDef (gQId m n) (convType t)])
       _ -> ((S.empty,S.empty),[])
   where
-    param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
+    param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
     argTypes = S.unions . map argTypes1
     argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
 
-lblId = LabelId . render -- hmm
+lblId :: Label -> C.LabelId
-modId (MN m) = ModId (showIdent m)
+lblId (LIdent ri) = LabelId ri
+lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
 
-class FromIdent i where gId :: Ident -> i
+modId :: ModuleName -> C.ModId
+modId (MN m) = ModId (ident2raw m)
+
+class FromIdent i where
+  gId :: Ident -> i
 
 instance FromIdent VarId where
-  gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
+  gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
 
-instance FromIdent C.FunId where gId = C.FunId . showIdent
+instance FromIdent C.FunId where gId = C.FunId . ident2raw
-instance FromIdent CatId where gId = CatId . showIdent
+instance FromIdent CatId where gId = CatId . ident2raw
 instance FromIdent ParamId where gId = ParamId . unqual
 instance FromIdent VarValueId where gId = VarValueId . unqual
 
-class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
+class FromIdent i => QualIdent i where
+  gQId :: ModuleName -> Ident -> i
 
-instance QualIdent ParamId    where gQId m n = ParamId (qual m n)
+instance QualIdent ParamId where gQId m n = ParamId (qual m n)
 instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
 
-qual m n = Qual (modId m) (showIdent n)
+qual :: ModuleName -> Ident -> QualId
-unqual n = Unqual (showIdent n)
+qual m n = Qual (modId m) (ident2raw n)
 
+unqual :: Ident -> QualId
+unqual n = Unqual (ident2raw n)
+
+convFlags :: G.Grammar -> ModuleName -> Flags
 convFlags gr mn =
-  Flags [(n,convLit v) |
+  Flags [(rawIdentS n,convLit v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
   where
     convLit l =

src/compiler/GF/Grammar/Canonical.hs

@@ -11,6 +11,7 @@
 module GF.Grammar.Canonical where
 import Prelude hiding ((<>))
 import GF.Text.Pretty
+import GF.Infra.Ident (RawIdent)
 
 -- | A Complete grammar
 data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
 
 -- *** Identifiers
 
-type Id = String
+type Id = RawIdent
 data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -7,6 +7,7 @@ import Control.Applicative ((<|>))
 import Data.Ratio (denominator, numerator)
 import GF.Grammar.Canonical
 import Control.Monad (guard)
+import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
 
 
 encodeJSON :: FilePath -> Grammar -> IO ()
@@ -29,7 +30,7 @@ instance JSON Grammar where
 -- ** Abstract Syntax
 
 instance JSON Abstract where
-  showJSON (Abstract absid flags cats funs) 
+  showJSON (Abstract absid flags cats funs)
     = makeObj [("abs", showJSON absid),
                ("flags", showJSON flags),
                ("cats", showJSON cats),
@@ -81,7 +82,7 @@ instance JSON TypeBinding where
 -- ** Concrete syntax
 
 instance JSON Concrete where
-  showJSON (Concrete cncid absid flags params lincats lins) 
+  showJSON (Concrete cncid absid flags params lincats lins)
     = makeObj [("cnc", showJSON cncid),
                ("abs", showJSON absid),
                ("flags", showJSON flags),
@@ -204,12 +205,12 @@ instance JSON a => JSON (RecordRow a) where
   -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
   showJSON  row  = showJSONs [row]
   showJSONs rows = makeObj (map toRow rows)
-    where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
+    where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
 
   readJSON  obj = head <$> readJSONs obj
   readJSONs obj = mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (RecordRow (LabelId lbl) value)
+                                      return (RecordRow (LabelId (rawIdentS lbl)) value)
 
 instance JSON rhs => JSON (TableRow rhs) where
   showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
@@ -219,19 +220,19 @@ instance JSON rhs => JSON (TableRow rhs) where
 
 -- *** Identifiers in Concrete Syntax
 
-instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON 
+instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON
-instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON 
+instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON
-instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON 
+instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON
-instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON 
+instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON
-instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON 
+instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
 
 
 --------------------------------------------------------------------------------
 -- ** Used in both Abstract and Concrete Syntax
 
-instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON 
+instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
-instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON 
+instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
-instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON 
+instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
 
 instance JSON VarId where
   -- the anonymous variable is the underscore:
@@ -242,20 +243,24 @@ instance JSON VarId where
     <|>        VarId <$> readJSON o
 
 instance JSON QualId where
-  showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
+  showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
   showJSON (Unqual n) = showJSON n
 
   readJSON o = do qualid <- readJSON o
                   let (mod, id) = span (/= '.') qualid
-                  return $ if null mod then Unqual id else Qual (ModId mod) id
+                  return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
+
+instance JSON RawIdent where
+  showJSON i = showJSON $ showRawIdent i
+  readJSON o = rawIdentS <$> readJSON o
 
 instance JSON Flags where
   -- flags are encoded directly as JSON records (i.e., objects):
-  showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
+  showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
 
   readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (lbl, value)
+                                      return (rawIdentS lbl, value)
 
 instance JSON FlagValue where
   -- flag values are encoded as basic JSON types:

src/compiler/GF/Grammar/Macros.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/11 16:38:00 $ 
+-- > CVS $Date: 2005/11/11 16:38:00 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.24 $
 --
@@ -51,14 +51,14 @@ typeForm t =
     _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
 
 typeFormCnc :: Type -> (Context, Type)
-typeFormCnc t = 
+typeFormCnc t =
   case t of
     Prod b x a t -> let (x', v) = typeFormCnc t
                     in ((b,x,a):x',v)
     _            -> ([],t)
 
 valCat :: Type -> Cat
-valCat typ = 
+valCat typ =
   let (_,cat,_) = typeForm typ
   in cat
 
@@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do  -- pessimistic choice
 contextOfType :: Monad m => Type -> m Context
 contextOfType typ = case typ of
   Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
-  _            -> return [] 
+  _            -> return []
 
 termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
 termForm t = case t of
@@ -108,8 +108,8 @@ termForm t = case t of
         return ((b,x):x', fun, args)
    App c a ->
      do (_,fun, args) <- termForm c
-        return ([],fun,args ++ [a]) 
+        return ([],fun,args ++ [a])
-   _       -> 
+   _       ->
      return ([],t,[])
 
 termFormCnc :: Term -> ([(BindType,Ident)], Term)
@@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term
 mkTable tt t = foldr Table t tt
 
 mkCTable :: [(BindType,Ident)] -> Term -> Term
-mkCTable ids v = foldr ccase v ids where 
+mkCTable ids v = foldr ccase v ids where
   ccase (_,x) t = T TRaw [(PV x,t)]
 
 mkHypo :: Term -> Hypo
@@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of
     filter (`elem` (map fst r1)) (map fst r2) of
       [] -> return (RecType (r1 ++ r2))
       ls -> raise $ render ("clashing labels" <+> hsep ls)
-  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) 
+  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
 
 --plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
@@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel,  typeStr)]
 
 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident
-mkFreshVar olds = varX (maxVarIndex olds + 1) 
+mkFreshVar olds = varX (maxVarIndex olds + 1)
 
 -- | trying to preserve a given symbol
 mkFreshVarX :: [Ident] -> Ident -> Ident
@@ -313,7 +313,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
 maxVarIndex :: [Ident] -> Int
 maxVarIndex = maximum . ((-1):) . map varIndex
 
-mkFreshVars :: Int -> [Ident] -> [Ident] 
+mkFreshVars :: Int -> [Ident] -> [Ident]
 mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
 
 -- | quick hack for refining with var in editor
@@ -413,11 +413,11 @@ patt2term pt = case pt of
   PC c pp   -> mkApp (Con c) (map patt2term pp)
   PP c pp   -> mkApp (QC  c) (map patt2term pp)
 
-  PR r      -> R [assign l (patt2term p) | (l,p) <- r] 
+  PR r      -> R [assign l (patt2term p) | (l,p) <- r]
   PT _ p    -> patt2term p
   PInt i    -> EInt i
   PFloat i  -> EFloat i
-  PString s -> K s 
+  PString s -> K s
 
   PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
   PChar     -> appCons cChar  []                             --- an encoding
@@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op)
 
 -- | to define compositional term functions
 composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp co trm = 
+composOp co trm =
  case trm of
    App c a          -> liftM2 App (co c) (co a)
    Abs b x t        -> liftM (Abs b x) (co t)
@@ -552,13 +552,13 @@ strsFromTerm t = case t of
     v0 <- mapM (strsFromTerm . fst) vs
     c0 <- mapM (strsFromTerm . snd) vs
   --let vs' = zip v0 c0
-    return [strTok (str2strings def) vars | 
+    return [strTok (str2strings def) vars |
               def  <- d0,
-              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
                                                           vv <- sequence v0]
            ]
   FV ts -> mapM strsFromTerm ts >>= return . concat
-  Strs ts -> mapM strsFromTerm ts >>= return . concat  
+  Strs ts -> mapM strsFromTerm ts >>= return . concat
   _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
 
 getTableType :: TInfo -> Err Type
@@ -590,11 +590,11 @@ noExist = FV []
 defaultLinType :: Type
 defaultLinType = mkRecType linLabel [typeStr]
 
--- normalize records and record types; put s first
+-- | normalize records and record types; put s first
 
 sortRec :: [(Label,a)] -> [(Label,a)]
 sortRec = sortBy ordLabel where
-  ordLabel (r1,_) (r2,_) = 
+  ordLabel (r1,_) (r2,_) =
     case (showIdent (label2ident r1), showIdent (label2ident r2)) of
       ("s",_) -> LT
       (_,"s") -> GT
@@ -605,7 +605,7 @@ sortRec = sortBy ordLabel where
 -- | dependency check, detecting circularities and returning topo-sorted list
 
 allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
-allDependencies ism b = 
+allDependencies ism b =
   [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
   where
     opersIn t = case t of

src/compiler/GF/Infra/Ident.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/15 11:43:33 $ 
+-- > CVS $Date: 2005/11/15 11:43:33 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.8 $
 --
@@ -13,18 +13,18 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- ** Identifiers
-              ModuleName(..), moduleNameS,
+  ModuleName(..), moduleNameS,
-	      Ident, ident2utf8, showIdent, prefixIdent,
+  Ident, ident2utf8, showIdent, prefixIdent,
-              -- *** Normal identifiers (returned by the parser)
+  -- *** Normal identifiers (returned by the parser)
-	      identS, identC, identW,
+  identS, identC, identW,
-              -- *** Special identifiers for internal use
+  -- *** Special identifiers for internal use
-              identV, identA, identAV,
+  identV, identA, identAV,
-	      argIdent, isArgIdent, getArgIndex,
+  argIdent, isArgIdent, getArgIndex,
-              varStr, varX, isWildIdent, varIndex,
+  varStr, varX, isWildIdent, varIndex,
-              -- *** Raw identifiers
+  -- *** Raw identifiers
-              RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-              isPrefixOf, showRawIdent
+  isPrefixOf, showRawIdent
-	     ) where
+) where
 
 import qualified Data.ByteString.UTF8 as UTF8
 import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m
 
 -- | the constructors labelled /INTERNAL/ are
 -- internal representation never returned by the parser
-data Ident = 
+data Ident =
    IC  {-# UNPACK #-} !RawIdent                                           -- ^ raw identifier after parsing, resolved in Rename
  | IW                                                                     -- ^ wildcard
 --
@@ -54,7 +54,7 @@ data Ident =
  | IV  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ variable
  | IA  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ argument of cat at position
  | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int   -- ^ /INTERNAL/ argument of cat with bindings at position
--- 
+--
   deriving (Eq, Ord, Show, Read)
 
 -- | Identifiers are stored as UTF-8-encoded bytestrings.
@@ -70,14 +70,13 @@ rawIdentS = Id . pack
 rawIdentC = Id
 showRawIdent = unpack . rawId2utf8
 
-prefixRawIdent (Id x) (Id y) = Id (BS.append x y) 
+prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
 isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
 
 instance Binary RawIdent where
   put = put . rawId2utf8
   get = fmap rawIdentC get
 
-
 -- | This function should be used with care, since the returned ByteString is
 -- UTF-8-encoded.
 ident2utf8 :: Ident -> UTF8.ByteString
@@ -88,6 +87,7 @@ ident2utf8 i = case i of
   IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
   IW -> pack "_"
 
+ident2raw :: Ident -> RawIdent
 ident2raw = Id . ident2utf8
 
 showIdent :: Ident -> String
@@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i
 
 instance Pretty Ident where pp = pp . showIdent
 
+instance Pretty RawIdent where pp = pp . showRawIdent
+
 identS :: String -> Ident
 identS = identC . rawIdentS
 
 identC :: RawIdent -> Ident
 identW :: Ident
 
-
 prefixIdent :: String -> Ident -> Ident
 prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
 
@@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident
 identA :: RawIdent -> Int -> Ident
 identAV:: RawIdent -> Int -> Int -> Ident
 
-(identC, identV, identA, identAV, identW) = 
+(identC, identV, identA, identAV, identW) =
     (IC,     IV,     IA,     IAV,     IW)
 
 -- | to mark argument variables

testsuite/canonical/.gitignore

@@ -0,0 +1 @@
+canonical/

testsuite/canonical/gold/FoodsFin.gf

@@ -0,0 +1,102 @@
+concrete FoodsFin of Foods = {
+param ParamX_Number = ParamX_Sg | ParamX_Pl;
+param Prelude_Bool = Prelude_False | Prelude_True;
+param ResFin_Agr = ResFin_Ag ParamX_Number ParamX_Person | ResFin_AgPol;
+param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
+param ResFin_Harmony = ResFin_Back | ResFin_Front;
+param ResFin_NForm =
+    ResFin_NCase ParamX_Number ResFin_Case | ResFin_NComit | ResFin_NInstruct |
+    ResFin_NPossNom ParamX_Number | ResFin_NPossGen ParamX_Number |
+    ResFin_NPossTransl ParamX_Number | ResFin_NPossIllat ParamX_Number |
+    ResFin_NCompound;
+param ResFin_Case =
+    ResFin_Nom | ResFin_Gen | ResFin_Part | ResFin_Transl | ResFin_Ess |
+    ResFin_Iness | ResFin_Elat | ResFin_Illat | ResFin_Adess | ResFin_Ablat |
+    ResFin_Allat | ResFin_Abess;
+param ResFin_NPForm = ResFin_NPCase ResFin_Case | ResFin_NPAcc | ResFin_NPSep;
+lincat Comment = {s : Str};
+       Item =
+           {s : ResFin_NPForm => Str; a : ResFin_Agr; isNeg : Prelude_Bool;
+            isPron : Prelude_Bool};
+       Kind =
+           {s : ResFin_NForm => Str; h : ResFin_Harmony;
+            postmod : ParamX_Number => Str};
+       Quality =
+           {s : Prelude_Bool => ResFin_NForm => Str; hasPrefix : Prelude_Bool;
+            p : Str};
+lin Expensive =
+        {s =
+           table {Prelude_False =>
+                    table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
+                           ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
+                           ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
+                           ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
+                           ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
+                           ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
+                           ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
+                           ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
+                           ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
+                           ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
+                           ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
+                           ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
+                           ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
+                           ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
+                           ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
+                           ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
+                           ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
+                           ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
+                           ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
+                           ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
+                           ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
+                           ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
+                           ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
+                           ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
+                           ResFin_NComit => "kalliine";
+                           ResFin_NInstruct => "kalliin";
+                           ResFin_NPossNom ParamX_Sg => "kallii";
+                           ResFin_NPossNom ParamX_Pl => "kallii";
+                           ResFin_NPossGen ParamX_Sg => "kallii";
+                           ResFin_NPossGen ParamX_Pl => "kalliide";
+                           ResFin_NPossTransl ParamX_Sg => "kalliikse";
+                           ResFin_NPossTransl ParamX_Pl => "kalliikse";
+                           ResFin_NPossIllat ParamX_Sg => "kalliisee";
+                           ResFin_NPossIllat ParamX_Pl => "kalliisii";
+                           ResFin_NCompound => "kallis"};
+                  Prelude_True =>
+                    table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
+                           ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
+                           ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
+                           ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
+                           ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
+                           ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
+                           ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
+                           ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
+                           ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
+                           ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
+                           ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
+                           ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
+                           ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
+                           ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
+                           ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
+                           ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
+                           ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
+                           ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
+                           ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
+                           ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
+                           ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
+                           ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
+                           ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
+                           ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
+                           ResFin_NComit => "kalliine";
+                           ResFin_NInstruct => "kalliin";
+                           ResFin_NPossNom ParamX_Sg => "kallii";
+                           ResFin_NPossNom ParamX_Pl => "kallii";
+                           ResFin_NPossGen ParamX_Sg => "kallii";
+                           ResFin_NPossGen ParamX_Pl => "kalliide";
+                           ResFin_NPossTransl ParamX_Sg => "kalliikse";
+                           ResFin_NPossTransl ParamX_Pl => "kalliikse";
+                           ResFin_NPossIllat ParamX_Sg => "kalliisee";
+                           ResFin_NPossIllat ParamX_Pl => "kalliisii";
+                           ResFin_NCompound => "kallis"}};
+         hasPrefix = Prelude_False; p = ""};
+}

testsuite/canonical/gold/PhrasebookBul.gf

@@ -0,0 +1,29 @@
+concrete PhrasebookBul of Phrasebook = {
+param Prelude_Bool = Prelude_False | Prelude_True;
+param ResBul_AGender = ResBul_AMasc ResBul_Animacy | ResBul_AFem | ResBul_ANeut;
+param ResBul_Animacy = ResBul_Human | ResBul_NonHuman;
+param ResBul_Case = ResBul_Acc | ResBul_Dat | ResBul_WithPrep | ResBul_CPrep;
+param ResBul_NForm =
+    ResBul_NF ParamX_Number ResBul_Species | ResBul_NFSgDefNom |
+    ResBul_NFPlCount | ResBul_NFVocative;
+param ParamX_Number = ParamX_Sg | ParamX_Pl;
+param ResBul_Species = ResBul_Indef | ResBul_Def;
+lincat PlaceKind =
+           {at : {s : Str; c : ResBul_Case}; isPl : Prelude_Bool;
+            name : {s : ResBul_NForm => Str; g : ResBul_AGender};
+            to : {s : Str; c : ResBul_Case}};
+       VerbPhrase = {s : Str};
+lin Airport =
+        {at = {s = "на"; c = ResBul_Acc}; isPl = Prelude_False;
+         name =
+           {s =
+              table {ResBul_NF ParamX_Sg ResBul_Indef => "летище";
+                     ResBul_NF ParamX_Sg ResBul_Def => "летището";
+                     ResBul_NF ParamX_Pl ResBul_Indef => "летища";
+                     ResBul_NF ParamX_Pl ResBul_Def => "летищата";
+                     ResBul_NFSgDefNom => "летището";
+                     ResBul_NFPlCount => "летища";
+                     ResBul_NFVocative => "летище"};
+            g = ResBul_ANeut};
+         to = {s = "до"; c = ResBul_CPrep}};
+}

testsuite/canonical/gold/PhrasebookGer.gf

@@ -0,0 +1,251 @@
+concrete PhrasebookGer of Phrasebook = {
+param Prelude_Bool = Prelude_False | Prelude_True;
+param ResGer_Agr = ResGer_Ag ResGer_Gender ParamX_Number ParamX_Person;
+param ParamX_Number = ParamX_Sg | ParamX_Pl;
+param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
+param ResGer_Gender = ResGer_Masc | ResGer_Fem | ResGer_Neutr;
+param ResGer_Control = ResGer_SubjC | ResGer_ObjC | ResGer_NoC;
+param ResGer_PCase = ResGer_NPC ResGer_Case | ResGer_NPP ResGer_CPrep;
+param ResGer_CPrep =
+    ResGer_CAnDat | ResGer_CInAcc | ResGer_CInDat | ResGer_CZuDat |
+    ResGer_CVonDat;
+param ResGer_Case = ResGer_Nom | ResGer_Acc | ResGer_Dat | ResGer_Gen;
+param ResGer_VAux = ResGer_VHaben | ResGer_VSein;
+param ResGer_VForm =
+    ResGer_VInf Prelude_Bool | ResGer_VFin Prelude_Bool ResGer_VFormFin |
+    ResGer_VImper ParamX_Number | ResGer_VPresPart ResGer_AForm |
+    ResGer_VPastPart ResGer_AForm;
+param ResGer_AForm = ResGer_APred | ResGer_AMod ResGer_GenNum ResGer_Case;
+param ResGer_GenNum = ResGer_GSg ResGer_Gender | ResGer_GPl;
+param ResGer_VFormFin =
+    ResGer_VPresInd ParamX_Number ParamX_Person |
+    ResGer_VPresSubj ParamX_Number ParamX_Person;
+param ResGer_VType = ResGer_VAct | ResGer_VRefl ResGer_Case;
+lincat PlaceKind = {s : Str};
+       VerbPhrase =
+           {s :
+              {s : ResGer_VForm => Str; aux : ResGer_VAux; particle : Str;
+               prefix : Str; vtype : ResGer_VType};
+            a1 : Str; a2 : Str; adj : Str; ext : Str;
+            inf : {s : Str; ctrl : ResGer_Control; isAux : Prelude_Bool};
+            infExt : Str; isAux : Prelude_Bool;
+            nn :
+              ResGer_Agr =>
+              {p1 : Str; p2 : Str; p3 : Str; p4 : Str; p5 : Str; p6 : Str};
+            subjc :
+              {s : Str; c : ResGer_PCase; isPrep : Prelude_Bool; s2 : Str}};
+lin VRead =
+        {s =
+           {s =
+              table {ResGer_VInf Prelude_False => "lesen";
+                     ResGer_VInf Prelude_True => "zu" ++ "lesen";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresInd ParamX_Sg ParamX_P1) =>
+                       "lese";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresInd ParamX_Sg ParamX_P2) =>
+                       "liest";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresInd ParamX_Sg ParamX_P3) =>
+                       "liest";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresInd ParamX_Pl ParamX_P1) =>
+                       "lesen";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresInd ParamX_Pl ParamX_P2) =>
+                       "lest";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresInd ParamX_Pl ParamX_P3) =>
+                       "lesen";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
+                       "lese";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
+                       "lesest";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
+                       "lese";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
+                       "lesen";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
+                       "leset";
+                     ResGer_VFin Prelude_False
+                                 (ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
+                       "lesen";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresInd ParamX_Sg ParamX_P1) =>
+                       "lese";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresInd ParamX_Sg ParamX_P2) =>
+                       "liest";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresInd ParamX_Sg ParamX_P3) =>
+                       "liest";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresInd ParamX_Pl ParamX_P1) =>
+                       "lesen";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresInd ParamX_Pl ParamX_P2) =>
+                       "lest";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresInd ParamX_Pl ParamX_P3) =>
+                       "lesen";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
+                       "lese";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
+                       "lesest";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
+                       "lese";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
+                       "lesen";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
+                       "leset";
+                     ResGer_VFin Prelude_True
+                                 (ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
+                       "lesen";
+                     ResGer_VImper ParamX_Sg => "les";
+                     ResGer_VImper ParamX_Pl => "lest";
+                     ResGer_VPresPart ResGer_APred => "lesend";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Nom) =>
+                       "lesender";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Acc) =>
+                       "lesenden";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Dat) =>
+                       "lesendem";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Gen) =>
+                       "lesenden";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Nom) =>
+                       "lesende";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Acc) =>
+                       "lesende";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Dat) =>
+                       "lesender";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Gen) =>
+                       "lesender";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Nom) =>
+                       "lesendes";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Acc) =>
+                       "lesendes";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Dat) =>
+                       "lesendem";
+                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Gen) =>
+                       "lesenden";
+                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
+                       "lesende";
+                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
+                       "lesende";
+                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
+                       "lesenden";
+                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
+                       "lesender";
+                     ResGer_VPastPart ResGer_APred => "gelesen";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Nom) =>
+                       "gelesener";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Acc) =>
+                       "gelesenen";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Dat) =>
+                       "gelesenem";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
+                                                   ResGer_Gen) =>
+                       "gelesenen";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Nom) =>
+                       "gelesene";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Acc) =>
+                       "gelesene";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Dat) =>
+                       "gelesener";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
+                                                   ResGer_Gen) =>
+                       "gelesener";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Nom) =>
+                       "gelesenes";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Acc) =>
+                       "gelesenes";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Dat) =>
+                       "gelesenem";
+                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
+                                                   ResGer_Gen) =>
+                       "gelesenen";
+                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
+                       "gelesene";
+                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
+                       "gelesene";
+                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
+                       "gelesenen";
+                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
+                       "gelesener"};
+            aux = ResGer_VHaben; particle = ""; prefix = "";
+            vtype = ResGer_VAct};
+         a1 = ""; a2 = ""; adj = ""; ext = "";
+         inf = {s = ""; ctrl = ResGer_NoC; isAux = Prelude_True}; infExt = "";
+         isAux = Prelude_False;
+         nn =
+           table {ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P1 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P2 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P3 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P1 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P2 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P3 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P1 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P2 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P3 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P1 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P2 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P3 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P1 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P2 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P3 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P1 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P2 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
+                  ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P3 =>
+                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}};
+         subjc =
+           {s = ""; c = ResGer_NPC ResGer_Nom; isPrep = Prelude_False;
+            s2 = ""}};
+}

testsuite/canonical/grammars/Foods.gf

@@ -0,0 +1,16 @@
+-- (c) 2009 Aarne Ranta under LGPL
+
+abstract Foods = {
+  flags startcat = Comment ;
+  cat
+    Comment ; Item ; Kind ; Quality ;
+  fun
+    -- Pred : Item -> Quality -> Comment ;
+    -- This, That, These, Those : Kind -> Item ;
+    -- Mod : Quality -> Kind -> Kind ;
+    -- Wine, Cheese, Fish, Pizza : Kind ;
+    -- Very : Quality -> Quality ;
+    -- Fresh, Warm, Italian,
+    --   Expensive, Delicious, Boring : Quality ;
+    Expensive: Quality;
+}

testsuite/canonical/grammars/FoodsFin.gf

@@ -0,0 +1,6 @@
+
+-- (c) 2009 Aarne Ranta under LGPL
+
+concrete FoodsFin of Foods = FoodsI with 
+  (Syntax = SyntaxFin),
+  (LexFoods = LexFoodsFin) ;

testsuite/canonical/grammars/FoodsI.gf

@@ -0,0 +1,29 @@
+-- (c) 2009 Aarne Ranta under LGPL
+
+incomplete concrete FoodsI of Foods = 
+    open Syntax, LexFoods in {
+  lincat
+    Comment = Utt ; 
+    Item = NP ;
+    Kind = CN ;
+    Quality = AP ;
+  lin
+    Pred item quality = mkUtt (mkCl item quality) ;
+    This kind = mkNP this_Det kind ;
+    That kind = mkNP that_Det kind ;
+    These kind = mkNP these_Det kind ;
+    Those kind = mkNP those_Det kind ;
+    Mod quality kind = mkCN quality kind ;
+    Very quality = mkAP very_AdA quality ;
+
+    Wine = mkCN wine_N ;
+    Pizza = mkCN pizza_N ;
+    Cheese = mkCN cheese_N ;
+    Fish = mkCN fish_N ;
+    Fresh = mkAP fresh_A ;
+    Warm = mkAP warm_A ;
+    Italian = mkAP italian_A ;
+    Expensive = mkAP expensive_A ;
+    Delicious = mkAP delicious_A ;
+    Boring = mkAP boring_A ;
+}

testsuite/canonical/grammars/LexFoods.gf

@@ -0,0 +1,15 @@
+-- (c) 2009 Aarne Ranta under LGPL
+
+interface LexFoods = open Syntax in {
+  oper
+    wine_N : N ;
+    pizza_N : N ;
+    cheese_N : N ;
+    fish_N : N ;
+    fresh_A : A ;
+    warm_A : A ;
+    italian_A : A ;
+    expensive_A : A ;
+    delicious_A : A ;
+    boring_A : A ;
+}

testsuite/canonical/grammars/LexFoodsFin.gf

@@ -0,0 +1,21 @@
+-- (c) 2009 Aarne Ranta under LGPL
+--# -coding=latin1
+
+instance LexFoodsFin of LexFoods =
+    open SyntaxFin, ParadigmsFin in {
+  oper
+    wine_N = mkN "viini" ;
+    pizza_N = mkN "pizza" ;
+    cheese_N = mkN "juusto" ;
+    fish_N = mkN "kala" ;
+    fresh_A = mkA "tuore" ;
+    warm_A = mkA
+    (mkN "l<>mmin" "l<>mpim<69>n" "l<>mmint<6E>" "l<>mpim<69>n<EFBFBD>" "l<>mpim<69><6D>n"
+         "l<>mpimin<69>" "l<>mpimi<6D>" "l<>mpimien" "l<>mpimiss<73>" "l<>mpimiin"
+	 )
+    "l<>mpim<69>mpi" "l<>mpimin" ;
+    italian_A = mkA "italialainen" ;
+    expensive_A = mkA "kallis" ;
+    delicious_A = mkA "herkullinen" ;
+    boring_A = mkA "tyls<6C>" ;
+}

testsuite/canonical/grammars/Phrasebook.gf

@@ -0,0 +1,9 @@
+abstract Phrasebook = {
+
+cat PlaceKind ;
+fun Airport : PlaceKind ;
+
+cat VerbPhrase ;
+fun VRead : VerbPhrase ;
+
+}

testsuite/canonical/grammars/PhrasebookBul.gf

@@ -0,0 +1,31 @@
+--# -path=.:present
+
+concrete PhrasebookBul of Phrasebook =
+  open
+    SyntaxBul,
+    (R = ResBul),
+    ParadigmsBul,
+    Prelude in {
+
+  lincat
+    PlaceKind = CNPlace ;
+
+  oper
+    CNPlace : Type = {name : CN ; at : Prep ; to : Prep; isPl : Bool} ;
+
+    mkPlace : N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \n,p ->
+      mkCNPlace (mkCN n) p to_Prep ;
+
+    mkCNPlace : CN -> Prep -> Prep -> CNPlace = \p,i,t -> {
+      name = p ;
+      at = i ;
+      to = t ;
+      isPl = False
+      } ;
+
+    na_Prep = mkPrep "на" R.Acc ;
+
+  lin
+    Airport = mkPlace (mkN066 "летище") na_Prep ;
+
+}

testsuite/canonical/grammars/PhrasebookGer.gf

@@ -0,0 +1,14 @@
+--# -path=.:present
+
+concrete PhrasebookGer of Phrasebook =
+  open
+    SyntaxGer,
+    LexiconGer in {
+
+  lincat
+    VerbPhrase  = VP ;
+
+  lin
+    VRead = mkVP <lin V read_V2 : V> ;
+
+}

testsuite/canonical/run-on-grammar.sh

@@ -0,0 +1,36 @@
+#!/usr/bin/env sh
+
+# For a given grammar, compile into canonical format,
+# then ensure that the canonical format itself is compilable.
+
+if [ $# -lt 1 ]; then
+  echo "Please specify concrete modules to test with, e.g.:"
+  echo "./run-on-grammar.sh ../../../gf-contrib/foods/FoodsEng.gf  ../../../gf-contrib/foods/FoodsFin.gf"
+  exit 2
+fi
+
+FAILURES=0
+
+for CNC_PATH in "$@"; do
+  CNC_FILE=$(basename "$CNC_PATH")
+  stack run -- --batch --output-format=canonical_gf "$CNC_PATH"
+  if [ $? -ne 0 ]; then
+    echo "Failed to compile into canonical"
+    FAILURES=$((FAILURES+1))
+    continue
+  fi
+
+  stack run -- --batch "canonical/$CNC_FILE"
+  if [ $? -ne 0 ]; then
+    echo "Failed to compile canonical"
+    FAILURES=$((FAILURES+1))
+  fi
+done
+
+# Summary
+if [ $FAILURES -ne 0 ]; then
+  echo "Failures: $FAILURES"
+  exit 1
+else
+  echo "All tests passed"
+fi

testsuite/canonical/run.sh

@@ -0,0 +1,54 @@
+#!/usr/bin/env sh
+
+FAILURES=0
+
+# https://github.com/GrammaticalFramework/gf-core/issues/100
+stack run -- --batch --output-format=canonical_gf grammars/PhrasebookBul.gf
+stack run -- --batch canonical/PhrasebookBul.gf
+if [ $? -ne 0 ]; then
+  echo "Canonical grammar doesn't compile: FAIL"
+  FAILURES=$((FAILURES+1))
+else
+  # echo "Canonical grammar compiles: OK"
+  diff canonical/PhrasebookBul.gf gold/PhrasebookBul.gf
+  if [ $? -ne 0 ]; then
+    echo "Canonical grammar doesn't match gold version: FAIL"
+    FAILURES=$((FAILURES+1))
+  else
+    echo "Canonical grammar matches gold version: OK"
+  fi
+fi
+
+echo ""
+
+# https://github.com/GrammaticalFramework/gf-core/issues/101
+stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf
+diff canonical/PhrasebookGer.gf gold/PhrasebookGer.gf
+if [ $? -ne 0 ]; then
+  echo "Canonical grammar doesn't match gold version: FAIL"
+  FAILURES=$((FAILURES+1))
+else
+  echo "Canonical grammar matches gold version: OK"
+fi
+
+echo ""
+
+# https://github.com/GrammaticalFramework/gf-core/issues/102
+stack run -- --batch --output-format=canonical_gf grammars/FoodsFin.gf
+diff canonical/FoodsFin.gf gold/FoodsFin.gf
+if [ $? -ne 0 ]; then
+  echo "Canonical grammar doesn't match gold version: FAIL"
+  FAILURES=$((FAILURES+1))
+else
+  echo "Canonical grammar matches gold version: OK"
+fi
+
+echo ""
+
+# Summary
+if [ $FAILURES -ne 0 ]; then
+  echo "Failures: $FAILURES"
+  exit 1
+else
+  echo "All tests passed"
+fi