diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs
index 0b698e79c..c685fc525 100644
--- a/src/compiler/GF/Command/CommonCommands.hs
+++ b/src/compiler/GF/Command/CommonCommands.hs
@@ -15,6 +15,7 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
import GF.Text.Pretty
import GF.Text.Transliterations
import GF.Text.Lexing(stringOp,opInEnv)
+import Data.Char (isSpace)
import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
@@ -170,7 +171,8 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
fmap fromString $ restricted $ readFile tmpo,
-}
- fmap fromString . restricted . readShellProcess syst $ toString arg,
+ fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
+
flags = [
("command","the system command applied to the argument")
],
diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index d74fcdacd..c9f0438e6 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/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 PredefId where toIdent (PredefId s) = identS s
-instance ToIdent CatId where toIdent (CatId s) = identS s
-instance ToIdent C.FunId where toIdent (FunId s) = identS s
-instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
+instance ToIdent CatId where toIdent (CatId s) = identC s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
-qIdentS = identS . unqual
+qIdentC = identS . unqual
-unqual (Qual (ModId m) n) = m++"_"++n
-unqual (Unqual n) = n
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
+unqual (Unqual n) = showRawIdent n
instance ToIdent VarId where
toIdent Anonymous = identW
- toIdent (VarId s) = identS s
+ toIdent (VarId s) = identC s
diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index d43256177..b0e356bc5 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/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.Option(optionsPGF)
+import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
+import GF.Infra.Option(Options,optionsPGF)
import PGF.Internal(Literal(..))
-import GF.Compile.Compute.Concrete(normalForm,resourceValues)
+import GF.Compile.Compute.Concrete(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,23 +60,24 @@ 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]
- [lin|(_,Right lin)<-defs]
+ [lincat | (_,Left lincat) <- defs]
+ [lin | (_,Right lin) <- defs]
where
defs = concatMap (toCanonical gr absname cenv) .
M.toList $
@@ -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))
- QC (m,n) -> ParamConstant (Param ((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) [])
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)))
- Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
- _ -> error $ "Missing case in convType for: "++show t
+ QC (m,n) -> ParamType (ParamTypeId (gQId m n))
+ Q (m,n) -> ParamType (ParamTypeId (gQId m n))
+ _ -> 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
-modId (MN m) = ModId (showIdent m)
+lblId :: Label -> C.LabelId
+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 CatId where gId = CatId . showIdent
+instance FromIdent C.FunId where gId = C.FunId . ident2raw
+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)
-unqual n = Unqual (showIdent n)
+qual :: ModuleName -> Ident -> QualId
+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 =
diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs
index 6356c9f6d..bc8e59f57 100644
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/src/compiler/GF/Compile/PGFtoHaskell.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/06/17 12:39:07 $
+-- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
@@ -22,7 +22,7 @@ import PGF.Internal
import GF.Data.Operations
import GF.Infra.Option
-import Data.List --(isPrefixOf, find, intersperse)
+import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
import qualified Data.Map as Map
type Prefix = String -> String
@@ -34,11 +34,12 @@ grammar2haskell :: Options
-> PGF
-> String
grammar2haskell opts name gr = foldr (++++) [] $
- pragmas ++ haskPreamble gadt name derivingClause extraImports ++
+ pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
[types, gfinstances gId lexical gr'] ++ compos
where gr' = hSkeleton gr
gadt = haskellOption opts HaskellGADT
dataExt = haskellOption opts HaskellData
+ pgf2 = haskellOption opts HaskellPGF2
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
| otherwise = ("G"++) . rmForbiddenChars
@@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $
derivingClause
| dataExt = "deriving (Show,Data)"
| otherwise = "deriving Show"
- extraImports | gadt = ["import Control.Monad.Identity",
- "import Data.Monoid"]
+ extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
| dataExt = ["import Data.Data"]
| otherwise = []
+ pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
+ | otherwise = ["import PGF hiding (Tree)"]
types | gadt = datatypesGADT gId lexical gr'
| otherwise = datatypes gId derivingClause lexical gr'
compos | gadt = prCompos gId lexical gr' ++ composClass
| otherwise = []
-haskPreamble gadt name derivingClause extraImports =
+haskPreamble :: Bool -> String -> String -> [String] -> [String]
+haskPreamble gadt name derivingClause imports =
[
"module " ++ name ++ " where",
""
- ] ++ extraImports ++ [
- "import PGF hiding (Tree)",
+ ] ++ imports ++ [
+ "",
"----------------------------------------------------",
"-- automatic translation from GF to Haskell",
"----------------------------------------------------",
@@ -85,10 +88,11 @@ haskPreamble gadt name derivingClause extraImports =
""
]
+predefInst :: Bool -> String -> String -> String -> String -> String -> String
predefInst gadt derivingClause gtyp typ destr consr =
(if gadt
then []
- else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
+ else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
)
++
"instance Gf" +++ gtyp +++ "where" ++++
@@ -103,10 +107,10 @@ type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
+datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
+gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
@@ -131,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
lexicalConstructor :: OIdent -> String
lexicalConstructor cat = "Lex" ++ cat
+predefTypeSkel :: HSkeleton
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
-- GADT version of data types
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypesGADT gId lexical (_,skel) = unlines $
+datatypesGADT gId lexical (_,skel) = unlines $
concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
- [
- "",
+ [
+ "",
"data Tree :: * -> * where"
- ] ++
+ ] ++
concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++
[
" GString :: String -> Tree GString_",
@@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
"data"+++gId cat++"_"]
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
-hDatatypeGADT gId lexical (cat, rules)
+hDatatypeGADT gId lexical (cat, rules)
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
| otherwise =
- [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
+ [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
| (f,args) <- nonLexicalRules (lexical cat) rules ]
++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
where t = "Tree" +++ gId cat ++ "_"
hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hEqGADT gId lexical (cat, rules)
- | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
+ | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
| otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
where
patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
- eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
+ eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
(x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
listr c = (c,["foo"]) -- foo just for length = 1
listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
prCompos gId lexical (_,catrules) =
["instance Compos Tree where",
" compos r a f t = case t of"]
- ++
+ ++
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
- (f,xs) <- rs, not (null xs)]
- ++
+ (f,xs) <- rs, not (null xs)]
+ ++
[" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
- ++
+ ++
[" _ -> r t"]
where
- prComposCons f xs = let vs = mkVars (length xs) in
+ prComposCons f xs = let vs = mkVars (length xs) in
f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
- prRec f (v,c)
+ prRec f (v,c)
| isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
| otherwise = "`a`" +++ "f" +++ v
- isList f = (gId "List") `isPrefixOf` f
+ isList f = gId "List" `isPrefixOf` f
gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
+hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance gId _ m (cat,[]) = unlines [
"instance Show" +++ gId cat,
@@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
" gf _ = undefined",
" fg _ = undefined"
]
-hInstance gId lexical m (cat,rules)
+hInstance gId lexical m (cat,rules)
| isListCat (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++++
- " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
+ " gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
- " gf (" ++ gId cat +++ "(x:xs)) = "
- ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
+ " gf (" ++ gId cat +++ "(x:xs)) = "
+ ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
-- no show for GADTs
--- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
+-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
| otherwise =
"instance Gf" +++ gId cat +++ "where\n" ++
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules)
ec = elemCat cat
baseVars = mkVars (baseSize (cat,rules))
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
- (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+ (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
"=" +++ mkRHS f xx'
- mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
- "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+ mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
+ "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+mkVars :: Int -> [String]
mkVars = mkSVars "x"
+
+mkSVars :: String -> Int -> [String]
mkSVars s n = [s ++ show i | i <- [1..n]]
----fInstance m ("Cn",_) = "" ---
fInstance _ _ m (cat,[]) = ""
fInstance gId lexical m (cat,rules) =
" fg t =" ++++
- (if isList
+ (if isList
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
@@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
" Just (i," ++
"[" ++ prTList "," xx' ++ "])" +++
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
- where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
- mkRHS f vars
- | isList =
- if "Base" `isPrefixOf` f
- then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
- else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
- | otherwise =
- gId f +++
- prTList " " [prParenth ("fg" +++ x) | x <- vars]
+ where
+ xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+ mkRHS f vars
+ | isList =
+ if "Base" `isPrefixOf` f
+ then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+ else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
+ | otherwise =
+ gId f +++
+ prTList " " [prParenth ("fg" +++ x) | x <- vars]
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr =
- (showCId (absname gr),
- let fs =
- [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
+hSkeleton gr =
+ (showCId (absname gr),
+ let fs =
+ [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns]
- in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
+ in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
)
where
- cts = Map.keys (cats (abstract gr))
+ cts = Map.keys (cats (abstract gr))
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
@@ -291,9 +301,10 @@ updateSkeleton cat skel rule =
-}
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
- && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
- where c = elemCat cat
- fs = map fst rules
+ && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+ where
+ c = elemCat cat
+ fs = map fst rules
-- | Gets the element category of a list category.
elemCat :: OIdent -> OIdent
@@ -310,7 +321,7 @@ baseSize (_,rules) = length bs
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
composClass :: [String]
-composClass =
+composClass =
[
"",
"class Compos t where",
@@ -337,4 +348,3 @@ composClass =
"",
"newtype C b a = C { unC :: b }"
]
-
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index aacf24c5b..c7ea56b45 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -39,6 +39,7 @@ import GF.Data.Operations
import Control.Monad
import Data.List (nub,(\\))
+import qualified Data.List as L
import qualified Data.Map as Map
import Data.Maybe(mapMaybe)
import GF.Text.Pretty
@@ -105,7 +106,26 @@ renameIdentTerm' env@(act,imps) t0 =
ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
"conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
"given" <+> fsep (punctuate ',' (map fst qualifs)))
- return t
+ return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
+ where
+ -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
+ -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
+ notFromCommonModule :: Term -> Bool
+ notFromCommonModule term =
+ let t = render $ ppTerm Qualified 0 term :: String
+ in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
+ ["CommonX", "ConstructX", "ExtendFunctor"
+ ,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
+
+ -- If one of the terms comes from the common modules,
+ -- we choose the other one, because that's defined in the grammar.
+ bestTerm :: [Term] -> Term
+ bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
+ bestTerm ts@(t:_) =
+ let notCommon = [t | t <- ts, notFromCommonModule t]
+ in case notCommon of
+ [] -> t -- All terms are from common modules, return first of original list
+ (u:_) -> u -- ≥1 terms are not from common modules, return first of those
info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
info2status mq c i = case i of
diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 0df3236ff..80e9f5e7b 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/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)
--------------------------------------------------------------------------------
diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs
index 0ec7f43e6..04c13df5e 100644
--- a/src/compiler/GF/Grammar/CanonicalJSON.hs
+++ b/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 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 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 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 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 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 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 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 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:
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index b088fe49c..280aee141 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/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
diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs
index b856d3995..ad47d91cd 100644
--- a/src/compiler/GF/Infra/Ident.hs
+++ b/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,
- Ident, ident2utf8, showIdent, prefixIdent,
- -- *** Normal identifiers (returned by the parser)
- identS, identC, identW,
- -- *** Special identifiers for internal use
- identV, identA, identAV,
- argIdent, isArgIdent, getArgIndex,
- varStr, varX, isWildIdent, varIndex,
- -- *** Raw identifiers
- RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
- isPrefixOf, showRawIdent
- ) where
+ ModuleName(..), moduleNameS,
+ Ident, ident2utf8, showIdent, prefixIdent,
+ -- *** Normal identifiers (returned by the parser)
+ identS, identC, identW,
+ -- *** Special identifiers for internal use
+ identV, identA, identAV,
+ argIdent, isArgIdent, getArgIndex,
+ varStr, varX, isWildIdent, varIndex,
+ -- *** Raw identifiers
+ RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+ isPrefixOf, showRawIdent
+) 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
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 6b7ff0cad..2a2ffd176 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -2,13 +2,13 @@ module GF.Infra.Option
(
-- ** Command line options
-- *** Option types
- Options,
- Flags(..),
- Mode(..), Phase(..), Verbosity(..),
- OutputFormat(..),
+ Options,
+ Flags(..),
+ Mode(..), Phase(..), Verbosity(..),
+ OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Pass(..), Recomp(..),
- outputFormatsExpl,
+ outputFormatsExpl,
-- *** Option parsing
parseOptions, parseModuleOptions, fixRelativeLibPaths,
-- *** Option pretty-printing
@@ -47,7 +47,7 @@ import PGF.Internal(Literal(..))
import qualified Control.Monad.Fail as Fail
usageHeader :: String
-usageHeader = unlines
+usageHeader = unlines
["Usage: gf [OPTIONS] [FILE [...]]",
"",
"How each FILE is handled depends on the file name suffix:",
@@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link
data OutputFormat = FmtPGFPretty
| FmtCanonicalGF
| FmtCanonicalJson
- | FmtJavaScript
+ | FmtJavaScript
| FmtJSON
- | FmtPython
- | FmtHaskell
+ | FmtPython
+ | FmtHaskell
| FmtJava
| FmtProlog
| FmtBNF
@@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty
| FmtNoLR
| FmtSRGS_XML
| FmtSRGS_XML_NonRec
- | FmtSRGS_ABNF
+ | FmtSRGS_ABNF
| FmtSRGS_ABNF_NonRec
- | FmtJSGF
- | FmtGSL
+ | FmtJSGF
+ | FmtGSL
| FmtVoiceXML
| FmtSLF
| FmtRegExp
| FmtFA
deriving (Eq,Ord)
-data SISRFormat =
+data SISRFormat =
-- | SISR Working draft 1 April 2003
--
- SISR_WD20030401
+ SISR_WD20030401
| SISR_1_0
deriving (Show,Eq,Ord)
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
deriving (Show,Eq,Ord)
-data CFGTransform = CFGNoLR
+data CFGTransform = CFGNoLR
| CFGRegular
- | CFGTopDownFilter
- | CFGBottomUpFilter
+ | CFGTopDownFilter
+ | CFGBottomUpFilter
| CFGStartCatOnly
| CFGMergeIdentical
| CFGRemoveCycles
deriving (Show,Eq,Ord)
-data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
- | HaskellConcrete | HaskellVariants | HaskellData
+data HaskellOption = HaskellNoPrefix
+ | HaskellGADT
+ | HaskellLexical
+ | HaskellConcrete
+ | HaskellVariants
+ | HaskellData
+ | HaskellPGF2
deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat
@@ -196,7 +201,7 @@ instance Show Options where
parseOptions :: ErrorMonad err =>
[String] -- ^ list of string arguments
-> err (Options, [FilePath])
-parseOptions args
+parseOptions args
| not (null errs) = errors errs
| otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss)
return (opts, files)
@@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
-> err Options
parseModuleOptions args = do
(opts,nonopts) <- parseOptions args
- if null nonopts
+ if null nonopts
then return opts
else errors $ map ("Non-option among module options: " ++) nonopts
@@ -281,7 +286,7 @@ defaultFlags = Flags {
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optOptimizePGF = False,
optSplitPGF = False,
- optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
+ optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [],
optStartCat = Nothing,
@@ -301,7 +306,7 @@ defaultFlags = Flags {
-- | Option descriptions
{-# NOINLINE optDescr #-}
optDescr :: [OptDescr (Err Options)]
-optDescr =
+optDescr =
[
Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
@@ -327,44 +332,44 @@ optDescr =
-- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
-- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
- Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
+ Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:",
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
"Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
"Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
"Abstract only: haskell, ..."]), -- prolog_abs,
- Option [] ["sisr"] (ReqArg sisrFmt "FMT")
+ Option [] ["sisr"] (ReqArg sisrFmt "FMT")
(unlines ["Include SISR tags in generated speech recognition grammars.",
"FMT can be one of: old, 1.0"]),
- Option [] ["haskell"] (ReqArg hsOption "OPTION")
- ("Turn on an optional feature when generating Haskell data types. OPTION = "
+ Option [] ["haskell"] (ReqArg hsOption "OPTION")
+ ("Turn on an optional feature when generating Haskell data types. OPTION = "
++ concat (intersperse " | " (map fst haskellOptionNames))),
- Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
+ Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
"Treat CAT as a lexical category.",
- Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
+ Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
"Treat CAT as a literal category.",
- Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
+ Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
"Save output files (other than .gfo files) in DIR.",
- Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
+ Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
"Overrides the value of GF_LIB_PATH.",
- Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
+ Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
"Always recompile from source.",
- Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
+ Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
"(default) Recompile from source if the source is newer than the .gfo file.",
- Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
+ Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
"Never recompile from source, if there is already .gfo file.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
- Option ['n'] ["name"] (ReqArg name "NAME")
+ Option ['n'] ["name"] (ReqArg name "NAME")
(unlines ["Use NAME as the name of the output. This is used in the output file names, ",
"with suffixes depending on the formats, and, when relevant, ",
"internally in the output."]),
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
- Option [] ["preproc"] (ReqArg preproc "CMD")
+ Option [] ["preproc"] (ReqArg preproc "CMD")
(unlines ["Use CMD to preprocess input files.",
"Multiple preprocessors can be used by giving this option multiple times."]),
- Option [] ["coding"] (ReqArg coding "ENCODING")
+ Option [] ["coding"] (ReqArg coding "ENCODING")
("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
@@ -372,7 +377,7 @@ optDescr =
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
- Option [] ["optimize"] (ReqArg optimize "OPT")
+ Option [] ["optimize"] (ReqArg optimize "OPT")
"Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
"Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
@@ -447,7 +452,7 @@ optDescr =
optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x
-
+
optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
splitPGF x = set $ \o -> o { optSplitPGF = x }
@@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)]
outputFormats = map fst outputFormatsExpl
outputFormatsExpl :: [((String,OutputFormat),String)]
-outputFormatsExpl =
+outputFormatsExpl =
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
@@ -504,11 +509,11 @@ instance Read OutputFormat where
readsPrec = lookupReadsPrec outputFormats
optimizationPackages :: [(String, Set Optimization)]
-optimizationPackages =
+optimizationPackages =
[("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("values", Set.fromList [OptStem,OptCSE,OptExpand]),
("noexpand", Set.fromList [OptStem,OptCSE]),
-
+
-- deprecated
("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
@@ -516,7 +521,7 @@ optimizationPackages =
]
cfgTransformNames :: [(String, CFGTransform)]
-cfgTransformNames =
+cfgTransformNames =
[("nolr", CFGNoLR),
("regular", CFGRegular),
("topdown", CFGTopDownFilter),
@@ -532,7 +537,8 @@ haskellOptionNames =
("lexical", HaskellLexical),
("concrete", HaskellConcrete),
("variants", HaskellVariants),
- ("data", HaskellData)]
+ ("data", HaskellData),
+ ("pgf2", HaskellPGF2)]
-- | This is for bacward compatibility. Since GHC 6.12 we
-- started using the native Unicode support in GHC but it
@@ -558,7 +564,7 @@ onOff f def = OptArg g "[on,off]"
_ -> fail $ "Expected [on,off], got: " ++ show x
readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
-readOutputFormat s =
+readOutputFormat s =
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
-- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -570,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of
isPathSep :: Char -> Bool
isPathSep c = c == ':' || c == ';'
---
+--
-- * Convenience functions for checking options
--
@@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
isLexicalCat :: Options -> String -> Bool
isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
---
+--
-- * Convenience functions for setting options
--
@@ -623,8 +629,8 @@ readMaybe s = case reads s of
toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
toEnumBounded i = let mi = minBound
- ma = maxBound `asTypeOf` mi
- in if i >= fromEnum mi && i <= fromEnum ma
+ ma = maxBound `asTypeOf` mi
+ in if i >= fromEnum mi && i <= fromEnum ma
then Just (toEnum i `asTypeOf` mi)
else Nothing
diff --git a/testsuite/canonical/.gitignore b/testsuite/canonical/.gitignore
new file mode 100644
index 000000000..72988cf10
--- /dev/null
+++ b/testsuite/canonical/.gitignore
@@ -0,0 +1 @@
+canonical/
diff --git a/testsuite/canonical/gold/FoodsFin.gf b/testsuite/canonical/gold/FoodsFin.gf
new file mode 100644
index 000000000..de63d2b36
--- /dev/null
+++ b/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 = ""};
+}
\ No newline at end of file
diff --git a/testsuite/canonical/gold/PhrasebookBul.gf b/testsuite/canonical/gold/PhrasebookBul.gf
new file mode 100644
index 000000000..eb10cc48c
--- /dev/null
+++ b/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}};
+}
\ No newline at end of file
diff --git a/testsuite/canonical/gold/PhrasebookGer.gf b/testsuite/canonical/gold/PhrasebookGer.gf
new file mode 100644
index 000000000..912f3b7b1
--- /dev/null
+++ b/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 = ""}};
+}
\ No newline at end of file
diff --git a/testsuite/canonical/grammars/Foods.gf b/testsuite/canonical/grammars/Foods.gf
new file mode 100644
index 000000000..aa68d4429
--- /dev/null
+++ b/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;
+}
diff --git a/testsuite/canonical/grammars/FoodsFin.gf b/testsuite/canonical/grammars/FoodsFin.gf
new file mode 100644
index 000000000..962199805
--- /dev/null
+++ b/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) ;
diff --git a/testsuite/canonical/grammars/FoodsI.gf b/testsuite/canonical/grammars/FoodsI.gf
new file mode 100644
index 000000000..f4113b724
--- /dev/null
+++ b/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 ;
+}
diff --git a/testsuite/canonical/grammars/LexFoods.gf b/testsuite/canonical/grammars/LexFoods.gf
new file mode 100644
index 000000000..12ace208c
--- /dev/null
+++ b/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 ;
+}
diff --git a/testsuite/canonical/grammars/LexFoodsFin.gf b/testsuite/canonical/grammars/LexFoodsFin.gf
new file mode 100644
index 000000000..8b12f449f
--- /dev/null
+++ b/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�n" "l�mmint�" "l�mpim�n�" "l�mpim��n"
+ "l�mpimin�" "l�mpimi�" "l�mpimien" "l�mpimiss�" "l�mpimiin"
+ )
+ "l�mpim�mpi" "l�mpimin" ;
+ italian_A = mkA "italialainen" ;
+ expensive_A = mkA "kallis" ;
+ delicious_A = mkA "herkullinen" ;
+ boring_A = mkA "tyls�" ;
+}
diff --git a/testsuite/canonical/grammars/Phrasebook.gf b/testsuite/canonical/grammars/Phrasebook.gf
new file mode 100644
index 000000000..eff538f62
--- /dev/null
+++ b/testsuite/canonical/grammars/Phrasebook.gf
@@ -0,0 +1,9 @@
+abstract Phrasebook = {
+
+cat PlaceKind ;
+fun Airport : PlaceKind ;
+
+cat VerbPhrase ;
+fun VRead : VerbPhrase ;
+
+}
diff --git a/testsuite/canonical/grammars/PhrasebookBul.gf b/testsuite/canonical/grammars/PhrasebookBul.gf
new file mode 100644
index 000000000..347d69297
--- /dev/null
+++ b/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 ;
+
+}
diff --git a/testsuite/canonical/grammars/PhrasebookGer.gf b/testsuite/canonical/grammars/PhrasebookGer.gf
new file mode 100644
index 000000000..c6402297c
--- /dev/null
+++ b/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 ;
+
+}
diff --git a/testsuite/canonical/run-on-grammar.sh b/testsuite/canonical/run-on-grammar.sh
new file mode 100755
index 000000000..f621035e3
--- /dev/null
+++ b/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
diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh
new file mode 100755
index 000000000..81c03c5d1
--- /dev/null
+++ b/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