From bfcab16de603a33ffef7f3da1174844f0ab11daa Mon Sep 17 00:00:00 2001 From: Inari Listenmaa Date: Sat, 6 Jun 2020 11:35:05 +0200 Subject: [PATCH 01/16] Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56 --- src/compiler/GF/Compile/Rename.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 5eb83cd4b..c12fd862c 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 From 0a70eca6e2913c462c5c65361131f3ed341e539d Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 30 Jun 2021 10:58:23 +0200 Subject: [PATCH 02/16] Make GF.Grammar.Canonical.Id a type synonym for GF.Infra.Ident.RawIdent This avoids a lot of conversion back and forth between Strings and ByteStrings This commit was cherry-picked from d0c27cdaae78c670b098740bfb49b428d900e640 (lpgf branch) --- src/compiler/GF/Compile/ConcreteToHaskell.hs | 47 +++++++++---------- src/compiler/GF/Compile/GrammarToCanonical.hs | 36 +++++++------- src/compiler/GF/Grammar/Canonical.hs | 3 +- src/compiler/GF/Grammar/CanonicalJSON.hs | 37 ++++++++------- src/compiler/GF/Infra/Ident.hs | 39 +++++++-------- 5 files changed, 86 insertions(+), 76 deletions(-) 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 33f35ad08..2b701382c 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -16,7 +16,7 @@ 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,prefixIdent,showIdent,isWildIdent) import GF.Infra.Option(optionsPGF) import PGF.Internal(Literal(..)) import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) @@ -69,10 +69,10 @@ concretes2canonical opts absname gr = 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) . + defs = concatMap (toCanonical gr absname cenv) . M.toList $ jments modinfo @@ -188,8 +188,8 @@ 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)) @@ -247,7 +247,7 @@ projection r l = maybe (Projection r l) id (proj r l) 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 @@ -257,7 +257,7 @@ 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 @@ -357,16 +357,20 @@ paramType gr q@(_,n) = 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 + +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 @@ -375,11 +379,11 @@ class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i 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 m n = Qual (modId m) (ident2raw n) +unqual n = Unqual (ident2raw n) 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/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/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 From 0f5be0bbaa862d2ccdb649eb6dd9fc5e26814e8a Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 30 Jun 2021 12:41:56 +0200 Subject: [PATCH 03/16] Add shell script in testsuite/compiler/canonical for replicating known issues Ideally this is integrated into proper test suite, but that's too much overhead for now --- testsuite/compiler/canonical/.gitignore | 1 + testsuite/compiler/canonical/Foods.gf | 16 + testsuite/compiler/canonical/FoodsFin.gf | 6 + testsuite/compiler/canonical/FoodsFin.gf.gold | 102 ++++++ testsuite/compiler/canonical/FoodsI.gf | 29 ++ testsuite/compiler/canonical/Greetings.gf | 28 ++ testsuite/compiler/canonical/GreetingsBul.gf | 31 ++ testsuite/compiler/canonical/GreetingsGer.gf | 31 ++ testsuite/compiler/canonical/LexFoods.gf | 15 + testsuite/compiler/canonical/LexFoodsFin.gf | 21 ++ testsuite/compiler/canonical/Phrasebook.gf | 8 + testsuite/compiler/canonical/PhrasebookBul.gf | 9 + testsuite/compiler/canonical/PhrasebookGer.gf | 10 + testsuite/compiler/canonical/Sentences.gf | 222 +++++++++++++ testsuite/compiler/canonical/SentencesBul.gf | 54 ++++ testsuite/compiler/canonical/SentencesGer.gf | 50 +++ testsuite/compiler/canonical/SentencesI.gf | 302 +++++++++++++++++ testsuite/compiler/canonical/Words.gf | 254 +++++++++++++++ testsuite/compiler/canonical/WordsBul.gf | 305 ++++++++++++++++++ testsuite/compiler/canonical/WordsGer.gf | 262 +++++++++++++++ testsuite/compiler/canonical/run.sh | 23 ++ 21 files changed, 1779 insertions(+) create mode 100644 testsuite/compiler/canonical/.gitignore create mode 100644 testsuite/compiler/canonical/Foods.gf create mode 100644 testsuite/compiler/canonical/FoodsFin.gf create mode 100644 testsuite/compiler/canonical/FoodsFin.gf.gold create mode 100644 testsuite/compiler/canonical/FoodsI.gf create mode 100644 testsuite/compiler/canonical/Greetings.gf create mode 100644 testsuite/compiler/canonical/GreetingsBul.gf create mode 100644 testsuite/compiler/canonical/GreetingsGer.gf create mode 100644 testsuite/compiler/canonical/LexFoods.gf create mode 100644 testsuite/compiler/canonical/LexFoodsFin.gf create mode 100644 testsuite/compiler/canonical/Phrasebook.gf create mode 100644 testsuite/compiler/canonical/PhrasebookBul.gf create mode 100644 testsuite/compiler/canonical/PhrasebookGer.gf create mode 100644 testsuite/compiler/canonical/Sentences.gf create mode 100644 testsuite/compiler/canonical/SentencesBul.gf create mode 100644 testsuite/compiler/canonical/SentencesGer.gf create mode 100644 testsuite/compiler/canonical/SentencesI.gf create mode 100644 testsuite/compiler/canonical/Words.gf create mode 100644 testsuite/compiler/canonical/WordsBul.gf create mode 100644 testsuite/compiler/canonical/WordsGer.gf create mode 100755 testsuite/compiler/canonical/run.sh diff --git a/testsuite/compiler/canonical/.gitignore b/testsuite/compiler/canonical/.gitignore new file mode 100644 index 000000000..72988cf10 --- /dev/null +++ b/testsuite/compiler/canonical/.gitignore @@ -0,0 +1 @@ +canonical/ diff --git a/testsuite/compiler/canonical/Foods.gf b/testsuite/compiler/canonical/Foods.gf new file mode 100644 index 000000000..aa68d4429 --- /dev/null +++ b/testsuite/compiler/canonical/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/compiler/canonical/FoodsFin.gf b/testsuite/compiler/canonical/FoodsFin.gf new file mode 100644 index 000000000..962199805 --- /dev/null +++ b/testsuite/compiler/canonical/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/compiler/canonical/FoodsFin.gf.gold b/testsuite/compiler/canonical/FoodsFin.gf.gold new file mode 100644 index 000000000..55c2fa6c9 --- /dev/null +++ b/testsuite/compiler/canonical/FoodsFin.gf.gold @@ -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 = ""}; +} diff --git a/testsuite/compiler/canonical/FoodsI.gf b/testsuite/compiler/canonical/FoodsI.gf new file mode 100644 index 000000000..f4113b724 --- /dev/null +++ b/testsuite/compiler/canonical/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/compiler/canonical/Greetings.gf b/testsuite/compiler/canonical/Greetings.gf new file mode 100644 index 000000000..580b1560b --- /dev/null +++ b/testsuite/compiler/canonical/Greetings.gf @@ -0,0 +1,28 @@ +abstract Greetings = Sentences [Greeting] ** { + +fun + GBye : Greeting ; + GCheers : Greeting ; + GDamn : Greeting ; + GExcuse, GExcusePol : Greeting ; + GGoodDay : Greeting ; + GGoodEvening : Greeting ; + GGoodMorning : Greeting ; + GGoodNight : Greeting ; + GGoodbye : Greeting ; + GHello : Greeting ; + GHelp : Greeting ; + GHowAreYou : Greeting ; + GLookOut : Greeting ; + GNiceToMeetYou : Greeting ; + GPleaseGive, GPleaseGivePol : Greeting ; + GSeeYouSoon : Greeting ; + GSorry, GSorryPol : Greeting ; + GThanks : Greeting ; + GTheCheck : Greeting ; + GCongratulations : Greeting ; + GHappyBirthday : Greeting ; + GGoodLuck : Greeting ; + GWhatTime : Greeting ; + +} diff --git a/testsuite/compiler/canonical/GreetingsBul.gf b/testsuite/compiler/canonical/GreetingsBul.gf new file mode 100644 index 000000000..f271d7717 --- /dev/null +++ b/testsuite/compiler/canonical/GreetingsBul.gf @@ -0,0 +1,31 @@ +concrete GreetingsBul of Greetings = SentencesBul [Greeting,mkGreeting] ** open Prelude in { + +flags + coding=utf8; + +lin + GBye = mkGreeting "чао" ; + GCheers = mkGreeting "наздраве" ; + GDamn = mkGreeting "по дяволите" ; + GExcuse, GExcusePol = mkGreeting "извинете" ; + GGoodDay = mkGreeting "добър ден" ; + GGoodEvening = mkGreeting "добра вечер" ; + GGoodMorning = mkGreeting "добро утро" ; + GGoodNight = mkGreeting "лека нощ" ; + GGoodbye = mkGreeting "довиждане" ; + GHello = mkGreeting "здравей" ; + GHelp = mkGreeting "помощ" ; + GHowAreYou = mkGreeting "как си" ; + GLookOut = mkGreeting "погледни" ; + GNiceToMeetYou = mkGreeting "радвам се да се видим" ; + GPleaseGive, GPleaseGivePol = mkGreeting "моля" ; + GSeeYouSoon = mkGreeting "до скоро" ; + GSorry, GSorryPol = mkGreeting "извинете" ; + GThanks = mkGreeting "благодаря ти" ; + GTheCheck = mkGreeting "сметката" ; + GCongratulations = mkGreeting "поздравления"; + GHappyBirthday = mkGreeting "честит рожден ден" ; + GGoodLuck = mkGreeting "успех" ; + GWhatTime = mkGreeting "колко е часът" ; + +} diff --git a/testsuite/compiler/canonical/GreetingsGer.gf b/testsuite/compiler/canonical/GreetingsGer.gf new file mode 100644 index 000000000..f027d70ac --- /dev/null +++ b/testsuite/compiler/canonical/GreetingsGer.gf @@ -0,0 +1,31 @@ +--# -path=.:abstract:prelude:german:api:common +--# -coding=latin1 +concrete GreetingsGer of Greetings = SentencesGer [Greeting,mkGreeting] ** open Prelude in { + +lin + GBye = mkGreeting "tsch" ; + GCheers = mkGreeting "zum Wohl" ; + GDamn = mkGreeting "verdammt" ; + GExcuse, GExcusePol = mkGreeting "Entschuldigung" ; + GGoodDay = mkGreeting "guten Tag" ; + GGoodEvening = mkGreeting "guten Abend" ; + GGoodMorning = mkGreeting "guten Morgen" ; + GGoodNight = mkGreeting "gute Nacht" ; + GGoodbye = mkGreeting "auf Wiedersehen" ; + GHello = mkGreeting "Hallo" ; + GHelp = mkGreeting "Hilfe" ; + GHowAreYou = mkGreeting "wie geht's" ; + GLookOut = mkGreeting "Achtung" ; + GNiceToMeetYou = mkGreeting "nett, Sie zu treffen" ; + GPleaseGive, GPleaseGivePol = mkGreeting "bitte" ; + GSeeYouSoon = mkGreeting "bis bald" ; + GSorry, GSorryPol = mkGreeting "Entschuldigung" ; + GThanks = mkGreeting "Danke" ; + GTheCheck = mkGreeting "die Rechnung" ; + GCongratulations = mkGreeting "herzlichen Glckwunsch"; + GHappyBirthday = mkGreeting "alles Gute zum Geburtstag" ; + GGoodLuck = mkGreeting "viel Glck" ; + GWhatTime = mkGreeting "wieviel Uhr ist es" | mkGreeting "wie spt ist es" ; + +} + diff --git a/testsuite/compiler/canonical/LexFoods.gf b/testsuite/compiler/canonical/LexFoods.gf new file mode 100644 index 000000000..12ace208c --- /dev/null +++ b/testsuite/compiler/canonical/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/compiler/canonical/LexFoodsFin.gf b/testsuite/compiler/canonical/LexFoodsFin.gf new file mode 100644 index 000000000..8b12f449f --- /dev/null +++ b/testsuite/compiler/canonical/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/compiler/canonical/Phrasebook.gf b/testsuite/compiler/canonical/Phrasebook.gf new file mode 100644 index 000000000..9ebc13106 --- /dev/null +++ b/testsuite/compiler/canonical/Phrasebook.gf @@ -0,0 +1,8 @@ +abstract Phrasebook = + Greetings, + Words + ** { + +flags startcat = Phrase ; + +} diff --git a/testsuite/compiler/canonical/PhrasebookBul.gf b/testsuite/compiler/canonical/PhrasebookBul.gf new file mode 100644 index 000000000..bbc092963 --- /dev/null +++ b/testsuite/compiler/canonical/PhrasebookBul.gf @@ -0,0 +1,9 @@ +--# -path=.:present + +concrete PhrasebookBul of Phrasebook = + GreetingsBul, + WordsBul ** open + SyntaxBul, + Prelude in { + +} diff --git a/testsuite/compiler/canonical/PhrasebookGer.gf b/testsuite/compiler/canonical/PhrasebookGer.gf new file mode 100644 index 000000000..69a61187c --- /dev/null +++ b/testsuite/compiler/canonical/PhrasebookGer.gf @@ -0,0 +1,10 @@ +--# -path=.:present + +concrete PhrasebookGer of Phrasebook = + GreetingsGer, + WordsGer ** open + SyntaxGer, + Prelude in { + + +} diff --git a/testsuite/compiler/canonical/Sentences.gf b/testsuite/compiler/canonical/Sentences.gf new file mode 100644 index 000000000..6798c2127 --- /dev/null +++ b/testsuite/compiler/canonical/Sentences.gf @@ -0,0 +1,222 @@ +--1 The Ontology of the Phrasebook + +--2 Syntactic Structures of the Phrasebook + +-- This module contains phrases that can be defined by a functor over the +-- resource grammar API. The phrases that are likely to have different implementations +-- are in the module Words. But the distinction is not quite sharp; thus it may happen +-- that the functor instantiations make exceptions. + +abstract Sentences = Numeral ** { + +-- The ontology of the phrasebook is defined by the following types. The commented ones +-- are defined in other modules. + + cat + Phrase ; -- complete phrase, the unit of translation e.g. "Where are you?" + Word ; -- word that could be used as phrase e.g. "Monday" + Message ; -- sequence of phrases, longest unit e.g. "Hello! Where are you?" + Greeting ; -- idiomatic greeting e.g. "hello" + Sentence ; -- declarative sentence e.g. "I am in the bar" + Question ; -- question, either yes/no or wh e.g. "where are you" + Proposition ; -- can be turned into sentence or question e.g. "this pizza is good" + Object ; -- the object of wanting, ordering, etc e.g. "three pizzas and a beer" + PrimObject ; -- single object of wanting, ordering, etc e.g. "three pizzas" + Item ; -- a single entity e.g. "this pizza" + Kind ; -- a type of an item e.g. "pizza" + MassKind ; -- a type mass (uncountable) e.g. "water" + PlurKind ; -- a type usually only in plural e.g. "noodles" + DrinkKind ; -- a drinkable, countable type e.g. "beer" + Quality ; -- qualification of an item, can be complex e.g. "very good" + Property ; -- basic property of an item, one word e.g. "good" + Place ; -- location e.g. "the bar" + PlaceKind ; -- type of location e.g. "bar" + Currency ; -- currency unit e.g. "leu" + Price ; -- number of currency units e.g. "eleven leu" + Person ; -- agent wanting or doing something e.g. "you" + Action ; -- proposition about a Person e.g. "you are here" + Nationality ; -- complex of language, property, country e.g. "Swedish, Sweden" + LAnguage ; -- language (can be without nationality) e.g. "Flemish" + Citizenship ; -- property (can be without language) e.g. "Belgian" + Country ; -- country (can be without language) e.g. "Belgium" + Day ; -- weekday type e.g. "Friday" + Date ; -- definite date e.g. "on Friday" + Name ; -- name of person e.g. "NN" + Number ; -- number expression 1 .. 999,999 e.g. "twenty" + Transport ; -- transportation device e.g. "car" + ByTransport ; -- mean of transportation e.g. "by tram" + Superlative ; -- superlative modifiers of places e.g. "the best restaurant" + + + fun + +-- To build a whole message + + MPhrase : Phrase -> Message ; + MContinue : Phrase -> Message -> Message ; + +-- Many of the categories are accessible as Phrases, i.e. as translation units. +-- To regulate whether words appear on the top level, change their status between +-- Word and Phrase, or uncomment PWord, + + -- PWord : Word -> Phrase ; + + PGreetingMale : Greeting -> Phrase ; -- depends on speaker e.g. in Thai + PGreetingFemale : Greeting -> Phrase ; + PSentence : Sentence -> Phrase ; + PQuestion : Question -> Phrase ; + + PNumber : Number -> Phrase ; + PPrice : Price -> Phrase ; + PObject : Object -> Word ; + PKind : Kind -> Word ; + PMassKind : MassKind -> Word ; + PQuality : Quality -> Word ; + PPlace : Place -> Word ; + PPlaceKind : PlaceKind -> Word ; + PCurrency : Currency -> Word ; + PLanguage : LAnguage -> Word ; + PCitizenship : Citizenship -> Word ; + PCountry : Country -> Word ; + PDay : Day -> Word ; + PByTransport : ByTransport -> Word ; + PTransport : Transport -> Word ; + + PYes, PNo, PYesToNo : Greeting ; -- yes, no, si/doch (pos. answer to neg. question) + +-- To order something. + + GObjectPlease : Object -> Greeting ; -- a pizza and beer, please! + +-- This is the way to build propositions about inanimate items. + + Is : Item -> Quality -> Proposition ; -- this pizza is good + IsMass : MassKind -> Quality -> Proposition ; -- Belgian beer is good + +-- To use propositions on higher levels. + + SProp : Proposition -> Sentence ; -- this pizza is good + SPropNot : Proposition -> Sentence ; -- this pizza isn't good + QProp : Proposition -> Question ; -- is this pizza good + + WherePlace : Place -> Question ; -- where is the bar + WherePerson : Person -> Question ; -- where are you + +-- This is the way to build propositions about persons. + + PropAction : Action -> Proposition ; -- (you (are|aren't) | are you) Swedish + +-- Here are some general syntactic constructions. + + ObjItem : Item -> PrimObject ; -- this pizza + ObjNumber : Number -> Kind -> PrimObject ; -- five pizzas + ObjIndef : Kind -> PrimObject ; -- a pizza + ObjPlural : Kind -> PrimObject ; -- pizzas + ObjPlur : PlurKind -> PrimObject ; -- noodles + ObjMass : MassKind -> PrimObject ; -- water + ObjAndObj : PrimObject -> Object -> Object ; -- this pizza and a beer + OneObj : PrimObject -> Object ; -- this pizza + + SuchKind : Quality -> Kind -> Kind ; -- Italian pizza + SuchMassKind : Quality -> MassKind -> MassKind ; -- Italian water + Very : Property -> Quality ; -- very Italian + Too : Property -> Quality ; -- too Italian + PropQuality : Property -> Quality ; -- Italian + + MassDrink : DrinkKind -> MassKind ; -- beer + DrinkNumber : Number -> DrinkKind -> PrimObject ; -- five beers + +-- Determiners. + + This, That, These, Those : Kind -> Item ; -- this pizza,...,those pizzas + The, Thes : Kind -> Item ; -- the pizza, the pizzas + ThisMass, ThatMass, TheMass : MassKind -> Item ; -- this/that/the water + ThesePlur, ThosePlur, ThesPlur : PlurKind -> Item ; -- these/those/the potatoes + + AmountCurrency : Number -> Currency -> Price ; -- five euros + + ThePlace : PlaceKind -> Place ; -- the bar + APlace : PlaceKind -> Place ; -- a bar + + IMale, IFemale, -- I, said by man/woman (affects agreement) + YouFamMale, YouFamFemale, -- familiar you, said to man/woman (affects agreement) + YouPolMale, YouPolFemale : Person ; -- polite you, said to man/woman (affects agreement) + + LangNat : Nationality -> LAnguage ; -- Swedish + CitiNat : Nationality -> Citizenship ; -- Swedish + CountryNat : Nationality -> Country ; -- Sweden + PropCit : Citizenship -> Property ; -- Swedish + + OnDay : Day -> Date ; -- on Friday + Today : Date ; -- today + + PersonName : Name -> Person ; -- person referred by name + NameNN : Name ; -- the name "NN" + +---- NameString : String -> Name ; ---- creates ambiguities with all words --% + + NNumeral : Numeral -> Number ; -- numeral in words, e.g. "twenty" + +-- Actions are typically language-dependent, not only lexically but also +-- structurally. However, these ones are mostly functorial. + + SHave : Person -> Object -> Sentence ; -- you have beer + SHaveNo : Person -> Kind -> Sentence ; -- you have no apples + SHaveNoMass : Person -> MassKind -> Sentence ; -- you have no beer + QDoHave : Person -> Object -> Question ; -- do you have beer + + AHaveCurr : Person -> Currency -> Action ; -- you have dollars + ACitizen : Person -> Citizenship -> Action ; -- you are Swedish + ABePlace : Person -> Place -> Action ; -- you are in the bar + + ByTransp : Transport -> ByTransport ; -- by bus + + AKnowSentence : Person -> Sentence -> Action ; -- you know that I am in the bar + AKnowPerson : Person -> Person -> Action ; -- you know me + AKnowQuestion : Person -> Question -> Action ; -- you know how far the bar is + +------------------------------------------------------------------------------------------ +-- New things added 30/11/2011 by AR +------------------------------------------------------------------------------------------ + + cat + VerbPhrase ; -- things one does, can do, must do, wants to do, e.g. swim + Modality ; -- can, want, must + fun + ADoVerbPhrase : Person -> VerbPhrase -> Action ; -- I swim + AModVerbPhrase : Modality -> Person -> VerbPhrase -> Action ; -- I can swim + ADoVerbPhrasePlace : Person -> VerbPhrase -> Place -> Action ; -- I swim in the hotel + AModVerbPhrasePlace : Modality -> Person -> VerbPhrase -> Place -> Action ; -- I can swim in the hotel + + QWhereDoVerbPhrase : Person -> VerbPhrase -> Question ; -- where do you swim + QWhereModVerbPhrase : Modality -> Person -> VerbPhrase -> Question ; -- where can I swim + + MCan, MKnow, MMust, MWant : Modality ; + +-- lexical items given in the resource Lexicon + + VPlay, VRun, VSit, VSleep, VSwim, VWalk : VerbPhrase ; + VDrink, VEat, VRead, VWait, VWrite, VSit, VStop : VerbPhrase ; + V2Buy, V2Drink, V2Eat : Object -> VerbPhrase ; + V2Wait : Person -> VerbPhrase ; + + PImperativeFamPos, -- eat + PImperativeFamNeg, -- don't eat + PImperativePolPos, -- essen Sie + PImperativePolNeg, -- essen Sie nicht + PImperativePlurPos, -- esst + PImperativePlurNeg : -- esst nicht + VerbPhrase -> Phrase ; + +-- other new things allowed by the resource + +--- PBecause : Sentence -> Sentence -> Phrase ; -- I want to swim because it is hot + + He, She, -- he, she + WeMale, WeFemale, -- we, said by men/women (affects agreement) + YouPlurFamMale, YouPlurFamFemale, -- plural familiar you, said to men/women (affects agreement) + YouPlurPolMale, YouPlurPolFemale, -- plural polite you, said to men/women (affects agreement) + TheyMale, TheyFemale : Person ; -- they, said of men/women (affects agreement) + +} + diff --git a/testsuite/compiler/canonical/SentencesBul.gf b/testsuite/compiler/canonical/SentencesBul.gf new file mode 100644 index 000000000..b2968bc85 --- /dev/null +++ b/testsuite/compiler/canonical/SentencesBul.gf @@ -0,0 +1,54 @@ +concrete SentencesBul of Sentences = + NumeralBul ** SentencesI - [IMale, IFemale, YouFamMale, YouFamFemale, YouPolMale, + YouPolFemale, ACitizen, Citizenship, PCitizenship, + LangNat, CitiNat, CountryNat, PropCit, + Nationality, Country, LAnguage, PLanguage, PCountry + ] with + (Syntax = SyntaxBul), + (Symbolic = SymbolicBul), + (Lexicon = LexiconBul) ** open ExtraBul, (R = ResBul) in { + +lincat + Citizenship = {s1 : R.Gender => R.NForm => Str; -- there are two nouns for every citizenship - one for males and one for females + s2 : A -- furthermore, adjective for Property + } ; + Nationality = {s1 : R.Gender => R.NForm => Str; -- there are two nouns for every citizenship - one for males and one for females + s2 : A; -- furthermore, adjective for Property + s3 : PN -- country name + } ; + LAnguage = A ; + Country = PN ; + +lin IMale = mkPerson i_Pron ; + IFemale = mkPerson i8fem_Pron ; + +lin YouFamMale = mkPerson youSg_Pron ; + YouFamFemale = mkPerson youSg8fem_Pron ; + YouPolMale, YouPolFemale = mkPerson youPol_Pron ; + +lin ACitizen p cit = + let noun : N + = case p.name.gn of { + R.GSg g => lin N {s = \\nf => cit.s1 ! g ! nf; + rel = cit.s2.s; relType = R.AdjMod; + g = case g of {R.Masc=>R.AMasc R.Human; R.Fem=>R.AFem; R.Neut=>R.ANeut} + } ; + R.GPl => lin N {s = \\nf => cit.s1 ! R.Masc ! nf; + rel = cit.s2.s; relType = R.AdjMod; + g = R.AMasc R.Human + } + } ; + in mkCl p.name noun ; + + PCitizenship cit = + mkPhrase (mkUtt (mkAP cit.s2)) ; + + LangNat n = n.s2 ; + CitiNat n = n ; + CountryNat n = n.s3 ; + PropCit cit = cit.s2 ; + + PLanguage x = mkPhrase (mkUtt (mkAP x)) ; + PCountry x = mkPhrase (mkUtt (mkNP x)) ; + +} diff --git a/testsuite/compiler/canonical/SentencesGer.gf b/testsuite/compiler/canonical/SentencesGer.gf new file mode 100644 index 000000000..cc0922d5f --- /dev/null +++ b/testsuite/compiler/canonical/SentencesGer.gf @@ -0,0 +1,50 @@ +concrete SentencesGer of Sentences = NumeralGer ** SentencesI - + [PYesToNo,SHaveNo,SHaveNoMass, + Proposition, Action, Is, IsMass, SProp, SPropNot, QProp, + AHaveCurr, ACitizen, ABePlace, AKnowSentence, AKnowPerson, AKnowQuestion, + Nationality, LAnguage, + ADoVerbPhrase, AModVerbPhrase, ADoVerbPhrasePlace, AModVerbPhrasePlace, + YouPlurPolMale, YouPlurPolFemale + ] with + (Syntax = SyntaxGer), + (Symbolic = SymbolicGer), + (Lexicon = LexiconGer) ** open Prelude, SyntaxGer in { + + lin + PYesToNo = mkPhrase (lin Utt (ss "doch")) ; + SHaveNo p k = mkS (mkCl p.name have_V2 (mkNP no_Quant plNum k)) ; + SHaveNoMass p k = mkS (mkCl p.name have_V2 (mkNP no_Quant k)) ; + + lincat + Proposition, Action = Prop ; + oper + Prop = {pos : Cl ; neg : S} ; -- x F y ; x F nicht/kein y + mkProp : Cl -> S -> Prop = \pos,neg -> {pos = pos ; neg = neg} ; + prop : Cl -> Prop = \cl -> mkProp cl (mkS negativePol cl) ; + lin + Is i q = prop (mkCl i q) ; + IsMass m q = prop (mkCl (mkNP m) q) ; + SProp p = mkS p.pos ; + SPropNot p = p.neg ; + QProp p = mkQS (mkQCl p.pos) ; + + AHaveCurr p curr = prop (mkCl p.name have_V2 (mkNP aPl_Det curr)) ; + ACitizen p n = prop (mkCl p.name n) ; + ABePlace p place = prop (mkCl p.name place.at) ; + + AKnowSentence p s = prop (mkCl p.name Lexicon.know_VS s) ; + AKnowQuestion p s = prop (mkCl p.name Lexicon.know_VQ s) ; + AKnowPerson p q = prop (mkCl p.name Lexicon.know_V2 q.name) ; + + lincat + Nationality = {lang : CN ; country : NP ; prop : A} ; + LAnguage = CN ; -- kein Deutsch + +-- the new things + lin + ADoVerbPhrase p vp = prop (mkCl p.name vp) ; + AModVerbPhrase m p vp = prop (mkCl p.name (mkVP m vp)) ; + ADoVerbPhrasePlace p vp x = prop (mkCl p.name (mkVP vp x.at)) ; + AModVerbPhrasePlace m p vp x = prop (mkCl p.name (mkVP m (mkVP vp x.at))) ; + YouPlurPolMale, YouPlurPolFemale = mkPerson youPol_Pron ; +} diff --git a/testsuite/compiler/canonical/SentencesI.gf b/testsuite/compiler/canonical/SentencesI.gf new file mode 100644 index 000000000..913aa11ad --- /dev/null +++ b/testsuite/compiler/canonical/SentencesI.gf @@ -0,0 +1,302 @@ +--1 Implementation of MOLTO Phrasebook + +--2 The functor for (mostly) common structures + +incomplete concrete SentencesI of Sentences = Numeral ** + open + Syntax, + Lexicon, + Symbolic, -- for names as strings + Prelude + in { + lincat + Phrase = Text ; + Word = Text ; + Message = Text ; + Greeting = Text ; + Sentence = S ; + Question = QS ; + Proposition = Cl ; + Item = NP ; + Kind = CN ; + MassKind = CN ; + MassKind = CN ; + PlurKind = CN ; + DrinkKind = CN ; + Quality = AP ; + Property = A ; + Object = NP ; + PrimObject = NP ; + Place = NPPlace ; -- {name : NP ; at : Syntax.Adv ; to : Syntax.Adv} ; + PlaceKind = CNPlace ; -- {name : CN ; at : Prep ; to : Prep} ; + Currency = CN ; + Price = NP ; + Action = Cl ; + Person = NPPerson ; -- {name : NP ; isPron : Bool ; poss : Quant} ; + Nationality = NPNationality ; -- {lang : NP ; country : NP ; prop : A} ; + LAnguage = NP ; + Citizenship = A ; + Country = NP ; + Day = NPDay ; -- {name : NP ; point : Syntax.Adv ; habitual : Syntax.Adv} ; + Date = Syntax.Adv ; + Name = NP ; + Number = Card ; + ByTransport = Syntax.Adv ; + Transport = {name : CN ; by : Syntax.Adv} ; + Superlative = Det ; + lin + MPhrase p = p ; + MContinue p m = mkText p m ; + + PSentence s = mkText s | lin Text (mkUtt s) ; -- optional '.' + PQuestion s = mkText s | lin Text (mkUtt s) ; -- optional '?' + + PGreetingMale, PGreetingFemale = \g -> mkText (lin Phr (ss g.s)) exclMarkPunct | g ; + + -- PWord w = w ; + + PNumber x = mkSentence (mkUtt x) ; + PPrice x = mkSentence (mkUtt x) ; + + PObject x = mkPhrase (mkUtt x) ; + PKind x = mkPhrase (mkUtt x) ; + PMassKind x = mkPhrase (mkUtt x) ; + PQuality x = mkPhrase (mkUtt x) ; + PPlace x = mkPhrase (mkUtt x.name) ; + PPlaceKind x = mkPhrase (mkUtt x.name) ; + PCurrency x = mkPhrase (mkUtt x) ; + PLanguage x = mkPhrase (mkUtt x) ; + PCountry x = mkPhrase (mkUtt x) ; + PCitizenship x = mkPhrase (mkUtt (mkAP x)) ; + PDay d = mkPhrase (mkUtt d.name) ; + PTransport t = mkPhrase (mkUtt t.name) ; + PByTransport t = mkPhrase (mkUtt t) ; + + PYes = mkPhrase yes_Utt ; + PNo = mkPhrase no_Utt ; + PYesToNo = mkPhrase yes_Utt ; + + GObjectPlease o = lin Text (mkPhr noPConj (mkUtt o) please_Voc) | lin Text (mkUtt o) ; + + Is = mkCl ; + IsMass m q = mkCl (mkNP m) q ; + + SProp = mkS ; + SPropNot = mkS negativePol ; + QProp p = mkQS (mkQCl p) ; + + WherePlace place = mkQS (mkQCl where_IAdv place.name) ; + WherePerson person = mkQS (mkQCl where_IAdv person.name) ; + + PropAction a = a ; + + AmountCurrency num curr = mkNP num curr ; + + ObjItem i = i ; + ObjNumber n k = mkNP n k ; + ObjIndef k = mkNP a_Quant k ; + ObjPlural k = mkNP aPl_Det k ; + ObjPlur k = mkNP aPl_Det k ; + ObjMass k = mkNP k ; + ObjAndObj = mkNP and_Conj ; + OneObj o = o ; + + MassDrink d = d ; + DrinkNumber n k = mkNP n k ; + + This kind = mkNP this_Quant kind ; + That kind = mkNP that_Quant kind ; + These kind = mkNP this_Quant plNum kind ; + Those kind = mkNP that_Quant plNum kind ; + The kind = mkNP the_Quant kind ; + Thes kind = mkNP the_Quant plNum kind ; + ThisMass kind = mkNP this_Quant kind ; + ThatMass kind = mkNP that_Quant kind ; + TheMass kind = mkNP the_Quant kind ; + ThesePlur kind = mkNP this_Quant plNum kind ; + ThosePlur kind = mkNP that_Quant plNum kind ; + ThesPlur kind = mkNP the_Quant plNum kind ; + + SuchKind quality kind = mkCN quality kind ; + SuchMassKind quality kind = mkCN quality kind ; + Very property = mkAP very_AdA (mkAP property) ; + Too property = mkAP too_AdA (mkAP property) ; + PropQuality property = mkAP property ; + + ThePlace kind = let dd : Det = if_then_else Det kind.isPl thePl_Det theSg_Det + in placeNP dd kind ; + APlace kind = let dd : Det = if_then_else Det kind.isPl aPl_Det aSg_Det + in placeNP dd kind ; + + IMale, IFemale = mkPerson i_Pron ; + YouFamMale, YouFamFemale = mkPerson youSg_Pron ; + YouPolMale, YouPolFemale = mkPerson youPol_Pron ; + + LangNat n = n.lang ; + CitiNat n = n.prop ; + CountryNat n = n.country ; + PropCit c = c ; + + OnDay d = d.point ; + Today = today_Adv ; + + PersonName n = + {name = n ; isPron = False ; poss = mkQuant he_Pron} ; -- poss not used +---- NameString s = symb s ; --% + NameNN = symb "NN" ; + + NNumeral n = mkCard ; + + SHave p obj = mkS (mkCl p.name have_V2 obj) ; + SHaveNo p k = mkS negativePol (mkCl p.name have_V2 (mkNP aPl_Det k)) ; + SHaveNoMass p m = mkS negativePol (mkCl p.name have_V2 (mkNP m)) ; + QDoHave p obj = mkQS (mkQCl (mkCl p.name have_V2 obj)) ; + + AHaveCurr p curr = mkCl p.name have_V2 (mkNP aPl_Det curr) ; + ACitizen p n = mkCl p.name n ; + ABePlace p place = mkCl p.name place.at ; + ByTransp t = t.by ; + + AKnowSentence p s = mkCl p.name Lexicon.know_VS s ; + AKnowQuestion p s = mkCl p.name Lexicon.know_VQ s ; + AKnowPerson p q = mkCl p.name Lexicon.know_V2 q.name ; + +oper + +-- These operations are used internally in Sentences. + + mkPhrase : Utt -> Text = \u -> lin Text u ; -- no punctuation + mkGreeting : Str -> Text = \s -> lin Text (ss s) ; -- no punctuation + mkSentence : Utt -> Text = \t -> lin Text (postfixSS "." t | t) ; -- optional . + + mkPerson : Pron -> {name : NP ; isPron : Bool ; poss : Quant} = \p -> + {name = mkNP p ; isPron = True ; poss = mkQuant p} ; + +-- These are used in Words for each language. + + NPNationality : Type = {lang : NP ; country : NP ; prop : A} ; + + mkNPNationality : NP -> NP -> A -> NPNationality = \la,co,pro -> + {lang = la ; + country = co ; + prop = pro + } ; + + NPDay : Type = {name : NP ; point : Syntax.Adv ; habitual : Syntax.Adv} ; + + mkNPDay : NP -> Syntax.Adv -> Syntax.Adv -> NPDay = \d,p,h -> + {name = d ; + point = p ; + habitual = h + } ; + + NPPlace : Type = {name : NP ; at : Syntax.Adv ; to : Syntax.Adv} ; + CNPlace : Type = {name : CN ; at : Prep ; to : Prep; isPl : Bool} ; + + mkCNPlace : CN -> Prep -> Prep -> CNPlace = \p,i,t -> { + name = p ; + at = i ; + to = t ; + isPl = False + } ; + + mkCNPlacePl : CN -> Prep -> Prep -> CNPlace = \p,i,t -> { + name = p ; + at = i ; + to = t ; + isPl = True + } ; + + placeNP : Det -> CNPlace -> NPPlace = \det,kind -> + let name : NP = mkNP det kind.name in { + name = name ; + at = Syntax.mkAdv kind.at name ; + to = Syntax.mkAdv kind.to name + } ; + + NPPerson : Type = {name : NP ; isPron : Bool ; poss : Quant} ; + + relativePerson : GNumber -> CN -> (Num -> NP -> CN -> NP) -> NPPerson -> NPPerson = + \n,x,f,p -> + let num = if_then_else Num n plNum sgNum in { + name = case p.isPron of { + True => mkNP p.poss num x ; + _ => f num p.name x + } ; + isPron = False ; + poss = mkQuant he_Pron -- not used because not pron + } ; + + GNumber : PType = Bool ; + sing = False ; plur = True ; + +-- for languages without GenNP, use "the wife of p" + mkRelative : Bool -> CN -> NPPerson -> NPPerson = \n,x,p -> + relativePerson n x + (\a,b,c -> mkNP (mkNP the_Quant a c) (Syntax.mkAdv possess_Prep b)) p ; + +-- for languages with GenNP, use "p's wife" +-- relativePerson n x (\a,b,c -> mkNP (GenNP b) a c) p ; + + phrasePlease : Utt -> Text = \u -> --- lin Text (mkPhr noPConj u please_Voc) | + lin Text u ; + +------------------------------------------------------------------------------------------ +-- New things added 30/11/2011 by AR +------------------------------------------------------------------------------------------ + + lincat + VerbPhrase = VP ; + Modality = VV ; + lin + ADoVerbPhrase p vp = mkCl p.name vp ; + AModVerbPhrase m p vp = mkCl p.name (mkVP m vp) ; + ADoVerbPhrasePlace p vp x = mkCl p.name (mkVP vp x.at) ; + AModVerbPhrasePlace m p vp x = mkCl p.name (mkVP m (mkVP vp x.at)) ; + + QWhereDoVerbPhrase p vp = mkQS (mkQCl where_IAdv (mkCl p.name vp)) ; + QWhereModVerbPhrase m p vp = mkQS (mkQCl where_IAdv (mkCl p.name (mkVP m vp))) ; + + MWant = want_VV ; + MCan = can_VV ; + MKnow = can8know_VV ; + MMust = must_VV ; + + VPlay = mkVP play_V ; + VRun = mkVP run_V ; + VSit = mkVP sit_V ; + VSleep = mkVP sleep_V ; + VSwim = mkVP swim_V ; + VWalk = mkVP walk_V ; + VSit = mkVP sit_V ; + VStop = mkVP stop_V ; + VDrink = mkVP ; + VEat = mkVP ; + VRead = mkVP ; + VWait = mkVP ; + VWrite = mkVP ; + + V2Buy o = mkVP buy_V2 o ; + V2Drink o = mkVP drink_V2 o ; + V2Eat o = mkVP eat_V2 o ; + V2Wait o = mkVP wait_V2 o.name ; + + PImperativeFamPos v = phrasePlease (mkUtt (mkImp v)) ; + PImperativeFamNeg v = phrasePlease (mkUtt negativePol (mkImp v)) ; + PImperativePolPos v = phrasePlease (mkUtt politeImpForm (mkImp v)) ; + PImperativePolNeg v = phrasePlease (mkUtt politeImpForm negativePol (mkImp v)) ; + PImperativePlurPos v = phrasePlease (mkUtt pluralImpForm (mkImp v)) ; + PImperativePlurNeg v = phrasePlease (mkUtt pluralImpForm negativePol (mkImp v)) ; + +-- other new things allowed by the resource + +--- PBecause a b = SSubjS a because_Subj b ; + + He = mkPerson he_Pron ; + She = mkPerson she_Pron ; + WeMale, WeFemale = mkPerson we_Pron ; + YouPlurFamMale, YouPlurFamFemale = mkPerson youPl_Pron ; + YouPlurPolMale, YouPlurPolFemale = mkPerson youPl_Pron ; + TheyMale, TheyFemale = mkPerson they_Pron ; + +} diff --git a/testsuite/compiler/canonical/Words.gf b/testsuite/compiler/canonical/Words.gf new file mode 100644 index 000000000..08704990a --- /dev/null +++ b/testsuite/compiler/canonical/Words.gf @@ -0,0 +1,254 @@ +--2 Words and idiomatic phrases of the Phrasebook + + +-- (c) 2010 Aarne Ranta under LGPL --% + +abstract Words = Sentences ** { + + fun + +-- kinds of items (so far mostly food stuff) + + Apple : Kind ; + Beer : DrinkKind ; + Bread : MassKind ; + Cheese : MassKind ; + Chicken : MassKind ; + Coffee : DrinkKind ; + Fish : MassKind ; + Meat : MassKind ; + Milk : MassKind ; + Pizza : Kind ; + Salt : MassKind ; + Tea : DrinkKind ; + Water : DrinkKind ; + Wine : DrinkKind ; + +-- properties of kinds (so far mostly of food) + + Bad : Property ; + Boring : Property ; + Cheap : Property ; + Cold : Property ; + Delicious : Property ; + Expensive : Property ; + Fresh : Property ; + Good : Property ; + Suspect : Property ; + Warm : Property ; + +-- kinds of places + + Airport : PlaceKind ; + AmusementPark : PlaceKind ; + Bank : PlaceKind ; + Bar : PlaceKind ; + Cafeteria : PlaceKind ; + Center : PlaceKind ; + Cinema : PlaceKind ; + Church : PlaceKind ; + Disco : PlaceKind ; + Hospital : PlaceKind ; + Hotel : PlaceKind ; + Museum : PlaceKind ; + Park : PlaceKind ; + Parking : PlaceKind ; + Pharmacy : PlaceKind ; + PostOffice : PlaceKind ; + Pub : PlaceKind ; + Restaurant : PlaceKind ; + School : PlaceKind ; + Shop : PlaceKind ; + Station : PlaceKind ; + Supermarket : PlaceKind ; + Theatre : PlaceKind ; + Toilet : PlaceKind ; + University : PlaceKind ; + Zoo : PlaceKind ; + + CitRestaurant : Citizenship -> PlaceKind ; + +-- currency units + + DanishCrown : Currency ; + Dollar : Currency ; + Euro : Currency ; -- Germany, France, Italy, Finland, Spain, The Netherlands + Lei : Currency ; -- Romania + Leva : Currency ; -- Bulgaria + NorwegianCrown : Currency ; + Pound : Currency ; -- UK + Rouble : Currency ; -- Russia + Rupee : Currency ; -- India + SwedishCrown : Currency ; + Zloty : Currency ; -- Poland + Yuan : Currency ; -- China + + +-- nationalities, countries, languages, citizenships + + Belgian : Citizenship ; + Belgium : Country ; + Bulgarian : Nationality ; + Catalan : Nationality ; + Chinese : Nationality ; + Danish : Nationality ; + Dutch : Nationality ; + English : Nationality ; + Finnish : Nationality ; + Flemish : LAnguage ; + French : Nationality ; + German : Nationality ; + Hindi : LAnguage ; + India : Country ; + Indian : Citizenship ; + Italian : Nationality ; + Norwegian : Nationality ; + Polish : Nationality ; + Romanian : Nationality ; + Russian : Nationality ; + Spanish : Nationality ; + Swedish : Nationality ; + +-- means of transportation + + Bike : Transport ; + Bus : Transport ; + Car : Transport ; + Ferry : Transport ; + Plane : Transport ; + Subway : Transport ; + Taxi : Transport ; + Train : Transport ; + Tram : Transport ; + + ByFoot : ByTransport ; + + +-- Actions (which can be expressed by different structures in different languages). +-- Notice that also negations and questions can be formed from these. + + AHasAge : Person -> Number -> Action ; -- I am seventy years + AHasChildren: Person -> Number -> Action ; -- I have six children + AHasName : Person -> Name -> Action ; -- my name is Bond + AHasRoom : Person -> Number -> Action ; -- you have a room for five persons + AHasTable : Person -> Number -> Action ; -- you have a table for five persons + AHungry : Person -> Action ; -- I am hungry + AIll : Person -> Action ; -- I am ill + AKnow : Person -> Action ; -- I (don't) know + ALike : Person -> Item -> Action ; -- I like this pizza + ALive : Person -> Country -> Action ; -- I live in Sweden + ALove : Person -> Person -> Action ; -- I love you + AMarried : Person -> Action ; -- I am married + AReady : Person -> Action ; -- I am ready + AScared : Person -> Action ; -- I am scared + ASpeak : Person -> LAnguage -> Action ; -- I speak Finnish + AThirsty : Person -> Action ; -- I am thirsty + ATired : Person -> Action ; -- I am tired + AUnderstand : Person -> Action ; -- I (don't) understand + AWant : Person -> Object -> Action ; -- I want two apples + AWantGo : Person -> Place -> Action ; -- I want to go to the hospital + +-- Miscellaneous phrases. Notice that also negations and questions can be formed from +-- propositions. + + QWhatAge : Person -> Question ; -- how old are you + QWhatName : Person -> Question ; -- what is your name + HowMuchCost : Item -> Question ; -- how much does the pizza cost + ItCost : Item -> Price -> Proposition ; -- the pizza costs five euros + + PropOpen : Place -> Proposition ; -- the museum is open + PropClosed : Place -> Proposition ; -- the museum is closed + PropOpenDate : Place -> Date -> Proposition ; -- the museum is open today + PropClosedDate : Place -> Date -> Proposition ; -- the museum is closed today + PropOpenDay : Place -> Day -> Proposition ; -- the museum is open on Mondays + PropClosedDay : Place -> Day -> Proposition ; -- the museum is closed on Mondays + + PSeeYouPlaceDate : Place -> Date -> Greeting ; -- see you in the bar on Monday + PSeeYouPlace : Place -> Greeting ; -- see you in the bar + PSeeYouDate : Date -> Greeting ; -- see you on Monday + +-- family relations + + Wife, Husband : Person -> Person ; -- my wife, your husband + Son, Daughter : Person -> Person ; -- my son, your husband + Children : Person -> Person ; -- my children + +-- week days + + Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday : Day ; + + Tomorrow : Date ; + +-- transports + + HowFar : Place -> Question ; -- how far is the zoo ? + HowFarFrom : Place -> Place -> Question ; -- how far is the center from the hotel ? + HowFarFromBy : Place -> Place -> ByTransport -> Question ; + -- how far is the airport from the hotel by taxi ? + HowFarBy : Place -> ByTransport -> Question ; -- how far is the museum by bus ? + + WhichTranspPlace : Transport -> Place -> Question ; -- which bus goes to the hotel + IsTranspPlace : Transport -> Place -> Question ; -- is there a metro to the airport ? + +-- modifiers of places + + TheBest : Superlative ; + TheClosest : Superlative ; + TheCheapest : Superlative ; + TheMostExpensive : Superlative ; + TheMostPopular : Superlative ; + TheWorst : Superlative ; + + SuperlPlace : Superlative -> PlaceKind -> Place ; -- the best bar + + +-------------------------------------------------- +-- New 30/11/2011 AR +-------------------------------------------------- +{- 28/8/2012 still only available in Bul Eng Fin Swe Tha + + fun + Thai : Nationality ; + Baht : Currency ; -- Thailand + + Rice : MassKind ; + Pork : MassKind ; + Beef : MassKind ; + Noodles : PlurKind ; + Shrimps : PlurKind ; + + Chili : MassKind ; + Garlic : MassKind ; + + Durian : Kind ; + Mango : Kind ; + Pineapple : Kind ; + Egg : Kind ; + + Coke : DrinkKind ; + IceCream : DrinkKind ; --- both mass and plural + OrangeJuice : DrinkKind ; + Lemonade : DrinkKind ; + Salad : DrinkKind ; + + Beach : PlaceKind ; + + ItsRaining : Proposition ; + ItsWindy : Proposition ; + ItsWarm : Proposition ; + ItsCold : Proposition ; + SunShine : Proposition ; + + Smoke : VerbPhrase ; + + ADoctor : Person -> Action ; + AProfessor : Person -> Action ; + ALawyer : Person -> Action ; + AEngineer : Person -> Action ; + ATeacher : Person -> Action ; + ACook : Person -> Action ; + AStudent : Person -> Action ; + ABusinessman : Person -> Action ; +-} + +} diff --git a/testsuite/compiler/canonical/WordsBul.gf b/testsuite/compiler/canonical/WordsBul.gf new file mode 100644 index 000000000..527b3604a --- /dev/null +++ b/testsuite/compiler/canonical/WordsBul.gf @@ -0,0 +1,305 @@ +--2 Implementations of Words, with English as example + +concrete WordsBul of Words = SentencesBul ** + open + SyntaxBul, + (R = ResBul), + ParadigmsBul, + (L = LexiconBul), + (P = ParadigmsBul), + ExtraBul, + MorphoFunsBul, + Prelude in { + + flags + coding=utf8; + + lin + +-- Kinds; many of them are in the resource lexicon, others can be built by $mkN$. + + Apple = mkCN L.apple_N ; + Beer = mkCN L.beer_N ; + Bread = mkCN L.bread_N ; + Cheese = mkCN (mkN066 "сирене") ; + Chicken = mkCN (mkN065 "пиле") ; + Coffee = mkCN (mkN065 "кафе") ; + Fish = mkCN L.fish_N ; + Meat = mkCN (mkN054 "месо") ; + Milk = mkCN L.milk_N ; + Pizza = mkCN (mkN041 "пица") ; + Salt = mkCN L.salt_N ; + Tea = mkCN (mkN028 "чай") ; + Water = mkCN L.water_N ; + Wine = mkCN L.wine_N ; + +-- Properties; many of them are in the resource lexicon, others can be built by $mkA$. + + Bad = L.bad_A ; + Boring = mkA079 "еднообразен" ; + Cheap = mkA076 "евтин" ; + Cold = L.cold_A ; + Delicious = mkA079 "превъзходен" ; + Expensive = mkA076 "скъп" ; + Fresh = mkA076 "свеж" ; + Good = L.good_A ; + Suspect = mkA079 "подозрителен" ; + Warm = L.warm_A ; + +-- Places require different prepositions to express location; in some languages +-- also the directional preposition varies, but in English we use $to$, as +-- defined by $mkPlace$. + + Airport = mkPlace (mkN066 "летище") na_Prep ; + AmusementPark = mkCompoundPlace (mkA079 "увеселителен") (mkN001 "парк") in_Prep ; + Bank = mkPlace (mkN041 "банка") in_Prep ; + Bar = mkPlace (mkN001 "бар") in_Prep ; + Cafeteria = mkPlace (mkN065 "кафе") in_Prep ; + Center = mkPlace (mkN009a "център") in_Prep ; + Cinema = mkPlace (mkN054 "кино") na_Prep ; + Church = mkPlace (mkN041 "църква") in_Prep ; + Disco = mkPlace (mkN041 "дискотека") in_Prep ; + Hospital = mkPlace (mkN041 "болница") in_Prep ; + Hotel = mkPlace (mkN007 "хотел") in_Prep ; + Museum = mkPlace (mkN032 "музей") in_Prep ; + Park = mkPlace (mkN001 "парк") in_Prep ; + Parking = mkPlace (mkN007 "паркинг") na_Prep ; + Pharmacy = mkPlace (mkN041 "аптека") in_Prep ; + PostOffice = mkPlace (mkN041 "поща") in_Prep ; + Pub = mkPlace (mkN001 "бар") in_Prep ; + Restaurant = mkPlace (mkN007 "ресторант") in_Prep ; + School = mkPlace (mkN007 "училище") in_Prep ; + Shop = mkPlace (mkN007 "магазин") in_Prep ; + Station = mkPlace (mkN041 "гара") na_Prep ; + Supermarket = mkPlace (mkN007 "супермаркет") in_Prep ; + Theatre = mkPlace (mkN009 "театър") na_Prep ; + Toilet = mkPlace (mkN041 "тоалетна") in_Prep ; + University = mkPlace (mkN007 "университет") in_Prep ; + Zoo = mkPlace (mkN001 "зоопарк") in_Prep ; + + CitRestaurant cit = mkCNPlace (mkCN cit.s2 (mkN007 "ресторант")) in_Prep to_Prep ; + +-- Currencies; $crown$ is ambiguous between Danish and Swedish crowns. + + DanishCrown = mkCN (mkA078 "датски") (mkN041 "крона") | mkCN (mkN041 "крона") ; + Dollar = mkCN (mkN007 "долар") ; + Euro = mkCN (mkN054 "евро") ; + Lei = mkCN (mkN047 "лея") ; + Leva = mkCN (mkN001 "лев") ; + NorwegianCrown = mkCN (mkA078 "норвежки") (mkN041 "крона") | mkCN (mkN041 "крона") ; + Pound = mkCN (mkN007 "паунд") ; + Rouble = mkCN (mkN041 "рубла") ; + SwedishCrown = mkCN (mkA078 "шведски") (mkN041 "крона") | mkCN (mkN041 "крона") ; + Zloty = mkCN (mkN041 "злота") ; + Baht = mkCN (mkN007a "бат") ; + +-- Nationalities + + Belgian = mkCitizenship (mkN013 "белгиец") (mkN041 "белгийка") (mkA078 "белгийски") ; + Belgium = mkPN "Белгия" R.Fem ; + Bulgarian = mkNat (mkN018 "българин") (mkN041 "българка") (mkA078 "български") (mkPN "България" R.Fem) ; + Catalan = mkNat (mkN008a "каталонец") (mkN041 "каталонка") (mkA078 "каталонски") (mkPN "Каталуния" R.Fem) ; + Danish = mkNat (mkN018 "датчанин") (mkN041 "датчанка") (mkA078 "датски") (mkPN "Дания" R.Fem) ; + Dutch = mkNat (mkN008a "холандец") (mkN041 "холандка") (mkA078 "холандски") (mkPN "Холандия" R.Fem) ; + English = mkNat (mkN018 "англичанин") (mkN041 "англичанка") (mkA078 "английски") (mkPN "Англия" R.Fem) ; + Finnish = mkNat (mkN008a "финландец") (mkN041 "финландка") (mkA078 "финландски") (mkPN "Финландия" R.Fem) ; + Flemish = mkA078 "фламандски" ; + French = mkNat (mkN018 "французин") (mkN041 "французойка") (mkA078 "френски") (mkPN "Франция" R.Fem) ; + German = mkNat (mkN008a "германец") (mkN041 "германка") (mkA078 "немски") (mkPN "Германия" R.Fem) ; + Italian = mkNat (mkN008a "италианец") (mkN041 "италианка") (mkA078 "италиански") (mkPN "Италия" R.Fem) ; + Norwegian = mkNat (mkN008a "норвежец") (mkN041 "норвежка") (mkA078 "норвежки") (mkPN "Норвегия" R.Fem) ; + Polish = mkNat (mkN014 "поляк") (mkN047 "полякиня") (mkA078 "полски") (mkPN "Полша" R.Fem) ; + Romanian = mkNat (mkN008a "румънец") (mkN041 "румънка") (mkA078 "румънски") (mkPN "Румъния" R.Fem) ; + Russian = mkNat (mkN014 "руснак") (mkN047 "рускиня") (mkA078 "руски") (mkPN "Русия" R.Fem) ; + Swedish = mkNat (mkN007 "швед") (mkN041 "шведка") (mkA078 "шведски") (mkPN "Швеция" R.Fem) ; + Spanish = mkNat (mkN008a "испанец") (mkN041 "испанка") (mkA078 "испански") (mkPN "Испания" R.Fem) ; + Thai = mkNat (mkN008a "тайландец") (mkN041 "тайландка") (mkA078 "тайландски") (mkPN "Тайланд" R.Masc) ; + +-- Means of transportation + + Bike = mkTransport L.bike_N ; + Bus = mkTransport (mkN007 "автобус") ; + Car = mkTransport L.car_N ; + Ferry = mkTransport (mkN007 "ферибот") ; + Plane = mkTransport (mkN007 "самолет") ; + Subway = mkTransport (mkN054 "метро") ; + Taxi = mkTransport (mkN073 "такси") ; + Train = mkTransport (mkN001 "влак") ; + Tram = mkTransport (mkN032 "трамвай") ; + + ByFoot = P.mkAdv "пеша" ; + +-- Actions: the predication patterns are very often language-dependent. + + AHasAge p num = mkCl p.name (SyntaxBul.mkAdv na_Prep (mkNP num L.year_N)) ; + AHasChildren p num = mkCl p.name have_V2 (mkNP num L.child_N) ; + AHasRoom p num = mkCl p.name have_V2 (mkNP (mkNP a_Det (mkN047 "стая")) (SyntaxBul.mkAdv (mkPrep "за" R.Acc) (mkNP num (mkN014 "човек")))) ; + AHasTable p num = mkCl p.name have_V2 (mkNP (mkNP a_Det (mkN041 "маса")) (SyntaxBul.mkAdv (mkPrep "за" R.Acc) (mkNP num (mkN014 "човек")))) ; + AHasName p name = mkCl p.name (dirV2 (medialV (actionV (mkV186 "казвам") (mkV156 "кажа")) R.Acc)) name ; + AHungry p = mkCl p.name (mkA079 "гладен") ; + AIll p = mkCl p.name (mkA079 "болен") ; + AKnow p = mkCl p.name (actionV (mkV186 "знам") (mkV162 "зная")) ; + ALike p item = mkCl p.name (dirV2 (actionV (mkV186 "харесвам") (mkV186 "харесам"))) item ; + ALive p co = mkCl p.name (mkVP (mkVP (stateV (mkV160 "живея"))) (SyntaxBul.mkAdv in_Prep (mkNP co))) ; + ALove p q = mkCl p.name (dirV2 (actionV (mkV186 "обичам") (mkV152 "обикна"))) q.name ; + AMarried p = mkCl p.name (mkA076 (case p.name.gn of { + R.GSg R.Fem => "омъжен" ; + _ => "женен" + })) ; + AReady p = mkCl p.name (mkA076 "готов") ; + AScared p = mkCl p.name (mkA076 "уплашен") ; + ASpeak p lang = mkCl p.name (dirV2 (stateV (mkV173 "говоря"))) (mkNP (substantiveN lang (R.AMasc R.NonHuman))) ; + AThirsty p = mkCl p.name (mkA079 "жаден") ; + ATired p = mkCl p.name (mkA076 "уморен") ; + AUnderstand p = mkCl p.name (actionV (mkV186 "разбирам") (mkV170 "разбера")) ; + AWant p obj = mkCl p.name (dirV2 (stateV (mkV186 "искам"))) obj ; + AWantGo p place = mkCl p.name want_VV (mkVP (mkVP (actionV (mkV186 "отивам") (mkV146 "отида"))) place.to) ; + +-- miscellaneous + + QWhatName p = mkQS (mkQCl how_IAdv (mkCl p.name (medialV (actionV (mkV186 "казвам") (mkV156 "кажа")) R.Acc))) ; + QWhatAge p = mkQS (mkQCl (MorphoFunsBul.mkIAdv "на колко") (mkCl p.name (mkNP a_Quant plNum L.year_N))) ; + HowMuchCost item = mkQS (mkQCl how8much_IAdv (mkCl item (stateV (mkV186 "струвам")))) ; + ItCost item price = mkCl item (dirV2 (stateV (mkV186 "струвам"))) price ; + + PropOpen p = mkCl p.name open_AP ; + PropClosed p = mkCl p.name closed_AP ; + PropOpenDate p d = mkCl p.name (mkVP (mkVP open_AP) d) ; + PropClosedDate p d = mkCl p.name (mkVP (mkVP closed_AP) d) ; + PropOpenDay p d = mkCl p.name (mkVP (mkVP open_AP) d.habitual) ; + PropClosedDay p d = mkCl p.name (mkVP (mkVP closed_AP) d.habitual) ; + +-- Building phrases from strings is complicated: the solution is to use +-- mkText : Text -> Text -> Text ; + + PSeeYouDate d = mkText (lin Text (ss ("ще се видим"))) (mkPhrase (mkUtt d)) ; + PSeeYouPlace p = mkText (lin Text (ss ("ще се видим"))) (mkPhrase (mkUtt p.at)) ; + PSeeYouPlaceDate p d = + mkText (lin Text (ss ("ще се видим"))) + (mkText (mkPhrase (mkUtt p.at)) (mkPhrase (mkUtt d))) ; + +-- Relations are expressed as "my wife" or "my son's wife", as defined by $xOf$ +-- below. Languages without productive genitives must use an equivalent of +-- "the wife of my son" for non-pronouns. + + Wife = xOf sing (mkN041 "съпруга") ; + Husband = xOf sing (mkN015 "съпруг") ; + Son = xOf sing (mkN018 "син") ; + Daughter = xOf sing (mkN047 "дъщеря") ; + Children = xOf plur L.child_N ; + +-- week days + + Monday = mkDay (mkN014 "понеделник") ; + Tuesday = mkDay (mkN014 "вторник") ; + Wednesday = mkDay (mkN043 "сряда") ; + Thursday = mkDay (mkN014 "четвъртък") ; + Friday = mkDay (mkN014 "петък") ; + Saturday = mkDay (mkN041 "събота") ; + Sunday = mkDay (mkN047 "неделя") ; + + Tomorrow = P.mkAdv "утре" ; + +-- modifiers of places + + TheBest = mkSuperl L.good_A ; + TheClosest = mkSuperl L.near_A ; + TheCheapest = mkSuperl (mkA076 "евтин") ; + TheMostExpensive = mkSuperl (mkA076 "скъп") ; + TheMostPopular = mkSuperl (mkA079 "известен") ; + TheWorst = mkSuperl L.bad_A ; + + SuperlPlace sup p = placeNP sup p ; + + +-- transports + + HowFar place = mkQS (mkQCl far_IAdv place.name) ; + HowFarFrom x y = mkQS (mkQCl far_IAdv (mkNP y.name (SyntaxBul.mkAdv from_Prep x.name))) ; + HowFarFromBy x y t = + mkQS (mkQCl far_IAdv (mkNP (mkNP y.name (SyntaxBul.mkAdv from_Prep x.name)) t)) ; + HowFarBy y t = mkQS (mkQCl far_IAdv (mkNP y.name t)) ; + + WhichTranspPlace trans place = + mkQS (mkQCl (mkIP which_IDet trans.name) (mkVP (mkVP L.go_V) place.to)) ; + + IsTranspPlace trans place = + mkQS (mkQCl (mkCl (mkCN trans.name place.to))) ; + + Rice = mkCN (mkN040a "ориз") ; + Pork = mkCN (mkN054 "свинско") ; + Beef = mkCN (mkN054 "телешко") ; + Egg = mkCN (mkN066 "яйце") ; + Noodles = mkCN (mkN075 "спагети") ; + Shrimps = mkCN (mkN041 "скарида") ; + Chili = mkCN (mkN065 "чили") ; + Garlic = mkCN (mkN007 "чесън") ; + Durian = mkCN (mkN007 "дуриан") ; + Mango = mkCN (mkN065 "манго") ; + Pineapple = mkCN (mkN007 "ананас") ; + Coke = mkCN (mkN041 "кола") ; + IceCream = mkCN (mkN007 "сладолед") ; + Salad = mkCN (mkN041 "салата") ; + OrangeJuice = mkCN (mkA076 "портокалов") (mkN001 "сок") ; + Lemonade = mkCN (mkN041 "лимонада") ; + + Beach = mkPlace (mkN001 "плаж") na_Prep ; + + ItsRaining = mkCl (mkVP (stateV (mkV174 "валя"))) ; + ItsCold = mkCl (mkVP (mkA076 "студен")) ; + ItsWarm = mkCl (mkVP (mkA080 "топъл")) ; + ItsWindy = mkCl (mkVP (mkA076 "ветровит")) ; + SunShine = mkCl (progressiveVP (mkVP (actionV (mkV186 "пеквам") (mkV148 "пека")))) ; + + Smoke = mkVP (stateV (mkV176 "пуша")) ; + + ADoctor = mkProfession (mkN007a "доктор") ; + AProfessor = mkProfession (mkN007a "професор") ; + ALawyer = mkProfession (mkN007a "адвокат") ; + AEngineer = mkProfession (mkN007a "инженер") ; + ATeacher = mkProfession (mkN031a "учител") ; + ACook = mkProfession (mkN007b "готвач") ; + AStudent = mkProfession (mkN007a "студент") ; + ABusinessman = mkProfession (mkN007a "бизнесмен") ; + +-- auxiliaries + + oper + mkProfession : N -> NPPerson -> Cl = \n,p -> mkCl p.name n ; + + mkCitizenship : N -> N -> A -> Citizenship + = \male, female, adj -> lin Citizenship {s1 = table {R.Fem => female.s; _ => male.s}; s2 = adj} ; + + mkNat : N -> N -> A -> PN -> Nationality + = \male, female, adj, country -> lin Nationality {s1 = table {R.Fem => female.s; _ => male.s}; s2 = adj; s3 = country} ; + + mkDay : N -> {name : NP ; point : Adv ; habitual : Adv} = \d -> + let day : NP = mkNP d ; + in mkNPDay day + (SyntaxBul.mkAdv in_Prep day) + (SyntaxBul.mkAdv in_Prep (mkNP the_Quant plNum (mkCN d))) ; + + mkCompoundPlace : A -> N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \a, n, p -> + mkCNPlace (mkCN a n) p to_Prep ; + + mkPlace : N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \n,p -> + mkCNPlace (mkCN n) p to_Prep ; + + open_AP = mkAP (mkA076 "отворен") ; + closed_AP = mkAP (mkA076 "затворен") ; + + xOf : GNumber -> N -> NPPerson -> NPPerson = \n,x,p -> + relativePerson n (mkCN x) (\a,b,c -> mkNP (mkNP the_Quant a c) (SyntaxBul.mkAdv (mkPrep "" R.Dat) b)) p ; + + mkTransport : N -> {name : CN ; by : Adv} = \n -> { + name = mkCN n ; + by = SyntaxBul.mkAdv with_Prep (mkNP n) + } ; + + mkSuperl : A -> Det = \a -> SyntaxBul.mkDet the_Art (SyntaxBul.mkOrd a) ; + + far_IAdv = ExtraBul.IAdvAdv (ss "далече") ; + + na_Prep = mkPrep "на" R.Acc ; + +} diff --git a/testsuite/compiler/canonical/WordsGer.gf b/testsuite/compiler/canonical/WordsGer.gf new file mode 100644 index 000000000..4984eb080 --- /dev/null +++ b/testsuite/compiler/canonical/WordsGer.gf @@ -0,0 +1,262 @@ +-- (c) 2009 Aarne Ranta under LGPL +--# -coding=latin1 + +concrete WordsGer of Words = SentencesGer ** + open SyntaxGer, ParadigmsGer, IrregGer, (L = LexiconGer), ExtraGer, Prelude in { + + lin + +-- kinds of food + + Apple = mkCN L.apple_N ; + Beer = mkCN L.beer_N ; + Bread = mkCN L.bread_N ; + Cheese = mkCN (mkN "Kse" "Kse" "Kse" "Kse" "Kse" "Kse" masculine) ; + Chicken = mkCN (mkN "Huhn" "Huhn" "Huhn" "Huhn" "Hhner" "Hhner" neuter) ; + Coffee = mkCN (mkN "Kaffee" "Kaffee" "Kaffee" "Kaffee" "Kaffees" "Kaffee" masculine) ; + Fish = mkCN L.fish_N ; + Meat = mkCN (mkN "Fleisch" "Fleisch" "Fleisch" "Fleisch" "Fleisch" "Fleisch" neuter) ; + Milk = mkCN L.milk_N ; + Pizza = mkCN (mkN "Pizza" "Pizzen" feminine) ; + Salt = mkCN L.salt_N ; + Tea = mkCN (mkN "Tee" "Tee" "Tee" "Tee" "Tees" "Tees" masculine) ; + Water = mkCN L.water_N ; + Wine = mkCN L.wine_N ; + +-- properties + + Bad = L.bad_A ; + Cheap = mkA "billig" ; + Boring = mkA "langweilig" ; + Cold = L.cold_A ; + Delicious = mkA "lecker" ; + Expensive = mkA "teuer" ; + Fresh = mkA "frisch" ; + Good = L.good_A ; + Warm = L.warm_A ; + Suspect = mkA "verdchtig" ; + +-- places + + Airport = mkPlace (mkN "Flughafen" "Flughfen" masculine) on_Prep zu_Prep ; + Church = mkPlace (mkN "Kirche") in_Prep inAcc_Prep ; + Hospital = mkPlace (mkN "Krankenhaus" "Krankenhuser" neuter) in_Prep inAcc_Prep ; + Restaurant = mkPlace (mkN "Restaurant" "Restaurants" neuter) in_Prep inAcc_Prep ; + Station = mkPlace (mkN "Bahnhof" "Bahnhfe" masculine) on_Prep zu_Prep ; + University = mkPlace (mkN "Universitt" "Universitten" feminine) in_Prep zu_Prep ; + + AmusementPark = mkPlace (mkN "Vergngungspark" "Vergngungspark" "Vergngungspark" "Vergngungspark" "Vergngungsparks" "Vergngungsparks" masculine) in_Prep inAcc_Prep ; + Bank = mkPlace (mkN "Bank" "Bank" "Bank" "Bank" "Banken" "Banken" feminine) in_Prep zu_Prep ; + Bar = mkPlace (mkN "Bar" "Bar" "Bar" "Bar" "Bars" "Bars" feminine) in_Prep inAcc_Prep ; + Cafeteria = mkPlace (mkN "Cafeteria" "Cafeteria" "Cafeteria" "Cafeteria" "Cafeterien" "Cafeterien" feminine) in_Prep inAcc_Prep ; + Center = mkPlace (mkN "Zentrum" "Zentrum" "Zentrum" "Zentrum" "Zentren" "Zentren" neuter) in_Prep zu_Prep ; + Cinema = mkPlace (mkN "Kino" "Kino" "Kino" "Kino" "Kinos" "Kinos" neuter) in_Prep inAcc_Prep ; + Disco = mkPlace (mkN "Disco" "Disco" "Disco" "Disco" "Discos" "Discos" feminine) in_Prep inAcc_Prep ; + Hotel = mkPlace (mkN "Hotel" "Hotel" "Hotel" "Hotel" "Hotels" "Hotels" neuter) in_Prep inAcc_Prep ; + Museum = mkPlace (mkN "Museum" "Museum" "Museum" "Museum" "Museen" "Museen" neuter) in_Prep inAcc_Prep ; + Park = mkPlace (mkN "Park" "Park" "Park" "Park" "Parks" "Parks" masculine) in_Prep inAcc_Prep ; + Parking = mkPlace (mkN "Parkplatz" "Parkplatz" "Parkplatz" "Parkplatz" "Parkplatzen" "Parkplatzen" masculine) on_Prep zu_Prep ; + Pharmacy = mkPlace (mkN "Apotheke" "Apotheke" "Apotheke" "Apotheke" "Apotheken" "Apotheken" feminine) in_Prep zu_Prep ; + PostOffice = mkPlace (mkN "Post" "Post" "Post" "Post" "Posten" "Posten" feminine) in_Prep inAcc_Prep ; + Pub = mkPlace (mkN "Kneipe" "Kneipe" "Kneipe" "Kneipe" "Kneipen" "Kneipen" feminine) in_Prep inAcc_Prep; + School = mkPlace (mkN "Schule" "Schule" "Schule" "Schule" "Schulen" "Schule" feminine) in_Prep inAcc_Prep ; + Shop = mkPlace (mkN "Geschft" "Geschft" "Geschft" "Geschft" "Geschfte" "Geschfte" neuter) in_Prep inAcc_Prep ; + Supermarket = mkPlace (mkN "Supermarkt" "Supermarkt" "Supermarkt" "Supermarkt" "Supermrkten" "Supermrkte" masculine) in_Prep inAcc_Prep ; + Theatre = mkPlace (mkN "Theater" "Theater" "Theater" "Theaters" "Theatern" "Thaters" neuter) in_Prep inAcc_Prep ; + Toilet = mkPlace (mkN "Toilette" "Toilette" "Toilette" "Toilette" "Toiletten" "Toiletten" feminine) in_Prep (mkPrep "auf" accusative) ; + Zoo = mkPlace (mkN "Zoo" "Zoo" "Zoo" "Zoo" "Zoos" "Zoos" masculine) in_Prep inAcc_Prep ; + + +CitRestaurant cit = mkCNPlace (mkCN cit (mkN "Restaurant" "Restaurants" neuter)) in_Prep inAcc_Prep ; + + +-- currencies + + DanishCrown = mkCN (mkA "Dnisch") (mkN "Krone" "Kronen" feminine) | mkCN (mkN "Krone" "Kronen" feminine) ; + Dollar = mkCN (mkN "Dollar" "Dollar" "Dollar" "Dollar" "Dollar" "Dollar" masculine) ; + Euro = mkCN (mkN "Euro" "Euro" "Euro" "Euro" "Euro" "Euro" neuter) ; + Lei = mkCN (mkN "Leu" "Leu" "Leu" "Leu" "Lei" "Lei" masculine) ; + SwedishCrown = mkCN (mkA "Schwedisch") (mkN "Krone" "Kronen" feminine) | mkCN (mkN "Krone" "Kronen" feminine) ; + Leva = mkCN (mkN "Lewa" "Lewa" "Lewa" "Lewa" "Lewa" "Lewa" feminine); + NorwegianCrown = mkCN (mkA "Norwegisch") (mkN "Krone" "Kronen" feminine) | mkCN (mkN "Krone" "Kronen" feminine) ; + Pound = mkCN (mkN "Pfund" "Pfund" "Pfund" "Pfund" "Pfund" "Pfund" neuter) ; + Rouble = mkCN (mkN "Rubel" "Rubel" "Rubel" "Rubel" "Rubels" "Rubels" masculine); + Zloty = mkCN (mkN "Zloty" "Zloty" "Zloty" "Zloty" "Zloty" "Zloty" masculine); + + + +-- nationalities + + Belgian = mkA "belgisch" ; + Belgium = mkNP (mkPN "Belgien") ; + Bulgarian = mkNat "Bulgarien" "Bulgarisch" "bulgarisch" ; + Catalan = mkNat "Katalonien" "Katalanisch" "katalanisch" ; + Danish = mkNat "Dnemark" "Dnisch" "dnisch" ; + Dutch = mkNat "den Niederlanden" "Niederlndisch" "niederlndisch" ; + English = mkNat "England" "Englisch" "englisch" ; + Finnish = mkNat "Finnland" "Finnisch" "finnisch" ; + Flemish = mkCN (mkN "Flmisch" "Flmisch" neuter) ; + French = mkNat "Frankreich" "Franzsisch" "franzsisch" ; + German = mkNat "Deutschland" "Deutsch" "deutsche" ; + Italian = mkNat "Italien" "Italienisch" "italienisch" ; + Norwegian = mkNat "Norwegen" "Norwegisch" "norwegisch" ; + Polish = mkNat "Polen" "Polnisch" "polnisch" ; + Romanian = mkNat "Rumnien" "Rumnisch" "rumnisch" ; + Russian = mkNat "Russland" "Russisch" "russisch" ; + Spanish = mkNat "Spanien" "Spanisch" "spanisch" ; + Swedish = mkNat "Schweden" "Schwedisch" "schwedisch" ; + + + +-- actions + + AHasAge p num = prop (mkCl p.name (mkNP num L.year_N)) ; + AHasName p name = prop (mkCl p.name (mkV2 heien_V) name) ; + AHungry p = prop (mkCl p.name (mkA "hungrig")) ; + AHasChildren p num = prop (mkCl p.name have_V2 (mkNP num L.child_N)) ; + AHasRoom p num = prop (mkCl p.name have_V2 + (mkNP (mkNP a_Det (mkN "Zimmer" "Zimmer" neuter)) + (SyntaxGer.mkAdv for_Prep (mkNP num (mkN "Persone"))))) ; + AHasTable p num = prop (mkCl p.name have_V2 + (mkNP (mkNP a_Det (mkN "Tisch")) + (SyntaxGer.mkAdv for_Prep (mkNP num (mkN "Persone"))))) ; + AIll p = prop (mkCl p.name (mkA "krank")) ; + AKnow p = prop (mkCl p.name wissen_V) ; + ALike p item = prop (mkCl p.name (mkV2 mgen_V) item) ; + ALive p co = prop (mkCl p.name (mkVP (mkVP (mkV "wohnen")) (SyntaxGer.mkAdv in_Prep co))) ; + ALove p q = prop (mkCl p.name (mkV2 (mkV "lieben")) q.name) ; + AMarried p = prop (mkCl p.name (mkA "verheiratet")) ; + AReady p = prop (mkCl p.name (mkA "bereit")) ; + AScared p = prop (mkCl p.name have_V2 (mkNP (mkN "Angst" "Angsten" feminine))) ; + ASpeak p lang = mkProp (mkCl p.name (mkV2 sprechen_V) (mkNP lang)) + (mkS (mkCl p.name (mkV2 sprechen_V) (mkNP no_Quant lang))) ; + AThirsty p = prop (mkCl p.name (mkA "durstig")) ; + ATired p = prop (mkCl p.name (mkA "mde")) ; + AUnderstand p = prop (mkCl p.name (fixprefixV "ver" stehen_V)) ; + AWant p obj = prop (mkCl p.name want_VV (mkVP have_V2 obj)) ; + AWantGo p place = prop (mkCl p.name want_VV (mkVP (mkVP L.go_V) place.to)) ; + +-- miscellaneous + + QWhatName p = mkQS (mkQCl how_IAdv (mkCl p.name heien_V)) ; + QWhatAge p = mkQS (mkQCl (ICompAP (mkAP L.old_A)) p.name) ; + + PropOpen p = prop (mkCl p.name open_Adv) ; + PropClosed p = prop (mkCl p.name closed_Adv) ; + PropOpenDate p d = prop (mkCl p.name (mkVP (mkVP d) open_Adv)) ; + PropClosedDate p d = prop (mkCl p.name (mkVP (mkVP d) closed_Adv)) ; + PropOpenDay p d = prop (mkCl p.name (mkVP (mkVP d.habitual) open_Adv)) ; + PropClosedDay p d = prop (mkCl p.name (mkVP (mkVP d.habitual) closed_Adv)) ; + + HowMuchCost item = mkQS (mkQCl how8much_IAdv (mkCl item (mkV "kosten"))) ; + ItCost item price = prop (mkCl item (mkV2 (mkV "kosten")) price) ; + +-- Building phrases from strings is complicated: the solution is to use +-- mkText : Text -> Text -> Text ; + + PSeeYouDate d = mkText (lin Text (ss ("wir sehen uns"))) (mkPhrase (mkUtt d)) ; + PSeeYouPlace p = mkText (lin Text (ss ("wir sehen uns"))) (mkPhrase (mkUtt p.at)) ; + PSeeYouPlaceDate p d = + mkText (lin Text (ss ("wir sehen uns"))) + (mkText (mkPhrase (mkUtt d)) (mkPhrase (mkUtt p.at))) ; + + +-- Relations are expressed as "my wife" or "my son's wife", as defined by $xOf$ +-- below. Languages without productive genitives must use an equivalent of +-- "the wife of my son" for non-pronouns. + + Wife = xOf sing (mkN "Frau" "Frauen" feminine) ; + Husband = xOf sing L.man_N ; + Son = xOf sing (mkN "Sohn" "Shne" masculine) ; + Daughter = xOf sing (mkN "Tochter" "Tchter" feminine) ; + Children = xOf plur L.child_N ; + +-- week days + + Monday = mkDay "Montag" ; + Tuesday = mkDay "Dienstag" ; + Wednesday = mkDay "Mittwoch" ; + Thursday = mkDay "Donnerstag" ; + Friday = mkDay "Freitag" ; + Saturday = mkDay "Samstag" ; + Sunday = mkDay "Sonntag" ; + + Tomorrow = ParadigmsGer.mkAdv "morgen" ; + + TheBest = mkSuperl L.good_A ; + TheClosest = mkSuperl L.near_A ; + TheCheapest = mkSuperl (mkA "billig") ; + TheMostExpensive = mkSuperl (mkA "teuer") ; + TheMostPopular = mkSuperl (mkA "beliebt") ; + TheWorst = mkSuperl (mkA "schlimm") ; + + SuperlPlace sup p = placeNP sup p ; + + +-- means of transportation + + Bike = mkTransport L.bike_N ; + Bus = mkTransport (mkN "Bus" "Bus" "Bus" "Bus" "Buss" "Buss" masculine) ; + Car = mkTransport L.car_N ; + Ferry = mkTransport (mkN "Fhre" "Fhre" "Fhre" "Fhre" "Fhren" "Fhren" feminine) ; + Plane = mkTransport (mkN "Flugzeug" "Flugzeug" "Flugzeug" "Flugzeug" "Flugzeuge" "Flugzeuge" neuter) ; + Subway = mkTransport (mkN "U-Bahn" "U-Bahn" "U-Bahn" "U-Bahn" "U-Bahnen" "U-Bahnen" feminine) ; + Taxi = mkTransport (mkN "Taxi" "Taxi" "Taxi" "Taxi" "Taxis" "Taxis" neuter) ; + Train = mkTransport (mkN "Zug" "Zug" "Zug" "Zug" "Zge" "Zge" masculine) ; + Tram = mkTransport (mkN "Straenbahn" "Straenbahn" "Straenbahn" "Straenbahn" "Straenbahnen" "Straenbahnen" feminine) ; + + ByFoot = ParadigmsGer.mkAdv "zu Fu" ; + + + HowFar place = mkQS (mkQCl far_IAdv place.name) ; + HowFarFrom x y = mkQS (mkQCl far_IAdv (mkNP (mkNP y.name (SyntaxGer.mkAdv von_Prep x.name)) (ParadigmsGer.mkAdv "entfernt"))) ; + HowFarFromBy x y t = + mkQS (mkQCl far_IAdv (mkCl (mkVP (SyntaxGer.mkAdv zu_Prep (mkNP (mkNP y.name (SyntaxGer.mkAdv von_Prep x.name)) t))))) ; + HowFarBy y t = mkQS (mkQCl far_IAdv (mkCl (mkVP (SyntaxGer.mkAdv zu_Prep (mkNP y.name t))))) ; + + WhichTranspPlace trans place = + mkQS (mkQCl (mkIP which_IDet trans.name) (mkVP (mkVP L.go_V) place.to)) ; + + IsTranspPlace trans place = + mkQS (mkQCl (mkCl (mkCN trans.name place.to))) ; + + + + + oper + + mkNat : Str -> Str -> Str -> {lang : CN ; prop : A ; country : NP} = \co, la, adj -> + {lang = mkCN (mkN la la neuter) ; + prop = mkA adj ; country = mkNP (mkPN co)} ; + + mkDay : Str -> {name : NP ; point : Adv ; habitual : Adv} = \d -> + let day = mkNP (mkPN d masculine) in + {name = day ; + point = SyntaxGer.mkAdv (mkPrep "am" dative) day ; ---- am + habitual = ParadigmsGer.mkAdv (d + "s") ---- + } ; + + mkPlace : N -> Prep -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \p,at,to -> { + name = mkCN p ; + at = at ; + to = to ; + isPl = False + } ; + + open_Adv = ParadigmsGer.mkAdv "geffnet" ; ---- Adv to get right word order easily + closed_Adv = ParadigmsGer.mkAdv "geschlossen" ; + + xOf : GNumber -> N -> NPPerson -> NPPerson = \n,x,p -> mkRelative n (mkCN x) p ; + + + mkSuperl : A -> Det = \a -> SyntaxGer.mkDet the_Art (SyntaxGer.mkOrd a) ; + + + mkTransport : N -> {name : CN ; by : Adv} = \n -> { + name = mkCN n ; + by = SyntaxGer.mkAdv by8means_Prep (mkNP the_Det n) + } ; + + far_IAdv = ss "wie weit" ** {lock_IAdv = <>} ; + +} diff --git a/testsuite/compiler/canonical/run.sh b/testsuite/compiler/canonical/run.sh new file mode 100755 index 000000000..b9cc7e25b --- /dev/null +++ b/testsuite/compiler/canonical/run.sh @@ -0,0 +1,23 @@ +#!/usr/bin/env sh + +# https://github.com/GrammaticalFramework/gf-core/issues/100 +stack run -- --batch --output-format=canonical_gf PhrasebookBul.gf +stack run -- --batch canonical/PhrasebookBul.gf + +# https://github.com/GrammaticalFramework/gf-core/issues/101 +stack run -- --batch --output-format=canonical_gf PhrasebookGer.gf +for s in c2 objCtrl; do + grep VRead --after-context=216 canonical/PhrasebookGer.gf | grep "$s" > /dev/null + if [ $? -ne 1 ]; then + echo "$s found" + exit 1 + fi +done + +# https://github.com/GrammaticalFramework/gf-core/issues/102 +stack run -- --batch --output-format=canonical_gf FoodsFin.gf +diff canonical/FoodsFin.gf ./FoodsFin.gf.gold +if [ $? -ne 0 ]; then + echo "Compiled grammar doesn't match gold version" + exit 1 +fi From 4436cb101e0756ad2a452fe81f0db2f18c14d60e Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 30 Jun 2021 13:47:15 +0200 Subject: [PATCH 04/16] Move testsuite/compiler/canonical on level up, update test script --- testsuite/{compiler => }/canonical/.gitignore | 0 .../gold/FoodsFin.gf} | 0 .../canonical => canonical/grammars}/Foods.gf | 0 .../grammars}/FoodsFin.gf | 0 .../grammars}/FoodsI.gf | 0 .../grammars}/Greetings.gf | 0 .../grammars}/GreetingsBul.gf | 0 .../grammars}/GreetingsGer.gf | 0 .../grammars}/LexFoods.gf | 0 .../grammars}/LexFoodsFin.gf | 0 .../grammars}/Phrasebook.gf | 0 .../grammars}/PhrasebookBul.gf | 0 .../grammars}/PhrasebookGer.gf | 0 .../grammars}/Sentences.gf | 0 .../grammars}/SentencesBul.gf | 0 .../grammars}/SentencesGer.gf | 0 .../grammars}/SentencesI.gf | 0 .../canonical => canonical/grammars}/Words.gf | 0 .../grammars}/WordsBul.gf | 0 .../grammars}/WordsGer.gf | 0 testsuite/canonical/run.sh | 42 +++++++++++++++++++ testsuite/compiler/canonical/run.sh | 23 ---------- 22 files changed, 42 insertions(+), 23 deletions(-) rename testsuite/{compiler => }/canonical/.gitignore (100%) rename testsuite/{compiler/canonical/FoodsFin.gf.gold => canonical/gold/FoodsFin.gf} (100%) rename testsuite/{compiler/canonical => canonical/grammars}/Foods.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/FoodsFin.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/FoodsI.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/Greetings.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/GreetingsBul.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/GreetingsGer.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/LexFoods.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/LexFoodsFin.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/Phrasebook.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/PhrasebookBul.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/PhrasebookGer.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/Sentences.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/SentencesBul.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/SentencesGer.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/SentencesI.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/Words.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/WordsBul.gf (100%) rename testsuite/{compiler/canonical => canonical/grammars}/WordsGer.gf (100%) create mode 100755 testsuite/canonical/run.sh delete mode 100755 testsuite/compiler/canonical/run.sh diff --git a/testsuite/compiler/canonical/.gitignore b/testsuite/canonical/.gitignore similarity index 100% rename from testsuite/compiler/canonical/.gitignore rename to testsuite/canonical/.gitignore diff --git a/testsuite/compiler/canonical/FoodsFin.gf.gold b/testsuite/canonical/gold/FoodsFin.gf similarity index 100% rename from testsuite/compiler/canonical/FoodsFin.gf.gold rename to testsuite/canonical/gold/FoodsFin.gf diff --git a/testsuite/compiler/canonical/Foods.gf b/testsuite/canonical/grammars/Foods.gf similarity index 100% rename from testsuite/compiler/canonical/Foods.gf rename to testsuite/canonical/grammars/Foods.gf diff --git a/testsuite/compiler/canonical/FoodsFin.gf b/testsuite/canonical/grammars/FoodsFin.gf similarity index 100% rename from testsuite/compiler/canonical/FoodsFin.gf rename to testsuite/canonical/grammars/FoodsFin.gf diff --git a/testsuite/compiler/canonical/FoodsI.gf b/testsuite/canonical/grammars/FoodsI.gf similarity index 100% rename from testsuite/compiler/canonical/FoodsI.gf rename to testsuite/canonical/grammars/FoodsI.gf diff --git a/testsuite/compiler/canonical/Greetings.gf b/testsuite/canonical/grammars/Greetings.gf similarity index 100% rename from testsuite/compiler/canonical/Greetings.gf rename to testsuite/canonical/grammars/Greetings.gf diff --git a/testsuite/compiler/canonical/GreetingsBul.gf b/testsuite/canonical/grammars/GreetingsBul.gf similarity index 100% rename from testsuite/compiler/canonical/GreetingsBul.gf rename to testsuite/canonical/grammars/GreetingsBul.gf diff --git a/testsuite/compiler/canonical/GreetingsGer.gf b/testsuite/canonical/grammars/GreetingsGer.gf similarity index 100% rename from testsuite/compiler/canonical/GreetingsGer.gf rename to testsuite/canonical/grammars/GreetingsGer.gf diff --git a/testsuite/compiler/canonical/LexFoods.gf b/testsuite/canonical/grammars/LexFoods.gf similarity index 100% rename from testsuite/compiler/canonical/LexFoods.gf rename to testsuite/canonical/grammars/LexFoods.gf diff --git a/testsuite/compiler/canonical/LexFoodsFin.gf b/testsuite/canonical/grammars/LexFoodsFin.gf similarity index 100% rename from testsuite/compiler/canonical/LexFoodsFin.gf rename to testsuite/canonical/grammars/LexFoodsFin.gf diff --git a/testsuite/compiler/canonical/Phrasebook.gf b/testsuite/canonical/grammars/Phrasebook.gf similarity index 100% rename from testsuite/compiler/canonical/Phrasebook.gf rename to testsuite/canonical/grammars/Phrasebook.gf diff --git a/testsuite/compiler/canonical/PhrasebookBul.gf b/testsuite/canonical/grammars/PhrasebookBul.gf similarity index 100% rename from testsuite/compiler/canonical/PhrasebookBul.gf rename to testsuite/canonical/grammars/PhrasebookBul.gf diff --git a/testsuite/compiler/canonical/PhrasebookGer.gf b/testsuite/canonical/grammars/PhrasebookGer.gf similarity index 100% rename from testsuite/compiler/canonical/PhrasebookGer.gf rename to testsuite/canonical/grammars/PhrasebookGer.gf diff --git a/testsuite/compiler/canonical/Sentences.gf b/testsuite/canonical/grammars/Sentences.gf similarity index 100% rename from testsuite/compiler/canonical/Sentences.gf rename to testsuite/canonical/grammars/Sentences.gf diff --git a/testsuite/compiler/canonical/SentencesBul.gf b/testsuite/canonical/grammars/SentencesBul.gf similarity index 100% rename from testsuite/compiler/canonical/SentencesBul.gf rename to testsuite/canonical/grammars/SentencesBul.gf diff --git a/testsuite/compiler/canonical/SentencesGer.gf b/testsuite/canonical/grammars/SentencesGer.gf similarity index 100% rename from testsuite/compiler/canonical/SentencesGer.gf rename to testsuite/canonical/grammars/SentencesGer.gf diff --git a/testsuite/compiler/canonical/SentencesI.gf b/testsuite/canonical/grammars/SentencesI.gf similarity index 100% rename from testsuite/compiler/canonical/SentencesI.gf rename to testsuite/canonical/grammars/SentencesI.gf diff --git a/testsuite/compiler/canonical/Words.gf b/testsuite/canonical/grammars/Words.gf similarity index 100% rename from testsuite/compiler/canonical/Words.gf rename to testsuite/canonical/grammars/Words.gf diff --git a/testsuite/compiler/canonical/WordsBul.gf b/testsuite/canonical/grammars/WordsBul.gf similarity index 100% rename from testsuite/compiler/canonical/WordsBul.gf rename to testsuite/canonical/grammars/WordsBul.gf diff --git a/testsuite/compiler/canonical/WordsGer.gf b/testsuite/canonical/grammars/WordsGer.gf similarity index 100% rename from testsuite/compiler/canonical/WordsGer.gf rename to testsuite/canonical/grammars/WordsGer.gf diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh new file mode 100755 index 000000000..7e5a90f12 --- /dev/null +++ b/testsuite/canonical/run.sh @@ -0,0 +1,42 @@ +#!/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" +fi + +# https://github.com/GrammaticalFramework/gf-core/issues/101 +stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf +for s in c2 objCtrl; do + grep VRead --after-context=216 canonical/PhrasebookGer.gf | grep "$s" > /dev/null + if [ $? -ne 1 ]; then + echo "Canonical grammar contains `$s`: FAIL" + FAILURES=$((FAILURES+1)) + else + echo "Canonical grammar does not contain `$s`: OK" + fi +done + +# 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 + +if [ $FAILURES -ne 0 ]; then + echo "Failures: $FAILURES" + exit 1 +else + echo "All tests passed" +fi diff --git a/testsuite/compiler/canonical/run.sh b/testsuite/compiler/canonical/run.sh deleted file mode 100755 index b9cc7e25b..000000000 --- a/testsuite/compiler/canonical/run.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/env sh - -# https://github.com/GrammaticalFramework/gf-core/issues/100 -stack run -- --batch --output-format=canonical_gf PhrasebookBul.gf -stack run -- --batch canonical/PhrasebookBul.gf - -# https://github.com/GrammaticalFramework/gf-core/issues/101 -stack run -- --batch --output-format=canonical_gf PhrasebookGer.gf -for s in c2 objCtrl; do - grep VRead --after-context=216 canonical/PhrasebookGer.gf | grep "$s" > /dev/null - if [ $? -ne 1 ]; then - echo "$s found" - exit 1 - fi -done - -# https://github.com/GrammaticalFramework/gf-core/issues/102 -stack run -- --batch --output-format=canonical_gf FoodsFin.gf -diff canonical/FoodsFin.gf ./FoodsFin.gf.gold -if [ $? -ne 0 ]; then - echo "Compiled grammar doesn't match gold version" - exit 1 -fi From 587004f985b9a0172b531abd76253a224b8cf77d Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 30 Jun 2021 14:14:54 +0200 Subject: [PATCH 05/16] Sort record fields in lin definitions Fixes #102 --- src/compiler/GF/Compile/GrammarToCanonical.hs | 4 +- src/compiler/GF/Grammar/Macros.hs | 38 +++++++++---------- testsuite/canonical/gold/FoodsFin.gf | 2 +- 3 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 2b701382c..8810c5911 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -11,7 +11,7 @@ import GF.Data.ErrM import GF.Text.Pretty import GF.Grammar.Grammar import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) -import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt) +import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt,sortRec) import GF.Grammar.Lockfield(isLockLabel) import GF.Grammar.Predef(cPredef,cInts) import GF.Compile.Compute.Predef(predef) @@ -162,7 +162,7 @@ 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 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/testsuite/canonical/gold/FoodsFin.gf b/testsuite/canonical/gold/FoodsFin.gf index 55c2fa6c9..de63d2b36 100644 --- a/testsuite/canonical/gold/FoodsFin.gf +++ b/testsuite/canonical/gold/FoodsFin.gf @@ -99,4 +99,4 @@ lin Expensive = ResFin_NPossIllat ParamX_Pl => "kalliisii"; ResFin_NCompound => "kallis"}}; hasPrefix = Prelude_False; p = ""}; -} +} \ No newline at end of file From 32be75ca7dbba046005b9ba06bdaa5e8b5f38ab4 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 09:22:57 +0200 Subject: [PATCH 06/16] Reduce Phrasebook grammars in testsuite/canonical to bare minimum --- testsuite/canonical/gold/PhrasebookGer.gf | 251 ++++++++++++++ testsuite/canonical/grammars/Greetings.gf | 28 -- testsuite/canonical/grammars/GreetingsBul.gf | 31 -- testsuite/canonical/grammars/GreetingsGer.gf | 31 -- testsuite/canonical/grammars/Phrasebook.gf | 11 +- testsuite/canonical/grammars/PhrasebookBul.gf | 28 +- testsuite/canonical/grammars/PhrasebookGer.gf | 12 +- testsuite/canonical/grammars/Sentences.gf | 222 ------------- testsuite/canonical/grammars/SentencesBul.gf | 54 ---- testsuite/canonical/grammars/SentencesGer.gf | 50 --- testsuite/canonical/grammars/SentencesI.gf | 302 ----------------- testsuite/canonical/grammars/Words.gf | 254 --------------- testsuite/canonical/grammars/WordsBul.gf | 305 ------------------ testsuite/canonical/grammars/WordsGer.gf | 262 --------------- testsuite/canonical/run.sh | 32 +- 15 files changed, 313 insertions(+), 1560 deletions(-) create mode 100644 testsuite/canonical/gold/PhrasebookGer.gf delete mode 100644 testsuite/canonical/grammars/Greetings.gf delete mode 100644 testsuite/canonical/grammars/GreetingsBul.gf delete mode 100644 testsuite/canonical/grammars/GreetingsGer.gf delete mode 100644 testsuite/canonical/grammars/Sentences.gf delete mode 100644 testsuite/canonical/grammars/SentencesBul.gf delete mode 100644 testsuite/canonical/grammars/SentencesGer.gf delete mode 100644 testsuite/canonical/grammars/SentencesI.gf delete mode 100644 testsuite/canonical/grammars/Words.gf delete mode 100644 testsuite/canonical/grammars/WordsBul.gf delete mode 100644 testsuite/canonical/grammars/WordsGer.gf diff --git a/testsuite/canonical/gold/PhrasebookGer.gf b/testsuite/canonical/gold/PhrasebookGer.gf new file mode 100644 index 000000000..22d750b78 --- /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/Greetings.gf b/testsuite/canonical/grammars/Greetings.gf deleted file mode 100644 index 580b1560b..000000000 --- a/testsuite/canonical/grammars/Greetings.gf +++ /dev/null @@ -1,28 +0,0 @@ -abstract Greetings = Sentences [Greeting] ** { - -fun - GBye : Greeting ; - GCheers : Greeting ; - GDamn : Greeting ; - GExcuse, GExcusePol : Greeting ; - GGoodDay : Greeting ; - GGoodEvening : Greeting ; - GGoodMorning : Greeting ; - GGoodNight : Greeting ; - GGoodbye : Greeting ; - GHello : Greeting ; - GHelp : Greeting ; - GHowAreYou : Greeting ; - GLookOut : Greeting ; - GNiceToMeetYou : Greeting ; - GPleaseGive, GPleaseGivePol : Greeting ; - GSeeYouSoon : Greeting ; - GSorry, GSorryPol : Greeting ; - GThanks : Greeting ; - GTheCheck : Greeting ; - GCongratulations : Greeting ; - GHappyBirthday : Greeting ; - GGoodLuck : Greeting ; - GWhatTime : Greeting ; - -} diff --git a/testsuite/canonical/grammars/GreetingsBul.gf b/testsuite/canonical/grammars/GreetingsBul.gf deleted file mode 100644 index f271d7717..000000000 --- a/testsuite/canonical/grammars/GreetingsBul.gf +++ /dev/null @@ -1,31 +0,0 @@ -concrete GreetingsBul of Greetings = SentencesBul [Greeting,mkGreeting] ** open Prelude in { - -flags - coding=utf8; - -lin - GBye = mkGreeting "чао" ; - GCheers = mkGreeting "наздраве" ; - GDamn = mkGreeting "по дяволите" ; - GExcuse, GExcusePol = mkGreeting "извинете" ; - GGoodDay = mkGreeting "добър ден" ; - GGoodEvening = mkGreeting "добра вечер" ; - GGoodMorning = mkGreeting "добро утро" ; - GGoodNight = mkGreeting "лека нощ" ; - GGoodbye = mkGreeting "довиждане" ; - GHello = mkGreeting "здравей" ; - GHelp = mkGreeting "помощ" ; - GHowAreYou = mkGreeting "как си" ; - GLookOut = mkGreeting "погледни" ; - GNiceToMeetYou = mkGreeting "радвам се да се видим" ; - GPleaseGive, GPleaseGivePol = mkGreeting "моля" ; - GSeeYouSoon = mkGreeting "до скоро" ; - GSorry, GSorryPol = mkGreeting "извинете" ; - GThanks = mkGreeting "благодаря ти" ; - GTheCheck = mkGreeting "сметката" ; - GCongratulations = mkGreeting "поздравления"; - GHappyBirthday = mkGreeting "честит рожден ден" ; - GGoodLuck = mkGreeting "успех" ; - GWhatTime = mkGreeting "колко е часът" ; - -} diff --git a/testsuite/canonical/grammars/GreetingsGer.gf b/testsuite/canonical/grammars/GreetingsGer.gf deleted file mode 100644 index f027d70ac..000000000 --- a/testsuite/canonical/grammars/GreetingsGer.gf +++ /dev/null @@ -1,31 +0,0 @@ ---# -path=.:abstract:prelude:german:api:common ---# -coding=latin1 -concrete GreetingsGer of Greetings = SentencesGer [Greeting,mkGreeting] ** open Prelude in { - -lin - GBye = mkGreeting "tsch" ; - GCheers = mkGreeting "zum Wohl" ; - GDamn = mkGreeting "verdammt" ; - GExcuse, GExcusePol = mkGreeting "Entschuldigung" ; - GGoodDay = mkGreeting "guten Tag" ; - GGoodEvening = mkGreeting "guten Abend" ; - GGoodMorning = mkGreeting "guten Morgen" ; - GGoodNight = mkGreeting "gute Nacht" ; - GGoodbye = mkGreeting "auf Wiedersehen" ; - GHello = mkGreeting "Hallo" ; - GHelp = mkGreeting "Hilfe" ; - GHowAreYou = mkGreeting "wie geht's" ; - GLookOut = mkGreeting "Achtung" ; - GNiceToMeetYou = mkGreeting "nett, Sie zu treffen" ; - GPleaseGive, GPleaseGivePol = mkGreeting "bitte" ; - GSeeYouSoon = mkGreeting "bis bald" ; - GSorry, GSorryPol = mkGreeting "Entschuldigung" ; - GThanks = mkGreeting "Danke" ; - GTheCheck = mkGreeting "die Rechnung" ; - GCongratulations = mkGreeting "herzlichen Glckwunsch"; - GHappyBirthday = mkGreeting "alles Gute zum Geburtstag" ; - GGoodLuck = mkGreeting "viel Glck" ; - GWhatTime = mkGreeting "wieviel Uhr ist es" | mkGreeting "wie spt ist es" ; - -} - diff --git a/testsuite/canonical/grammars/Phrasebook.gf b/testsuite/canonical/grammars/Phrasebook.gf index 9ebc13106..eff538f62 100644 --- a/testsuite/canonical/grammars/Phrasebook.gf +++ b/testsuite/canonical/grammars/Phrasebook.gf @@ -1,8 +1,9 @@ -abstract Phrasebook = - Greetings, - Words - ** { +abstract Phrasebook = { -flags startcat = Phrase ; +cat PlaceKind ; +fun Airport : PlaceKind ; + +cat VerbPhrase ; +fun VRead : VerbPhrase ; } diff --git a/testsuite/canonical/grammars/PhrasebookBul.gf b/testsuite/canonical/grammars/PhrasebookBul.gf index bbc092963..347d69297 100644 --- a/testsuite/canonical/grammars/PhrasebookBul.gf +++ b/testsuite/canonical/grammars/PhrasebookBul.gf @@ -1,9 +1,31 @@ --# -path=.:present -concrete PhrasebookBul of Phrasebook = - GreetingsBul, - WordsBul ** open +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 index 69a61187c..c6402297c 100644 --- a/testsuite/canonical/grammars/PhrasebookGer.gf +++ b/testsuite/canonical/grammars/PhrasebookGer.gf @@ -1,10 +1,14 @@ --# -path=.:present -concrete PhrasebookGer of Phrasebook = - GreetingsGer, - WordsGer ** open +concrete PhrasebookGer of Phrasebook = + open SyntaxGer, - Prelude in { + LexiconGer in { + lincat + VerbPhrase = VP ; + + lin + VRead = mkVP ; } diff --git a/testsuite/canonical/grammars/Sentences.gf b/testsuite/canonical/grammars/Sentences.gf deleted file mode 100644 index 6798c2127..000000000 --- a/testsuite/canonical/grammars/Sentences.gf +++ /dev/null @@ -1,222 +0,0 @@ ---1 The Ontology of the Phrasebook - ---2 Syntactic Structures of the Phrasebook - --- This module contains phrases that can be defined by a functor over the --- resource grammar API. The phrases that are likely to have different implementations --- are in the module Words. But the distinction is not quite sharp; thus it may happen --- that the functor instantiations make exceptions. - -abstract Sentences = Numeral ** { - --- The ontology of the phrasebook is defined by the following types. The commented ones --- are defined in other modules. - - cat - Phrase ; -- complete phrase, the unit of translation e.g. "Where are you?" - Word ; -- word that could be used as phrase e.g. "Monday" - Message ; -- sequence of phrases, longest unit e.g. "Hello! Where are you?" - Greeting ; -- idiomatic greeting e.g. "hello" - Sentence ; -- declarative sentence e.g. "I am in the bar" - Question ; -- question, either yes/no or wh e.g. "where are you" - Proposition ; -- can be turned into sentence or question e.g. "this pizza is good" - Object ; -- the object of wanting, ordering, etc e.g. "three pizzas and a beer" - PrimObject ; -- single object of wanting, ordering, etc e.g. "three pizzas" - Item ; -- a single entity e.g. "this pizza" - Kind ; -- a type of an item e.g. "pizza" - MassKind ; -- a type mass (uncountable) e.g. "water" - PlurKind ; -- a type usually only in plural e.g. "noodles" - DrinkKind ; -- a drinkable, countable type e.g. "beer" - Quality ; -- qualification of an item, can be complex e.g. "very good" - Property ; -- basic property of an item, one word e.g. "good" - Place ; -- location e.g. "the bar" - PlaceKind ; -- type of location e.g. "bar" - Currency ; -- currency unit e.g. "leu" - Price ; -- number of currency units e.g. "eleven leu" - Person ; -- agent wanting or doing something e.g. "you" - Action ; -- proposition about a Person e.g. "you are here" - Nationality ; -- complex of language, property, country e.g. "Swedish, Sweden" - LAnguage ; -- language (can be without nationality) e.g. "Flemish" - Citizenship ; -- property (can be without language) e.g. "Belgian" - Country ; -- country (can be without language) e.g. "Belgium" - Day ; -- weekday type e.g. "Friday" - Date ; -- definite date e.g. "on Friday" - Name ; -- name of person e.g. "NN" - Number ; -- number expression 1 .. 999,999 e.g. "twenty" - Transport ; -- transportation device e.g. "car" - ByTransport ; -- mean of transportation e.g. "by tram" - Superlative ; -- superlative modifiers of places e.g. "the best restaurant" - - - fun - --- To build a whole message - - MPhrase : Phrase -> Message ; - MContinue : Phrase -> Message -> Message ; - --- Many of the categories are accessible as Phrases, i.e. as translation units. --- To regulate whether words appear on the top level, change their status between --- Word and Phrase, or uncomment PWord, - - -- PWord : Word -> Phrase ; - - PGreetingMale : Greeting -> Phrase ; -- depends on speaker e.g. in Thai - PGreetingFemale : Greeting -> Phrase ; - PSentence : Sentence -> Phrase ; - PQuestion : Question -> Phrase ; - - PNumber : Number -> Phrase ; - PPrice : Price -> Phrase ; - PObject : Object -> Word ; - PKind : Kind -> Word ; - PMassKind : MassKind -> Word ; - PQuality : Quality -> Word ; - PPlace : Place -> Word ; - PPlaceKind : PlaceKind -> Word ; - PCurrency : Currency -> Word ; - PLanguage : LAnguage -> Word ; - PCitizenship : Citizenship -> Word ; - PCountry : Country -> Word ; - PDay : Day -> Word ; - PByTransport : ByTransport -> Word ; - PTransport : Transport -> Word ; - - PYes, PNo, PYesToNo : Greeting ; -- yes, no, si/doch (pos. answer to neg. question) - --- To order something. - - GObjectPlease : Object -> Greeting ; -- a pizza and beer, please! - --- This is the way to build propositions about inanimate items. - - Is : Item -> Quality -> Proposition ; -- this pizza is good - IsMass : MassKind -> Quality -> Proposition ; -- Belgian beer is good - --- To use propositions on higher levels. - - SProp : Proposition -> Sentence ; -- this pizza is good - SPropNot : Proposition -> Sentence ; -- this pizza isn't good - QProp : Proposition -> Question ; -- is this pizza good - - WherePlace : Place -> Question ; -- where is the bar - WherePerson : Person -> Question ; -- where are you - --- This is the way to build propositions about persons. - - PropAction : Action -> Proposition ; -- (you (are|aren't) | are you) Swedish - --- Here are some general syntactic constructions. - - ObjItem : Item -> PrimObject ; -- this pizza - ObjNumber : Number -> Kind -> PrimObject ; -- five pizzas - ObjIndef : Kind -> PrimObject ; -- a pizza - ObjPlural : Kind -> PrimObject ; -- pizzas - ObjPlur : PlurKind -> PrimObject ; -- noodles - ObjMass : MassKind -> PrimObject ; -- water - ObjAndObj : PrimObject -> Object -> Object ; -- this pizza and a beer - OneObj : PrimObject -> Object ; -- this pizza - - SuchKind : Quality -> Kind -> Kind ; -- Italian pizza - SuchMassKind : Quality -> MassKind -> MassKind ; -- Italian water - Very : Property -> Quality ; -- very Italian - Too : Property -> Quality ; -- too Italian - PropQuality : Property -> Quality ; -- Italian - - MassDrink : DrinkKind -> MassKind ; -- beer - DrinkNumber : Number -> DrinkKind -> PrimObject ; -- five beers - --- Determiners. - - This, That, These, Those : Kind -> Item ; -- this pizza,...,those pizzas - The, Thes : Kind -> Item ; -- the pizza, the pizzas - ThisMass, ThatMass, TheMass : MassKind -> Item ; -- this/that/the water - ThesePlur, ThosePlur, ThesPlur : PlurKind -> Item ; -- these/those/the potatoes - - AmountCurrency : Number -> Currency -> Price ; -- five euros - - ThePlace : PlaceKind -> Place ; -- the bar - APlace : PlaceKind -> Place ; -- a bar - - IMale, IFemale, -- I, said by man/woman (affects agreement) - YouFamMale, YouFamFemale, -- familiar you, said to man/woman (affects agreement) - YouPolMale, YouPolFemale : Person ; -- polite you, said to man/woman (affects agreement) - - LangNat : Nationality -> LAnguage ; -- Swedish - CitiNat : Nationality -> Citizenship ; -- Swedish - CountryNat : Nationality -> Country ; -- Sweden - PropCit : Citizenship -> Property ; -- Swedish - - OnDay : Day -> Date ; -- on Friday - Today : Date ; -- today - - PersonName : Name -> Person ; -- person referred by name - NameNN : Name ; -- the name "NN" - ----- NameString : String -> Name ; ---- creates ambiguities with all words --% - - NNumeral : Numeral -> Number ; -- numeral in words, e.g. "twenty" - --- Actions are typically language-dependent, not only lexically but also --- structurally. However, these ones are mostly functorial. - - SHave : Person -> Object -> Sentence ; -- you have beer - SHaveNo : Person -> Kind -> Sentence ; -- you have no apples - SHaveNoMass : Person -> MassKind -> Sentence ; -- you have no beer - QDoHave : Person -> Object -> Question ; -- do you have beer - - AHaveCurr : Person -> Currency -> Action ; -- you have dollars - ACitizen : Person -> Citizenship -> Action ; -- you are Swedish - ABePlace : Person -> Place -> Action ; -- you are in the bar - - ByTransp : Transport -> ByTransport ; -- by bus - - AKnowSentence : Person -> Sentence -> Action ; -- you know that I am in the bar - AKnowPerson : Person -> Person -> Action ; -- you know me - AKnowQuestion : Person -> Question -> Action ; -- you know how far the bar is - ------------------------------------------------------------------------------------------- --- New things added 30/11/2011 by AR ------------------------------------------------------------------------------------------- - - cat - VerbPhrase ; -- things one does, can do, must do, wants to do, e.g. swim - Modality ; -- can, want, must - fun - ADoVerbPhrase : Person -> VerbPhrase -> Action ; -- I swim - AModVerbPhrase : Modality -> Person -> VerbPhrase -> Action ; -- I can swim - ADoVerbPhrasePlace : Person -> VerbPhrase -> Place -> Action ; -- I swim in the hotel - AModVerbPhrasePlace : Modality -> Person -> VerbPhrase -> Place -> Action ; -- I can swim in the hotel - - QWhereDoVerbPhrase : Person -> VerbPhrase -> Question ; -- where do you swim - QWhereModVerbPhrase : Modality -> Person -> VerbPhrase -> Question ; -- where can I swim - - MCan, MKnow, MMust, MWant : Modality ; - --- lexical items given in the resource Lexicon - - VPlay, VRun, VSit, VSleep, VSwim, VWalk : VerbPhrase ; - VDrink, VEat, VRead, VWait, VWrite, VSit, VStop : VerbPhrase ; - V2Buy, V2Drink, V2Eat : Object -> VerbPhrase ; - V2Wait : Person -> VerbPhrase ; - - PImperativeFamPos, -- eat - PImperativeFamNeg, -- don't eat - PImperativePolPos, -- essen Sie - PImperativePolNeg, -- essen Sie nicht - PImperativePlurPos, -- esst - PImperativePlurNeg : -- esst nicht - VerbPhrase -> Phrase ; - --- other new things allowed by the resource - ---- PBecause : Sentence -> Sentence -> Phrase ; -- I want to swim because it is hot - - He, She, -- he, she - WeMale, WeFemale, -- we, said by men/women (affects agreement) - YouPlurFamMale, YouPlurFamFemale, -- plural familiar you, said to men/women (affects agreement) - YouPlurPolMale, YouPlurPolFemale, -- plural polite you, said to men/women (affects agreement) - TheyMale, TheyFemale : Person ; -- they, said of men/women (affects agreement) - -} - diff --git a/testsuite/canonical/grammars/SentencesBul.gf b/testsuite/canonical/grammars/SentencesBul.gf deleted file mode 100644 index b2968bc85..000000000 --- a/testsuite/canonical/grammars/SentencesBul.gf +++ /dev/null @@ -1,54 +0,0 @@ -concrete SentencesBul of Sentences = - NumeralBul ** SentencesI - [IMale, IFemale, YouFamMale, YouFamFemale, YouPolMale, - YouPolFemale, ACitizen, Citizenship, PCitizenship, - LangNat, CitiNat, CountryNat, PropCit, - Nationality, Country, LAnguage, PLanguage, PCountry - ] with - (Syntax = SyntaxBul), - (Symbolic = SymbolicBul), - (Lexicon = LexiconBul) ** open ExtraBul, (R = ResBul) in { - -lincat - Citizenship = {s1 : R.Gender => R.NForm => Str; -- there are two nouns for every citizenship - one for males and one for females - s2 : A -- furthermore, adjective for Property - } ; - Nationality = {s1 : R.Gender => R.NForm => Str; -- there are two nouns for every citizenship - one for males and one for females - s2 : A; -- furthermore, adjective for Property - s3 : PN -- country name - } ; - LAnguage = A ; - Country = PN ; - -lin IMale = mkPerson i_Pron ; - IFemale = mkPerson i8fem_Pron ; - -lin YouFamMale = mkPerson youSg_Pron ; - YouFamFemale = mkPerson youSg8fem_Pron ; - YouPolMale, YouPolFemale = mkPerson youPol_Pron ; - -lin ACitizen p cit = - let noun : N - = case p.name.gn of { - R.GSg g => lin N {s = \\nf => cit.s1 ! g ! nf; - rel = cit.s2.s; relType = R.AdjMod; - g = case g of {R.Masc=>R.AMasc R.Human; R.Fem=>R.AFem; R.Neut=>R.ANeut} - } ; - R.GPl => lin N {s = \\nf => cit.s1 ! R.Masc ! nf; - rel = cit.s2.s; relType = R.AdjMod; - g = R.AMasc R.Human - } - } ; - in mkCl p.name noun ; - - PCitizenship cit = - mkPhrase (mkUtt (mkAP cit.s2)) ; - - LangNat n = n.s2 ; - CitiNat n = n ; - CountryNat n = n.s3 ; - PropCit cit = cit.s2 ; - - PLanguage x = mkPhrase (mkUtt (mkAP x)) ; - PCountry x = mkPhrase (mkUtt (mkNP x)) ; - -} diff --git a/testsuite/canonical/grammars/SentencesGer.gf b/testsuite/canonical/grammars/SentencesGer.gf deleted file mode 100644 index cc0922d5f..000000000 --- a/testsuite/canonical/grammars/SentencesGer.gf +++ /dev/null @@ -1,50 +0,0 @@ -concrete SentencesGer of Sentences = NumeralGer ** SentencesI - - [PYesToNo,SHaveNo,SHaveNoMass, - Proposition, Action, Is, IsMass, SProp, SPropNot, QProp, - AHaveCurr, ACitizen, ABePlace, AKnowSentence, AKnowPerson, AKnowQuestion, - Nationality, LAnguage, - ADoVerbPhrase, AModVerbPhrase, ADoVerbPhrasePlace, AModVerbPhrasePlace, - YouPlurPolMale, YouPlurPolFemale - ] with - (Syntax = SyntaxGer), - (Symbolic = SymbolicGer), - (Lexicon = LexiconGer) ** open Prelude, SyntaxGer in { - - lin - PYesToNo = mkPhrase (lin Utt (ss "doch")) ; - SHaveNo p k = mkS (mkCl p.name have_V2 (mkNP no_Quant plNum k)) ; - SHaveNoMass p k = mkS (mkCl p.name have_V2 (mkNP no_Quant k)) ; - - lincat - Proposition, Action = Prop ; - oper - Prop = {pos : Cl ; neg : S} ; -- x F y ; x F nicht/kein y - mkProp : Cl -> S -> Prop = \pos,neg -> {pos = pos ; neg = neg} ; - prop : Cl -> Prop = \cl -> mkProp cl (mkS negativePol cl) ; - lin - Is i q = prop (mkCl i q) ; - IsMass m q = prop (mkCl (mkNP m) q) ; - SProp p = mkS p.pos ; - SPropNot p = p.neg ; - QProp p = mkQS (mkQCl p.pos) ; - - AHaveCurr p curr = prop (mkCl p.name have_V2 (mkNP aPl_Det curr)) ; - ACitizen p n = prop (mkCl p.name n) ; - ABePlace p place = prop (mkCl p.name place.at) ; - - AKnowSentence p s = prop (mkCl p.name Lexicon.know_VS s) ; - AKnowQuestion p s = prop (mkCl p.name Lexicon.know_VQ s) ; - AKnowPerson p q = prop (mkCl p.name Lexicon.know_V2 q.name) ; - - lincat - Nationality = {lang : CN ; country : NP ; prop : A} ; - LAnguage = CN ; -- kein Deutsch - --- the new things - lin - ADoVerbPhrase p vp = prop (mkCl p.name vp) ; - AModVerbPhrase m p vp = prop (mkCl p.name (mkVP m vp)) ; - ADoVerbPhrasePlace p vp x = prop (mkCl p.name (mkVP vp x.at)) ; - AModVerbPhrasePlace m p vp x = prop (mkCl p.name (mkVP m (mkVP vp x.at))) ; - YouPlurPolMale, YouPlurPolFemale = mkPerson youPol_Pron ; -} diff --git a/testsuite/canonical/grammars/SentencesI.gf b/testsuite/canonical/grammars/SentencesI.gf deleted file mode 100644 index 913aa11ad..000000000 --- a/testsuite/canonical/grammars/SentencesI.gf +++ /dev/null @@ -1,302 +0,0 @@ ---1 Implementation of MOLTO Phrasebook - ---2 The functor for (mostly) common structures - -incomplete concrete SentencesI of Sentences = Numeral ** - open - Syntax, - Lexicon, - Symbolic, -- for names as strings - Prelude - in { - lincat - Phrase = Text ; - Word = Text ; - Message = Text ; - Greeting = Text ; - Sentence = S ; - Question = QS ; - Proposition = Cl ; - Item = NP ; - Kind = CN ; - MassKind = CN ; - MassKind = CN ; - PlurKind = CN ; - DrinkKind = CN ; - Quality = AP ; - Property = A ; - Object = NP ; - PrimObject = NP ; - Place = NPPlace ; -- {name : NP ; at : Syntax.Adv ; to : Syntax.Adv} ; - PlaceKind = CNPlace ; -- {name : CN ; at : Prep ; to : Prep} ; - Currency = CN ; - Price = NP ; - Action = Cl ; - Person = NPPerson ; -- {name : NP ; isPron : Bool ; poss : Quant} ; - Nationality = NPNationality ; -- {lang : NP ; country : NP ; prop : A} ; - LAnguage = NP ; - Citizenship = A ; - Country = NP ; - Day = NPDay ; -- {name : NP ; point : Syntax.Adv ; habitual : Syntax.Adv} ; - Date = Syntax.Adv ; - Name = NP ; - Number = Card ; - ByTransport = Syntax.Adv ; - Transport = {name : CN ; by : Syntax.Adv} ; - Superlative = Det ; - lin - MPhrase p = p ; - MContinue p m = mkText p m ; - - PSentence s = mkText s | lin Text (mkUtt s) ; -- optional '.' - PQuestion s = mkText s | lin Text (mkUtt s) ; -- optional '?' - - PGreetingMale, PGreetingFemale = \g -> mkText (lin Phr (ss g.s)) exclMarkPunct | g ; - - -- PWord w = w ; - - PNumber x = mkSentence (mkUtt x) ; - PPrice x = mkSentence (mkUtt x) ; - - PObject x = mkPhrase (mkUtt x) ; - PKind x = mkPhrase (mkUtt x) ; - PMassKind x = mkPhrase (mkUtt x) ; - PQuality x = mkPhrase (mkUtt x) ; - PPlace x = mkPhrase (mkUtt x.name) ; - PPlaceKind x = mkPhrase (mkUtt x.name) ; - PCurrency x = mkPhrase (mkUtt x) ; - PLanguage x = mkPhrase (mkUtt x) ; - PCountry x = mkPhrase (mkUtt x) ; - PCitizenship x = mkPhrase (mkUtt (mkAP x)) ; - PDay d = mkPhrase (mkUtt d.name) ; - PTransport t = mkPhrase (mkUtt t.name) ; - PByTransport t = mkPhrase (mkUtt t) ; - - PYes = mkPhrase yes_Utt ; - PNo = mkPhrase no_Utt ; - PYesToNo = mkPhrase yes_Utt ; - - GObjectPlease o = lin Text (mkPhr noPConj (mkUtt o) please_Voc) | lin Text (mkUtt o) ; - - Is = mkCl ; - IsMass m q = mkCl (mkNP m) q ; - - SProp = mkS ; - SPropNot = mkS negativePol ; - QProp p = mkQS (mkQCl p) ; - - WherePlace place = mkQS (mkQCl where_IAdv place.name) ; - WherePerson person = mkQS (mkQCl where_IAdv person.name) ; - - PropAction a = a ; - - AmountCurrency num curr = mkNP num curr ; - - ObjItem i = i ; - ObjNumber n k = mkNP n k ; - ObjIndef k = mkNP a_Quant k ; - ObjPlural k = mkNP aPl_Det k ; - ObjPlur k = mkNP aPl_Det k ; - ObjMass k = mkNP k ; - ObjAndObj = mkNP and_Conj ; - OneObj o = o ; - - MassDrink d = d ; - DrinkNumber n k = mkNP n k ; - - This kind = mkNP this_Quant kind ; - That kind = mkNP that_Quant kind ; - These kind = mkNP this_Quant plNum kind ; - Those kind = mkNP that_Quant plNum kind ; - The kind = mkNP the_Quant kind ; - Thes kind = mkNP the_Quant plNum kind ; - ThisMass kind = mkNP this_Quant kind ; - ThatMass kind = mkNP that_Quant kind ; - TheMass kind = mkNP the_Quant kind ; - ThesePlur kind = mkNP this_Quant plNum kind ; - ThosePlur kind = mkNP that_Quant plNum kind ; - ThesPlur kind = mkNP the_Quant plNum kind ; - - SuchKind quality kind = mkCN quality kind ; - SuchMassKind quality kind = mkCN quality kind ; - Very property = mkAP very_AdA (mkAP property) ; - Too property = mkAP too_AdA (mkAP property) ; - PropQuality property = mkAP property ; - - ThePlace kind = let dd : Det = if_then_else Det kind.isPl thePl_Det theSg_Det - in placeNP dd kind ; - APlace kind = let dd : Det = if_then_else Det kind.isPl aPl_Det aSg_Det - in placeNP dd kind ; - - IMale, IFemale = mkPerson i_Pron ; - YouFamMale, YouFamFemale = mkPerson youSg_Pron ; - YouPolMale, YouPolFemale = mkPerson youPol_Pron ; - - LangNat n = n.lang ; - CitiNat n = n.prop ; - CountryNat n = n.country ; - PropCit c = c ; - - OnDay d = d.point ; - Today = today_Adv ; - - PersonName n = - {name = n ; isPron = False ; poss = mkQuant he_Pron} ; -- poss not used ----- NameString s = symb s ; --% - NameNN = symb "NN" ; - - NNumeral n = mkCard ; - - SHave p obj = mkS (mkCl p.name have_V2 obj) ; - SHaveNo p k = mkS negativePol (mkCl p.name have_V2 (mkNP aPl_Det k)) ; - SHaveNoMass p m = mkS negativePol (mkCl p.name have_V2 (mkNP m)) ; - QDoHave p obj = mkQS (mkQCl (mkCl p.name have_V2 obj)) ; - - AHaveCurr p curr = mkCl p.name have_V2 (mkNP aPl_Det curr) ; - ACitizen p n = mkCl p.name n ; - ABePlace p place = mkCl p.name place.at ; - ByTransp t = t.by ; - - AKnowSentence p s = mkCl p.name Lexicon.know_VS s ; - AKnowQuestion p s = mkCl p.name Lexicon.know_VQ s ; - AKnowPerson p q = mkCl p.name Lexicon.know_V2 q.name ; - -oper - --- These operations are used internally in Sentences. - - mkPhrase : Utt -> Text = \u -> lin Text u ; -- no punctuation - mkGreeting : Str -> Text = \s -> lin Text (ss s) ; -- no punctuation - mkSentence : Utt -> Text = \t -> lin Text (postfixSS "." t | t) ; -- optional . - - mkPerson : Pron -> {name : NP ; isPron : Bool ; poss : Quant} = \p -> - {name = mkNP p ; isPron = True ; poss = mkQuant p} ; - --- These are used in Words for each language. - - NPNationality : Type = {lang : NP ; country : NP ; prop : A} ; - - mkNPNationality : NP -> NP -> A -> NPNationality = \la,co,pro -> - {lang = la ; - country = co ; - prop = pro - } ; - - NPDay : Type = {name : NP ; point : Syntax.Adv ; habitual : Syntax.Adv} ; - - mkNPDay : NP -> Syntax.Adv -> Syntax.Adv -> NPDay = \d,p,h -> - {name = d ; - point = p ; - habitual = h - } ; - - NPPlace : Type = {name : NP ; at : Syntax.Adv ; to : Syntax.Adv} ; - CNPlace : Type = {name : CN ; at : Prep ; to : Prep; isPl : Bool} ; - - mkCNPlace : CN -> Prep -> Prep -> CNPlace = \p,i,t -> { - name = p ; - at = i ; - to = t ; - isPl = False - } ; - - mkCNPlacePl : CN -> Prep -> Prep -> CNPlace = \p,i,t -> { - name = p ; - at = i ; - to = t ; - isPl = True - } ; - - placeNP : Det -> CNPlace -> NPPlace = \det,kind -> - let name : NP = mkNP det kind.name in { - name = name ; - at = Syntax.mkAdv kind.at name ; - to = Syntax.mkAdv kind.to name - } ; - - NPPerson : Type = {name : NP ; isPron : Bool ; poss : Quant} ; - - relativePerson : GNumber -> CN -> (Num -> NP -> CN -> NP) -> NPPerson -> NPPerson = - \n,x,f,p -> - let num = if_then_else Num n plNum sgNum in { - name = case p.isPron of { - True => mkNP p.poss num x ; - _ => f num p.name x - } ; - isPron = False ; - poss = mkQuant he_Pron -- not used because not pron - } ; - - GNumber : PType = Bool ; - sing = False ; plur = True ; - --- for languages without GenNP, use "the wife of p" - mkRelative : Bool -> CN -> NPPerson -> NPPerson = \n,x,p -> - relativePerson n x - (\a,b,c -> mkNP (mkNP the_Quant a c) (Syntax.mkAdv possess_Prep b)) p ; - --- for languages with GenNP, use "p's wife" --- relativePerson n x (\a,b,c -> mkNP (GenNP b) a c) p ; - - phrasePlease : Utt -> Text = \u -> --- lin Text (mkPhr noPConj u please_Voc) | - lin Text u ; - ------------------------------------------------------------------------------------------- --- New things added 30/11/2011 by AR ------------------------------------------------------------------------------------------- - - lincat - VerbPhrase = VP ; - Modality = VV ; - lin - ADoVerbPhrase p vp = mkCl p.name vp ; - AModVerbPhrase m p vp = mkCl p.name (mkVP m vp) ; - ADoVerbPhrasePlace p vp x = mkCl p.name (mkVP vp x.at) ; - AModVerbPhrasePlace m p vp x = mkCl p.name (mkVP m (mkVP vp x.at)) ; - - QWhereDoVerbPhrase p vp = mkQS (mkQCl where_IAdv (mkCl p.name vp)) ; - QWhereModVerbPhrase m p vp = mkQS (mkQCl where_IAdv (mkCl p.name (mkVP m vp))) ; - - MWant = want_VV ; - MCan = can_VV ; - MKnow = can8know_VV ; - MMust = must_VV ; - - VPlay = mkVP play_V ; - VRun = mkVP run_V ; - VSit = mkVP sit_V ; - VSleep = mkVP sleep_V ; - VSwim = mkVP swim_V ; - VWalk = mkVP walk_V ; - VSit = mkVP sit_V ; - VStop = mkVP stop_V ; - VDrink = mkVP ; - VEat = mkVP ; - VRead = mkVP ; - VWait = mkVP ; - VWrite = mkVP ; - - V2Buy o = mkVP buy_V2 o ; - V2Drink o = mkVP drink_V2 o ; - V2Eat o = mkVP eat_V2 o ; - V2Wait o = mkVP wait_V2 o.name ; - - PImperativeFamPos v = phrasePlease (mkUtt (mkImp v)) ; - PImperativeFamNeg v = phrasePlease (mkUtt negativePol (mkImp v)) ; - PImperativePolPos v = phrasePlease (mkUtt politeImpForm (mkImp v)) ; - PImperativePolNeg v = phrasePlease (mkUtt politeImpForm negativePol (mkImp v)) ; - PImperativePlurPos v = phrasePlease (mkUtt pluralImpForm (mkImp v)) ; - PImperativePlurNeg v = phrasePlease (mkUtt pluralImpForm negativePol (mkImp v)) ; - --- other new things allowed by the resource - ---- PBecause a b = SSubjS a because_Subj b ; - - He = mkPerson he_Pron ; - She = mkPerson she_Pron ; - WeMale, WeFemale = mkPerson we_Pron ; - YouPlurFamMale, YouPlurFamFemale = mkPerson youPl_Pron ; - YouPlurPolMale, YouPlurPolFemale = mkPerson youPl_Pron ; - TheyMale, TheyFemale = mkPerson they_Pron ; - -} diff --git a/testsuite/canonical/grammars/Words.gf b/testsuite/canonical/grammars/Words.gf deleted file mode 100644 index 08704990a..000000000 --- a/testsuite/canonical/grammars/Words.gf +++ /dev/null @@ -1,254 +0,0 @@ ---2 Words and idiomatic phrases of the Phrasebook - - --- (c) 2010 Aarne Ranta under LGPL --% - -abstract Words = Sentences ** { - - fun - --- kinds of items (so far mostly food stuff) - - Apple : Kind ; - Beer : DrinkKind ; - Bread : MassKind ; - Cheese : MassKind ; - Chicken : MassKind ; - Coffee : DrinkKind ; - Fish : MassKind ; - Meat : MassKind ; - Milk : MassKind ; - Pizza : Kind ; - Salt : MassKind ; - Tea : DrinkKind ; - Water : DrinkKind ; - Wine : DrinkKind ; - --- properties of kinds (so far mostly of food) - - Bad : Property ; - Boring : Property ; - Cheap : Property ; - Cold : Property ; - Delicious : Property ; - Expensive : Property ; - Fresh : Property ; - Good : Property ; - Suspect : Property ; - Warm : Property ; - --- kinds of places - - Airport : PlaceKind ; - AmusementPark : PlaceKind ; - Bank : PlaceKind ; - Bar : PlaceKind ; - Cafeteria : PlaceKind ; - Center : PlaceKind ; - Cinema : PlaceKind ; - Church : PlaceKind ; - Disco : PlaceKind ; - Hospital : PlaceKind ; - Hotel : PlaceKind ; - Museum : PlaceKind ; - Park : PlaceKind ; - Parking : PlaceKind ; - Pharmacy : PlaceKind ; - PostOffice : PlaceKind ; - Pub : PlaceKind ; - Restaurant : PlaceKind ; - School : PlaceKind ; - Shop : PlaceKind ; - Station : PlaceKind ; - Supermarket : PlaceKind ; - Theatre : PlaceKind ; - Toilet : PlaceKind ; - University : PlaceKind ; - Zoo : PlaceKind ; - - CitRestaurant : Citizenship -> PlaceKind ; - --- currency units - - DanishCrown : Currency ; - Dollar : Currency ; - Euro : Currency ; -- Germany, France, Italy, Finland, Spain, The Netherlands - Lei : Currency ; -- Romania - Leva : Currency ; -- Bulgaria - NorwegianCrown : Currency ; - Pound : Currency ; -- UK - Rouble : Currency ; -- Russia - Rupee : Currency ; -- India - SwedishCrown : Currency ; - Zloty : Currency ; -- Poland - Yuan : Currency ; -- China - - --- nationalities, countries, languages, citizenships - - Belgian : Citizenship ; - Belgium : Country ; - Bulgarian : Nationality ; - Catalan : Nationality ; - Chinese : Nationality ; - Danish : Nationality ; - Dutch : Nationality ; - English : Nationality ; - Finnish : Nationality ; - Flemish : LAnguage ; - French : Nationality ; - German : Nationality ; - Hindi : LAnguage ; - India : Country ; - Indian : Citizenship ; - Italian : Nationality ; - Norwegian : Nationality ; - Polish : Nationality ; - Romanian : Nationality ; - Russian : Nationality ; - Spanish : Nationality ; - Swedish : Nationality ; - --- means of transportation - - Bike : Transport ; - Bus : Transport ; - Car : Transport ; - Ferry : Transport ; - Plane : Transport ; - Subway : Transport ; - Taxi : Transport ; - Train : Transport ; - Tram : Transport ; - - ByFoot : ByTransport ; - - --- Actions (which can be expressed by different structures in different languages). --- Notice that also negations and questions can be formed from these. - - AHasAge : Person -> Number -> Action ; -- I am seventy years - AHasChildren: Person -> Number -> Action ; -- I have six children - AHasName : Person -> Name -> Action ; -- my name is Bond - AHasRoom : Person -> Number -> Action ; -- you have a room for five persons - AHasTable : Person -> Number -> Action ; -- you have a table for five persons - AHungry : Person -> Action ; -- I am hungry - AIll : Person -> Action ; -- I am ill - AKnow : Person -> Action ; -- I (don't) know - ALike : Person -> Item -> Action ; -- I like this pizza - ALive : Person -> Country -> Action ; -- I live in Sweden - ALove : Person -> Person -> Action ; -- I love you - AMarried : Person -> Action ; -- I am married - AReady : Person -> Action ; -- I am ready - AScared : Person -> Action ; -- I am scared - ASpeak : Person -> LAnguage -> Action ; -- I speak Finnish - AThirsty : Person -> Action ; -- I am thirsty - ATired : Person -> Action ; -- I am tired - AUnderstand : Person -> Action ; -- I (don't) understand - AWant : Person -> Object -> Action ; -- I want two apples - AWantGo : Person -> Place -> Action ; -- I want to go to the hospital - --- Miscellaneous phrases. Notice that also negations and questions can be formed from --- propositions. - - QWhatAge : Person -> Question ; -- how old are you - QWhatName : Person -> Question ; -- what is your name - HowMuchCost : Item -> Question ; -- how much does the pizza cost - ItCost : Item -> Price -> Proposition ; -- the pizza costs five euros - - PropOpen : Place -> Proposition ; -- the museum is open - PropClosed : Place -> Proposition ; -- the museum is closed - PropOpenDate : Place -> Date -> Proposition ; -- the museum is open today - PropClosedDate : Place -> Date -> Proposition ; -- the museum is closed today - PropOpenDay : Place -> Day -> Proposition ; -- the museum is open on Mondays - PropClosedDay : Place -> Day -> Proposition ; -- the museum is closed on Mondays - - PSeeYouPlaceDate : Place -> Date -> Greeting ; -- see you in the bar on Monday - PSeeYouPlace : Place -> Greeting ; -- see you in the bar - PSeeYouDate : Date -> Greeting ; -- see you on Monday - --- family relations - - Wife, Husband : Person -> Person ; -- my wife, your husband - Son, Daughter : Person -> Person ; -- my son, your husband - Children : Person -> Person ; -- my children - --- week days - - Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday : Day ; - - Tomorrow : Date ; - --- transports - - HowFar : Place -> Question ; -- how far is the zoo ? - HowFarFrom : Place -> Place -> Question ; -- how far is the center from the hotel ? - HowFarFromBy : Place -> Place -> ByTransport -> Question ; - -- how far is the airport from the hotel by taxi ? - HowFarBy : Place -> ByTransport -> Question ; -- how far is the museum by bus ? - - WhichTranspPlace : Transport -> Place -> Question ; -- which bus goes to the hotel - IsTranspPlace : Transport -> Place -> Question ; -- is there a metro to the airport ? - --- modifiers of places - - TheBest : Superlative ; - TheClosest : Superlative ; - TheCheapest : Superlative ; - TheMostExpensive : Superlative ; - TheMostPopular : Superlative ; - TheWorst : Superlative ; - - SuperlPlace : Superlative -> PlaceKind -> Place ; -- the best bar - - --------------------------------------------------- --- New 30/11/2011 AR --------------------------------------------------- -{- 28/8/2012 still only available in Bul Eng Fin Swe Tha - - fun - Thai : Nationality ; - Baht : Currency ; -- Thailand - - Rice : MassKind ; - Pork : MassKind ; - Beef : MassKind ; - Noodles : PlurKind ; - Shrimps : PlurKind ; - - Chili : MassKind ; - Garlic : MassKind ; - - Durian : Kind ; - Mango : Kind ; - Pineapple : Kind ; - Egg : Kind ; - - Coke : DrinkKind ; - IceCream : DrinkKind ; --- both mass and plural - OrangeJuice : DrinkKind ; - Lemonade : DrinkKind ; - Salad : DrinkKind ; - - Beach : PlaceKind ; - - ItsRaining : Proposition ; - ItsWindy : Proposition ; - ItsWarm : Proposition ; - ItsCold : Proposition ; - SunShine : Proposition ; - - Smoke : VerbPhrase ; - - ADoctor : Person -> Action ; - AProfessor : Person -> Action ; - ALawyer : Person -> Action ; - AEngineer : Person -> Action ; - ATeacher : Person -> Action ; - ACook : Person -> Action ; - AStudent : Person -> Action ; - ABusinessman : Person -> Action ; --} - -} diff --git a/testsuite/canonical/grammars/WordsBul.gf b/testsuite/canonical/grammars/WordsBul.gf deleted file mode 100644 index 527b3604a..000000000 --- a/testsuite/canonical/grammars/WordsBul.gf +++ /dev/null @@ -1,305 +0,0 @@ ---2 Implementations of Words, with English as example - -concrete WordsBul of Words = SentencesBul ** - open - SyntaxBul, - (R = ResBul), - ParadigmsBul, - (L = LexiconBul), - (P = ParadigmsBul), - ExtraBul, - MorphoFunsBul, - Prelude in { - - flags - coding=utf8; - - lin - --- Kinds; many of them are in the resource lexicon, others can be built by $mkN$. - - Apple = mkCN L.apple_N ; - Beer = mkCN L.beer_N ; - Bread = mkCN L.bread_N ; - Cheese = mkCN (mkN066 "сирене") ; - Chicken = mkCN (mkN065 "пиле") ; - Coffee = mkCN (mkN065 "кафе") ; - Fish = mkCN L.fish_N ; - Meat = mkCN (mkN054 "месо") ; - Milk = mkCN L.milk_N ; - Pizza = mkCN (mkN041 "пица") ; - Salt = mkCN L.salt_N ; - Tea = mkCN (mkN028 "чай") ; - Water = mkCN L.water_N ; - Wine = mkCN L.wine_N ; - --- Properties; many of them are in the resource lexicon, others can be built by $mkA$. - - Bad = L.bad_A ; - Boring = mkA079 "еднообразен" ; - Cheap = mkA076 "евтин" ; - Cold = L.cold_A ; - Delicious = mkA079 "превъзходен" ; - Expensive = mkA076 "скъп" ; - Fresh = mkA076 "свеж" ; - Good = L.good_A ; - Suspect = mkA079 "подозрителен" ; - Warm = L.warm_A ; - --- Places require different prepositions to express location; in some languages --- also the directional preposition varies, but in English we use $to$, as --- defined by $mkPlace$. - - Airport = mkPlace (mkN066 "летище") na_Prep ; - AmusementPark = mkCompoundPlace (mkA079 "увеселителен") (mkN001 "парк") in_Prep ; - Bank = mkPlace (mkN041 "банка") in_Prep ; - Bar = mkPlace (mkN001 "бар") in_Prep ; - Cafeteria = mkPlace (mkN065 "кафе") in_Prep ; - Center = mkPlace (mkN009a "център") in_Prep ; - Cinema = mkPlace (mkN054 "кино") na_Prep ; - Church = mkPlace (mkN041 "църква") in_Prep ; - Disco = mkPlace (mkN041 "дискотека") in_Prep ; - Hospital = mkPlace (mkN041 "болница") in_Prep ; - Hotel = mkPlace (mkN007 "хотел") in_Prep ; - Museum = mkPlace (mkN032 "музей") in_Prep ; - Park = mkPlace (mkN001 "парк") in_Prep ; - Parking = mkPlace (mkN007 "паркинг") na_Prep ; - Pharmacy = mkPlace (mkN041 "аптека") in_Prep ; - PostOffice = mkPlace (mkN041 "поща") in_Prep ; - Pub = mkPlace (mkN001 "бар") in_Prep ; - Restaurant = mkPlace (mkN007 "ресторант") in_Prep ; - School = mkPlace (mkN007 "училище") in_Prep ; - Shop = mkPlace (mkN007 "магазин") in_Prep ; - Station = mkPlace (mkN041 "гара") na_Prep ; - Supermarket = mkPlace (mkN007 "супермаркет") in_Prep ; - Theatre = mkPlace (mkN009 "театър") na_Prep ; - Toilet = mkPlace (mkN041 "тоалетна") in_Prep ; - University = mkPlace (mkN007 "университет") in_Prep ; - Zoo = mkPlace (mkN001 "зоопарк") in_Prep ; - - CitRestaurant cit = mkCNPlace (mkCN cit.s2 (mkN007 "ресторант")) in_Prep to_Prep ; - --- Currencies; $crown$ is ambiguous between Danish and Swedish crowns. - - DanishCrown = mkCN (mkA078 "датски") (mkN041 "крона") | mkCN (mkN041 "крона") ; - Dollar = mkCN (mkN007 "долар") ; - Euro = mkCN (mkN054 "евро") ; - Lei = mkCN (mkN047 "лея") ; - Leva = mkCN (mkN001 "лев") ; - NorwegianCrown = mkCN (mkA078 "норвежки") (mkN041 "крона") | mkCN (mkN041 "крона") ; - Pound = mkCN (mkN007 "паунд") ; - Rouble = mkCN (mkN041 "рубла") ; - SwedishCrown = mkCN (mkA078 "шведски") (mkN041 "крона") | mkCN (mkN041 "крона") ; - Zloty = mkCN (mkN041 "злота") ; - Baht = mkCN (mkN007a "бат") ; - --- Nationalities - - Belgian = mkCitizenship (mkN013 "белгиец") (mkN041 "белгийка") (mkA078 "белгийски") ; - Belgium = mkPN "Белгия" R.Fem ; - Bulgarian = mkNat (mkN018 "българин") (mkN041 "българка") (mkA078 "български") (mkPN "България" R.Fem) ; - Catalan = mkNat (mkN008a "каталонец") (mkN041 "каталонка") (mkA078 "каталонски") (mkPN "Каталуния" R.Fem) ; - Danish = mkNat (mkN018 "датчанин") (mkN041 "датчанка") (mkA078 "датски") (mkPN "Дания" R.Fem) ; - Dutch = mkNat (mkN008a "холандец") (mkN041 "холандка") (mkA078 "холандски") (mkPN "Холандия" R.Fem) ; - English = mkNat (mkN018 "англичанин") (mkN041 "англичанка") (mkA078 "английски") (mkPN "Англия" R.Fem) ; - Finnish = mkNat (mkN008a "финландец") (mkN041 "финландка") (mkA078 "финландски") (mkPN "Финландия" R.Fem) ; - Flemish = mkA078 "фламандски" ; - French = mkNat (mkN018 "французин") (mkN041 "французойка") (mkA078 "френски") (mkPN "Франция" R.Fem) ; - German = mkNat (mkN008a "германец") (mkN041 "германка") (mkA078 "немски") (mkPN "Германия" R.Fem) ; - Italian = mkNat (mkN008a "италианец") (mkN041 "италианка") (mkA078 "италиански") (mkPN "Италия" R.Fem) ; - Norwegian = mkNat (mkN008a "норвежец") (mkN041 "норвежка") (mkA078 "норвежки") (mkPN "Норвегия" R.Fem) ; - Polish = mkNat (mkN014 "поляк") (mkN047 "полякиня") (mkA078 "полски") (mkPN "Полша" R.Fem) ; - Romanian = mkNat (mkN008a "румънец") (mkN041 "румънка") (mkA078 "румънски") (mkPN "Румъния" R.Fem) ; - Russian = mkNat (mkN014 "руснак") (mkN047 "рускиня") (mkA078 "руски") (mkPN "Русия" R.Fem) ; - Swedish = mkNat (mkN007 "швед") (mkN041 "шведка") (mkA078 "шведски") (mkPN "Швеция" R.Fem) ; - Spanish = mkNat (mkN008a "испанец") (mkN041 "испанка") (mkA078 "испански") (mkPN "Испания" R.Fem) ; - Thai = mkNat (mkN008a "тайландец") (mkN041 "тайландка") (mkA078 "тайландски") (mkPN "Тайланд" R.Masc) ; - --- Means of transportation - - Bike = mkTransport L.bike_N ; - Bus = mkTransport (mkN007 "автобус") ; - Car = mkTransport L.car_N ; - Ferry = mkTransport (mkN007 "ферибот") ; - Plane = mkTransport (mkN007 "самолет") ; - Subway = mkTransport (mkN054 "метро") ; - Taxi = mkTransport (mkN073 "такси") ; - Train = mkTransport (mkN001 "влак") ; - Tram = mkTransport (mkN032 "трамвай") ; - - ByFoot = P.mkAdv "пеша" ; - --- Actions: the predication patterns are very often language-dependent. - - AHasAge p num = mkCl p.name (SyntaxBul.mkAdv na_Prep (mkNP num L.year_N)) ; - AHasChildren p num = mkCl p.name have_V2 (mkNP num L.child_N) ; - AHasRoom p num = mkCl p.name have_V2 (mkNP (mkNP a_Det (mkN047 "стая")) (SyntaxBul.mkAdv (mkPrep "за" R.Acc) (mkNP num (mkN014 "човек")))) ; - AHasTable p num = mkCl p.name have_V2 (mkNP (mkNP a_Det (mkN041 "маса")) (SyntaxBul.mkAdv (mkPrep "за" R.Acc) (mkNP num (mkN014 "човек")))) ; - AHasName p name = mkCl p.name (dirV2 (medialV (actionV (mkV186 "казвам") (mkV156 "кажа")) R.Acc)) name ; - AHungry p = mkCl p.name (mkA079 "гладен") ; - AIll p = mkCl p.name (mkA079 "болен") ; - AKnow p = mkCl p.name (actionV (mkV186 "знам") (mkV162 "зная")) ; - ALike p item = mkCl p.name (dirV2 (actionV (mkV186 "харесвам") (mkV186 "харесам"))) item ; - ALive p co = mkCl p.name (mkVP (mkVP (stateV (mkV160 "живея"))) (SyntaxBul.mkAdv in_Prep (mkNP co))) ; - ALove p q = mkCl p.name (dirV2 (actionV (mkV186 "обичам") (mkV152 "обикна"))) q.name ; - AMarried p = mkCl p.name (mkA076 (case p.name.gn of { - R.GSg R.Fem => "омъжен" ; - _ => "женен" - })) ; - AReady p = mkCl p.name (mkA076 "готов") ; - AScared p = mkCl p.name (mkA076 "уплашен") ; - ASpeak p lang = mkCl p.name (dirV2 (stateV (mkV173 "говоря"))) (mkNP (substantiveN lang (R.AMasc R.NonHuman))) ; - AThirsty p = mkCl p.name (mkA079 "жаден") ; - ATired p = mkCl p.name (mkA076 "уморен") ; - AUnderstand p = mkCl p.name (actionV (mkV186 "разбирам") (mkV170 "разбера")) ; - AWant p obj = mkCl p.name (dirV2 (stateV (mkV186 "искам"))) obj ; - AWantGo p place = mkCl p.name want_VV (mkVP (mkVP (actionV (mkV186 "отивам") (mkV146 "отида"))) place.to) ; - --- miscellaneous - - QWhatName p = mkQS (mkQCl how_IAdv (mkCl p.name (medialV (actionV (mkV186 "казвам") (mkV156 "кажа")) R.Acc))) ; - QWhatAge p = mkQS (mkQCl (MorphoFunsBul.mkIAdv "на колко") (mkCl p.name (mkNP a_Quant plNum L.year_N))) ; - HowMuchCost item = mkQS (mkQCl how8much_IAdv (mkCl item (stateV (mkV186 "струвам")))) ; - ItCost item price = mkCl item (dirV2 (stateV (mkV186 "струвам"))) price ; - - PropOpen p = mkCl p.name open_AP ; - PropClosed p = mkCl p.name closed_AP ; - PropOpenDate p d = mkCl p.name (mkVP (mkVP open_AP) d) ; - PropClosedDate p d = mkCl p.name (mkVP (mkVP closed_AP) d) ; - PropOpenDay p d = mkCl p.name (mkVP (mkVP open_AP) d.habitual) ; - PropClosedDay p d = mkCl p.name (mkVP (mkVP closed_AP) d.habitual) ; - --- Building phrases from strings is complicated: the solution is to use --- mkText : Text -> Text -> Text ; - - PSeeYouDate d = mkText (lin Text (ss ("ще се видим"))) (mkPhrase (mkUtt d)) ; - PSeeYouPlace p = mkText (lin Text (ss ("ще се видим"))) (mkPhrase (mkUtt p.at)) ; - PSeeYouPlaceDate p d = - mkText (lin Text (ss ("ще се видим"))) - (mkText (mkPhrase (mkUtt p.at)) (mkPhrase (mkUtt d))) ; - --- Relations are expressed as "my wife" or "my son's wife", as defined by $xOf$ --- below. Languages without productive genitives must use an equivalent of --- "the wife of my son" for non-pronouns. - - Wife = xOf sing (mkN041 "съпруга") ; - Husband = xOf sing (mkN015 "съпруг") ; - Son = xOf sing (mkN018 "син") ; - Daughter = xOf sing (mkN047 "дъщеря") ; - Children = xOf plur L.child_N ; - --- week days - - Monday = mkDay (mkN014 "понеделник") ; - Tuesday = mkDay (mkN014 "вторник") ; - Wednesday = mkDay (mkN043 "сряда") ; - Thursday = mkDay (mkN014 "четвъртък") ; - Friday = mkDay (mkN014 "петък") ; - Saturday = mkDay (mkN041 "събота") ; - Sunday = mkDay (mkN047 "неделя") ; - - Tomorrow = P.mkAdv "утре" ; - --- modifiers of places - - TheBest = mkSuperl L.good_A ; - TheClosest = mkSuperl L.near_A ; - TheCheapest = mkSuperl (mkA076 "евтин") ; - TheMostExpensive = mkSuperl (mkA076 "скъп") ; - TheMostPopular = mkSuperl (mkA079 "известен") ; - TheWorst = mkSuperl L.bad_A ; - - SuperlPlace sup p = placeNP sup p ; - - --- transports - - HowFar place = mkQS (mkQCl far_IAdv place.name) ; - HowFarFrom x y = mkQS (mkQCl far_IAdv (mkNP y.name (SyntaxBul.mkAdv from_Prep x.name))) ; - HowFarFromBy x y t = - mkQS (mkQCl far_IAdv (mkNP (mkNP y.name (SyntaxBul.mkAdv from_Prep x.name)) t)) ; - HowFarBy y t = mkQS (mkQCl far_IAdv (mkNP y.name t)) ; - - WhichTranspPlace trans place = - mkQS (mkQCl (mkIP which_IDet trans.name) (mkVP (mkVP L.go_V) place.to)) ; - - IsTranspPlace trans place = - mkQS (mkQCl (mkCl (mkCN trans.name place.to))) ; - - Rice = mkCN (mkN040a "ориз") ; - Pork = mkCN (mkN054 "свинско") ; - Beef = mkCN (mkN054 "телешко") ; - Egg = mkCN (mkN066 "яйце") ; - Noodles = mkCN (mkN075 "спагети") ; - Shrimps = mkCN (mkN041 "скарида") ; - Chili = mkCN (mkN065 "чили") ; - Garlic = mkCN (mkN007 "чесън") ; - Durian = mkCN (mkN007 "дуриан") ; - Mango = mkCN (mkN065 "манго") ; - Pineapple = mkCN (mkN007 "ананас") ; - Coke = mkCN (mkN041 "кола") ; - IceCream = mkCN (mkN007 "сладолед") ; - Salad = mkCN (mkN041 "салата") ; - OrangeJuice = mkCN (mkA076 "портокалов") (mkN001 "сок") ; - Lemonade = mkCN (mkN041 "лимонада") ; - - Beach = mkPlace (mkN001 "плаж") na_Prep ; - - ItsRaining = mkCl (mkVP (stateV (mkV174 "валя"))) ; - ItsCold = mkCl (mkVP (mkA076 "студен")) ; - ItsWarm = mkCl (mkVP (mkA080 "топъл")) ; - ItsWindy = mkCl (mkVP (mkA076 "ветровит")) ; - SunShine = mkCl (progressiveVP (mkVP (actionV (mkV186 "пеквам") (mkV148 "пека")))) ; - - Smoke = mkVP (stateV (mkV176 "пуша")) ; - - ADoctor = mkProfession (mkN007a "доктор") ; - AProfessor = mkProfession (mkN007a "професор") ; - ALawyer = mkProfession (mkN007a "адвокат") ; - AEngineer = mkProfession (mkN007a "инженер") ; - ATeacher = mkProfession (mkN031a "учител") ; - ACook = mkProfession (mkN007b "готвач") ; - AStudent = mkProfession (mkN007a "студент") ; - ABusinessman = mkProfession (mkN007a "бизнесмен") ; - --- auxiliaries - - oper - mkProfession : N -> NPPerson -> Cl = \n,p -> mkCl p.name n ; - - mkCitizenship : N -> N -> A -> Citizenship - = \male, female, adj -> lin Citizenship {s1 = table {R.Fem => female.s; _ => male.s}; s2 = adj} ; - - mkNat : N -> N -> A -> PN -> Nationality - = \male, female, adj, country -> lin Nationality {s1 = table {R.Fem => female.s; _ => male.s}; s2 = adj; s3 = country} ; - - mkDay : N -> {name : NP ; point : Adv ; habitual : Adv} = \d -> - let day : NP = mkNP d ; - in mkNPDay day - (SyntaxBul.mkAdv in_Prep day) - (SyntaxBul.mkAdv in_Prep (mkNP the_Quant plNum (mkCN d))) ; - - mkCompoundPlace : A -> N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \a, n, p -> - mkCNPlace (mkCN a n) p to_Prep ; - - mkPlace : N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \n,p -> - mkCNPlace (mkCN n) p to_Prep ; - - open_AP = mkAP (mkA076 "отворен") ; - closed_AP = mkAP (mkA076 "затворен") ; - - xOf : GNumber -> N -> NPPerson -> NPPerson = \n,x,p -> - relativePerson n (mkCN x) (\a,b,c -> mkNP (mkNP the_Quant a c) (SyntaxBul.mkAdv (mkPrep "" R.Dat) b)) p ; - - mkTransport : N -> {name : CN ; by : Adv} = \n -> { - name = mkCN n ; - by = SyntaxBul.mkAdv with_Prep (mkNP n) - } ; - - mkSuperl : A -> Det = \a -> SyntaxBul.mkDet the_Art (SyntaxBul.mkOrd a) ; - - far_IAdv = ExtraBul.IAdvAdv (ss "далече") ; - - na_Prep = mkPrep "на" R.Acc ; - -} diff --git a/testsuite/canonical/grammars/WordsGer.gf b/testsuite/canonical/grammars/WordsGer.gf deleted file mode 100644 index 4984eb080..000000000 --- a/testsuite/canonical/grammars/WordsGer.gf +++ /dev/null @@ -1,262 +0,0 @@ --- (c) 2009 Aarne Ranta under LGPL ---# -coding=latin1 - -concrete WordsGer of Words = SentencesGer ** - open SyntaxGer, ParadigmsGer, IrregGer, (L = LexiconGer), ExtraGer, Prelude in { - - lin - --- kinds of food - - Apple = mkCN L.apple_N ; - Beer = mkCN L.beer_N ; - Bread = mkCN L.bread_N ; - Cheese = mkCN (mkN "Kse" "Kse" "Kse" "Kse" "Kse" "Kse" masculine) ; - Chicken = mkCN (mkN "Huhn" "Huhn" "Huhn" "Huhn" "Hhner" "Hhner" neuter) ; - Coffee = mkCN (mkN "Kaffee" "Kaffee" "Kaffee" "Kaffee" "Kaffees" "Kaffee" masculine) ; - Fish = mkCN L.fish_N ; - Meat = mkCN (mkN "Fleisch" "Fleisch" "Fleisch" "Fleisch" "Fleisch" "Fleisch" neuter) ; - Milk = mkCN L.milk_N ; - Pizza = mkCN (mkN "Pizza" "Pizzen" feminine) ; - Salt = mkCN L.salt_N ; - Tea = mkCN (mkN "Tee" "Tee" "Tee" "Tee" "Tees" "Tees" masculine) ; - Water = mkCN L.water_N ; - Wine = mkCN L.wine_N ; - --- properties - - Bad = L.bad_A ; - Cheap = mkA "billig" ; - Boring = mkA "langweilig" ; - Cold = L.cold_A ; - Delicious = mkA "lecker" ; - Expensive = mkA "teuer" ; - Fresh = mkA "frisch" ; - Good = L.good_A ; - Warm = L.warm_A ; - Suspect = mkA "verdchtig" ; - --- places - - Airport = mkPlace (mkN "Flughafen" "Flughfen" masculine) on_Prep zu_Prep ; - Church = mkPlace (mkN "Kirche") in_Prep inAcc_Prep ; - Hospital = mkPlace (mkN "Krankenhaus" "Krankenhuser" neuter) in_Prep inAcc_Prep ; - Restaurant = mkPlace (mkN "Restaurant" "Restaurants" neuter) in_Prep inAcc_Prep ; - Station = mkPlace (mkN "Bahnhof" "Bahnhfe" masculine) on_Prep zu_Prep ; - University = mkPlace (mkN "Universitt" "Universitten" feminine) in_Prep zu_Prep ; - - AmusementPark = mkPlace (mkN "Vergngungspark" "Vergngungspark" "Vergngungspark" "Vergngungspark" "Vergngungsparks" "Vergngungsparks" masculine) in_Prep inAcc_Prep ; - Bank = mkPlace (mkN "Bank" "Bank" "Bank" "Bank" "Banken" "Banken" feminine) in_Prep zu_Prep ; - Bar = mkPlace (mkN "Bar" "Bar" "Bar" "Bar" "Bars" "Bars" feminine) in_Prep inAcc_Prep ; - Cafeteria = mkPlace (mkN "Cafeteria" "Cafeteria" "Cafeteria" "Cafeteria" "Cafeterien" "Cafeterien" feminine) in_Prep inAcc_Prep ; - Center = mkPlace (mkN "Zentrum" "Zentrum" "Zentrum" "Zentrum" "Zentren" "Zentren" neuter) in_Prep zu_Prep ; - Cinema = mkPlace (mkN "Kino" "Kino" "Kino" "Kino" "Kinos" "Kinos" neuter) in_Prep inAcc_Prep ; - Disco = mkPlace (mkN "Disco" "Disco" "Disco" "Disco" "Discos" "Discos" feminine) in_Prep inAcc_Prep ; - Hotel = mkPlace (mkN "Hotel" "Hotel" "Hotel" "Hotel" "Hotels" "Hotels" neuter) in_Prep inAcc_Prep ; - Museum = mkPlace (mkN "Museum" "Museum" "Museum" "Museum" "Museen" "Museen" neuter) in_Prep inAcc_Prep ; - Park = mkPlace (mkN "Park" "Park" "Park" "Park" "Parks" "Parks" masculine) in_Prep inAcc_Prep ; - Parking = mkPlace (mkN "Parkplatz" "Parkplatz" "Parkplatz" "Parkplatz" "Parkplatzen" "Parkplatzen" masculine) on_Prep zu_Prep ; - Pharmacy = mkPlace (mkN "Apotheke" "Apotheke" "Apotheke" "Apotheke" "Apotheken" "Apotheken" feminine) in_Prep zu_Prep ; - PostOffice = mkPlace (mkN "Post" "Post" "Post" "Post" "Posten" "Posten" feminine) in_Prep inAcc_Prep ; - Pub = mkPlace (mkN "Kneipe" "Kneipe" "Kneipe" "Kneipe" "Kneipen" "Kneipen" feminine) in_Prep inAcc_Prep; - School = mkPlace (mkN "Schule" "Schule" "Schule" "Schule" "Schulen" "Schule" feminine) in_Prep inAcc_Prep ; - Shop = mkPlace (mkN "Geschft" "Geschft" "Geschft" "Geschft" "Geschfte" "Geschfte" neuter) in_Prep inAcc_Prep ; - Supermarket = mkPlace (mkN "Supermarkt" "Supermarkt" "Supermarkt" "Supermarkt" "Supermrkten" "Supermrkte" masculine) in_Prep inAcc_Prep ; - Theatre = mkPlace (mkN "Theater" "Theater" "Theater" "Theaters" "Theatern" "Thaters" neuter) in_Prep inAcc_Prep ; - Toilet = mkPlace (mkN "Toilette" "Toilette" "Toilette" "Toilette" "Toiletten" "Toiletten" feminine) in_Prep (mkPrep "auf" accusative) ; - Zoo = mkPlace (mkN "Zoo" "Zoo" "Zoo" "Zoo" "Zoos" "Zoos" masculine) in_Prep inAcc_Prep ; - - -CitRestaurant cit = mkCNPlace (mkCN cit (mkN "Restaurant" "Restaurants" neuter)) in_Prep inAcc_Prep ; - - --- currencies - - DanishCrown = mkCN (mkA "Dnisch") (mkN "Krone" "Kronen" feminine) | mkCN (mkN "Krone" "Kronen" feminine) ; - Dollar = mkCN (mkN "Dollar" "Dollar" "Dollar" "Dollar" "Dollar" "Dollar" masculine) ; - Euro = mkCN (mkN "Euro" "Euro" "Euro" "Euro" "Euro" "Euro" neuter) ; - Lei = mkCN (mkN "Leu" "Leu" "Leu" "Leu" "Lei" "Lei" masculine) ; - SwedishCrown = mkCN (mkA "Schwedisch") (mkN "Krone" "Kronen" feminine) | mkCN (mkN "Krone" "Kronen" feminine) ; - Leva = mkCN (mkN "Lewa" "Lewa" "Lewa" "Lewa" "Lewa" "Lewa" feminine); - NorwegianCrown = mkCN (mkA "Norwegisch") (mkN "Krone" "Kronen" feminine) | mkCN (mkN "Krone" "Kronen" feminine) ; - Pound = mkCN (mkN "Pfund" "Pfund" "Pfund" "Pfund" "Pfund" "Pfund" neuter) ; - Rouble = mkCN (mkN "Rubel" "Rubel" "Rubel" "Rubel" "Rubels" "Rubels" masculine); - Zloty = mkCN (mkN "Zloty" "Zloty" "Zloty" "Zloty" "Zloty" "Zloty" masculine); - - - --- nationalities - - Belgian = mkA "belgisch" ; - Belgium = mkNP (mkPN "Belgien") ; - Bulgarian = mkNat "Bulgarien" "Bulgarisch" "bulgarisch" ; - Catalan = mkNat "Katalonien" "Katalanisch" "katalanisch" ; - Danish = mkNat "Dnemark" "Dnisch" "dnisch" ; - Dutch = mkNat "den Niederlanden" "Niederlndisch" "niederlndisch" ; - English = mkNat "England" "Englisch" "englisch" ; - Finnish = mkNat "Finnland" "Finnisch" "finnisch" ; - Flemish = mkCN (mkN "Flmisch" "Flmisch" neuter) ; - French = mkNat "Frankreich" "Franzsisch" "franzsisch" ; - German = mkNat "Deutschland" "Deutsch" "deutsche" ; - Italian = mkNat "Italien" "Italienisch" "italienisch" ; - Norwegian = mkNat "Norwegen" "Norwegisch" "norwegisch" ; - Polish = mkNat "Polen" "Polnisch" "polnisch" ; - Romanian = mkNat "Rumnien" "Rumnisch" "rumnisch" ; - Russian = mkNat "Russland" "Russisch" "russisch" ; - Spanish = mkNat "Spanien" "Spanisch" "spanisch" ; - Swedish = mkNat "Schweden" "Schwedisch" "schwedisch" ; - - - --- actions - - AHasAge p num = prop (mkCl p.name (mkNP num L.year_N)) ; - AHasName p name = prop (mkCl p.name (mkV2 heien_V) name) ; - AHungry p = prop (mkCl p.name (mkA "hungrig")) ; - AHasChildren p num = prop (mkCl p.name have_V2 (mkNP num L.child_N)) ; - AHasRoom p num = prop (mkCl p.name have_V2 - (mkNP (mkNP a_Det (mkN "Zimmer" "Zimmer" neuter)) - (SyntaxGer.mkAdv for_Prep (mkNP num (mkN "Persone"))))) ; - AHasTable p num = prop (mkCl p.name have_V2 - (mkNP (mkNP a_Det (mkN "Tisch")) - (SyntaxGer.mkAdv for_Prep (mkNP num (mkN "Persone"))))) ; - AIll p = prop (mkCl p.name (mkA "krank")) ; - AKnow p = prop (mkCl p.name wissen_V) ; - ALike p item = prop (mkCl p.name (mkV2 mgen_V) item) ; - ALive p co = prop (mkCl p.name (mkVP (mkVP (mkV "wohnen")) (SyntaxGer.mkAdv in_Prep co))) ; - ALove p q = prop (mkCl p.name (mkV2 (mkV "lieben")) q.name) ; - AMarried p = prop (mkCl p.name (mkA "verheiratet")) ; - AReady p = prop (mkCl p.name (mkA "bereit")) ; - AScared p = prop (mkCl p.name have_V2 (mkNP (mkN "Angst" "Angsten" feminine))) ; - ASpeak p lang = mkProp (mkCl p.name (mkV2 sprechen_V) (mkNP lang)) - (mkS (mkCl p.name (mkV2 sprechen_V) (mkNP no_Quant lang))) ; - AThirsty p = prop (mkCl p.name (mkA "durstig")) ; - ATired p = prop (mkCl p.name (mkA "mde")) ; - AUnderstand p = prop (mkCl p.name (fixprefixV "ver" stehen_V)) ; - AWant p obj = prop (mkCl p.name want_VV (mkVP have_V2 obj)) ; - AWantGo p place = prop (mkCl p.name want_VV (mkVP (mkVP L.go_V) place.to)) ; - --- miscellaneous - - QWhatName p = mkQS (mkQCl how_IAdv (mkCl p.name heien_V)) ; - QWhatAge p = mkQS (mkQCl (ICompAP (mkAP L.old_A)) p.name) ; - - PropOpen p = prop (mkCl p.name open_Adv) ; - PropClosed p = prop (mkCl p.name closed_Adv) ; - PropOpenDate p d = prop (mkCl p.name (mkVP (mkVP d) open_Adv)) ; - PropClosedDate p d = prop (mkCl p.name (mkVP (mkVP d) closed_Adv)) ; - PropOpenDay p d = prop (mkCl p.name (mkVP (mkVP d.habitual) open_Adv)) ; - PropClosedDay p d = prop (mkCl p.name (mkVP (mkVP d.habitual) closed_Adv)) ; - - HowMuchCost item = mkQS (mkQCl how8much_IAdv (mkCl item (mkV "kosten"))) ; - ItCost item price = prop (mkCl item (mkV2 (mkV "kosten")) price) ; - --- Building phrases from strings is complicated: the solution is to use --- mkText : Text -> Text -> Text ; - - PSeeYouDate d = mkText (lin Text (ss ("wir sehen uns"))) (mkPhrase (mkUtt d)) ; - PSeeYouPlace p = mkText (lin Text (ss ("wir sehen uns"))) (mkPhrase (mkUtt p.at)) ; - PSeeYouPlaceDate p d = - mkText (lin Text (ss ("wir sehen uns"))) - (mkText (mkPhrase (mkUtt d)) (mkPhrase (mkUtt p.at))) ; - - --- Relations are expressed as "my wife" or "my son's wife", as defined by $xOf$ --- below. Languages without productive genitives must use an equivalent of --- "the wife of my son" for non-pronouns. - - Wife = xOf sing (mkN "Frau" "Frauen" feminine) ; - Husband = xOf sing L.man_N ; - Son = xOf sing (mkN "Sohn" "Shne" masculine) ; - Daughter = xOf sing (mkN "Tochter" "Tchter" feminine) ; - Children = xOf plur L.child_N ; - --- week days - - Monday = mkDay "Montag" ; - Tuesday = mkDay "Dienstag" ; - Wednesday = mkDay "Mittwoch" ; - Thursday = mkDay "Donnerstag" ; - Friday = mkDay "Freitag" ; - Saturday = mkDay "Samstag" ; - Sunday = mkDay "Sonntag" ; - - Tomorrow = ParadigmsGer.mkAdv "morgen" ; - - TheBest = mkSuperl L.good_A ; - TheClosest = mkSuperl L.near_A ; - TheCheapest = mkSuperl (mkA "billig") ; - TheMostExpensive = mkSuperl (mkA "teuer") ; - TheMostPopular = mkSuperl (mkA "beliebt") ; - TheWorst = mkSuperl (mkA "schlimm") ; - - SuperlPlace sup p = placeNP sup p ; - - --- means of transportation - - Bike = mkTransport L.bike_N ; - Bus = mkTransport (mkN "Bus" "Bus" "Bus" "Bus" "Buss" "Buss" masculine) ; - Car = mkTransport L.car_N ; - Ferry = mkTransport (mkN "Fhre" "Fhre" "Fhre" "Fhre" "Fhren" "Fhren" feminine) ; - Plane = mkTransport (mkN "Flugzeug" "Flugzeug" "Flugzeug" "Flugzeug" "Flugzeuge" "Flugzeuge" neuter) ; - Subway = mkTransport (mkN "U-Bahn" "U-Bahn" "U-Bahn" "U-Bahn" "U-Bahnen" "U-Bahnen" feminine) ; - Taxi = mkTransport (mkN "Taxi" "Taxi" "Taxi" "Taxi" "Taxis" "Taxis" neuter) ; - Train = mkTransport (mkN "Zug" "Zug" "Zug" "Zug" "Zge" "Zge" masculine) ; - Tram = mkTransport (mkN "Straenbahn" "Straenbahn" "Straenbahn" "Straenbahn" "Straenbahnen" "Straenbahnen" feminine) ; - - ByFoot = ParadigmsGer.mkAdv "zu Fu" ; - - - HowFar place = mkQS (mkQCl far_IAdv place.name) ; - HowFarFrom x y = mkQS (mkQCl far_IAdv (mkNP (mkNP y.name (SyntaxGer.mkAdv von_Prep x.name)) (ParadigmsGer.mkAdv "entfernt"))) ; - HowFarFromBy x y t = - mkQS (mkQCl far_IAdv (mkCl (mkVP (SyntaxGer.mkAdv zu_Prep (mkNP (mkNP y.name (SyntaxGer.mkAdv von_Prep x.name)) t))))) ; - HowFarBy y t = mkQS (mkQCl far_IAdv (mkCl (mkVP (SyntaxGer.mkAdv zu_Prep (mkNP y.name t))))) ; - - WhichTranspPlace trans place = - mkQS (mkQCl (mkIP which_IDet trans.name) (mkVP (mkVP L.go_V) place.to)) ; - - IsTranspPlace trans place = - mkQS (mkQCl (mkCl (mkCN trans.name place.to))) ; - - - - - oper - - mkNat : Str -> Str -> Str -> {lang : CN ; prop : A ; country : NP} = \co, la, adj -> - {lang = mkCN (mkN la la neuter) ; - prop = mkA adj ; country = mkNP (mkPN co)} ; - - mkDay : Str -> {name : NP ; point : Adv ; habitual : Adv} = \d -> - let day = mkNP (mkPN d masculine) in - {name = day ; - point = SyntaxGer.mkAdv (mkPrep "am" dative) day ; ---- am - habitual = ParadigmsGer.mkAdv (d + "s") ---- - } ; - - mkPlace : N -> Prep -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \p,at,to -> { - name = mkCN p ; - at = at ; - to = to ; - isPl = False - } ; - - open_Adv = ParadigmsGer.mkAdv "geffnet" ; ---- Adv to get right word order easily - closed_Adv = ParadigmsGer.mkAdv "geschlossen" ; - - xOf : GNumber -> N -> NPPerson -> NPPerson = \n,x,p -> mkRelative n (mkCN x) p ; - - - mkSuperl : A -> Det = \a -> SyntaxGer.mkDet the_Art (SyntaxGer.mkOrd a) ; - - - mkTransport : N -> {name : CN ; by : Adv} = \n -> { - name = mkCN n ; - by = SyntaxGer.mkAdv by8means_Prep (mkNP the_Det n) - } ; - - far_IAdv = ss "wie weit" ** {lock_IAdv = <>} ; - -} diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh index 7e5a90f12..be7d1ff6c 100755 --- a/testsuite/canonical/run.sh +++ b/testsuite/canonical/run.sh @@ -12,17 +12,28 @@ else echo "Canonical grammar compiles: OK" fi +echo "" + # https://github.com/GrammaticalFramework/gf-core/issues/101 stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf -for s in c2 objCtrl; do - grep VRead --after-context=216 canonical/PhrasebookGer.gf | grep "$s" > /dev/null - if [ $? -ne 1 ]; then - echo "Canonical grammar contains `$s`: FAIL" - FAILURES=$((FAILURES+1)) - else - echo "Canonical grammar does not contain `$s`: OK" - fi -done +# for s in c2 objCtrl; do +# grep VRead --after-context=216 canonical/PhrasebookGer.gf | grep "$s" > /dev/null +# if [ $? -ne 1 ]; then +# echo "Canonical grammar contains \`$s\`: FAIL" +# FAILURES=$((FAILURES+1)) +# else +# echo "Canonical grammar does not contain \`$s\`: OK" +# fi +# done +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 @@ -34,6 +45,9 @@ else echo "Canonical grammar matches gold version: OK" fi +echo "" + +# Summary if [ $FAILURES -ne 0 ]; then echo "Failures: $FAILURES" exit 1 From 13575b093f265eb8c089df0f40b43ba5fd0f67af Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 10:13:42 +0200 Subject: [PATCH 07/16] Add top-level signatures and general code cleanup --- src/compiler/GF/Compile/GrammarToCanonical.hs | 91 +++++++++++++------ 1 file changed, 64 insertions(+), 27 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 8810c5911..547f7416a 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,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,ident2raw,rawIdentS,prefixIdent,showIdent,isWildIdent) -import GF.Infra.Option(optionsPGF) +import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,{-prefixIdent,-}showIdent,isWildIdent) +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 Debug.Trace(trace,traceShow) + -- | 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 @@ -57,15 +63,17 @@ abstract2canonical absname gr = -- | 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)) @@ -85,6 +93,11 @@ 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 _ -> @@ -114,6 +127,7 @@ toCanonical gr absname cenv (name,jment) = 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 +136,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 +155,12 @@ paramTypes gr t = Ok (_,ResParam {}) -> S.singleton q _ -> ignore - ignore = trace ("Ignore: "++show t) S.empty - + ignore = trace ("Ignore: " ++ show t) S.empty +convert :: G.Grammar -> Term -> LinValue convert gr = convert' gr [] +convert' :: G.Grammar -> [Ident] -> Term -> LinValue convert' gr vs = ppT where ppT0 = convert' gr vs @@ -169,13 +185,13 @@ convert' gr vs = ppT 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) @@ -193,7 +209,7 @@ convert' gr vs = ppT 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 +218,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 +235,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 +253,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,8 +261,10 @@ 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 @@ -253,6 +273,7 @@ proj r l = _ -> Nothing -- | Smart constructor for selections +selection :: LinValue -> LinValue -> LinValue selection t v = -- Note: impossible cases can become possible after grammar transformation case t of @@ -276,13 +297,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 +318,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 +341,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 +352,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 +373,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,10 +381,10 @@ 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] @@ -364,7 +395,8 @@ lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm modId :: ModuleName -> C.ModId modId (MN m) = ModId (ident2raw m) -class FromIdent i where gId :: Ident -> i +class FromIdent i where + gId :: Ident -> i instance FromIdent VarId where gId i = if isWildIdent i then Anonymous else VarId (ident2raw i) @@ -374,14 +406,19 @@ 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 :: 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 [(rawIdentS n,convLit v) | (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] From e5a2aed5b6e31fe89e94e9fd9c22e2488f85cae8 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 11:47:14 +0200 Subject: [PATCH 08/16] Remove record fields not in lincat Fixes #100, #101 --- src/compiler/GF/Compile/GrammarToCanonical.hs | 30 ++++++++++++------- testsuite/canonical/gold/PhrasebookBul.gf | 29 ++++++++++++++++++ testsuite/canonical/gold/PhrasebookGer.gf | 6 ++-- testsuite/canonical/run.sh | 9 +++++- 4 files changed, 59 insertions(+), 15 deletions(-) create mode 100644 testsuite/canonical/gold/PhrasebookBul.gf diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 547f7416a..57a761a64 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -17,13 +17,13 @@ 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,ident2raw,rawIdentS,{-prefixIdent,-}showIdent,isWildIdent) +import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent) import GF.Infra.Option(Options,optionsPGF) import PGF.Internal(Literal(..)) import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues) import GF.Grammar.Canonical as C import System.FilePath ((), (<.>)) -import Debug.Trace(trace,traceShow) +import qualified Debug.Trace as T -- | Generate Canonical code for the named abstract syntax and all associated @@ -60,7 +60,6 @@ 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)] @@ -93,11 +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 :: 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 _ -> @@ -110,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 @@ -121,7 +117,6 @@ 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 @@ -155,7 +150,20 @@ 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 _ t = t convert :: G.Grammar -> Term -> LinValue convert gr = convert' gr [] 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 index 22d750b78..912f3b7b1 100644 --- a/testsuite/canonical/gold/PhrasebookGer.gf +++ b/testsuite/canonical/gold/PhrasebookGer.gf @@ -205,9 +205,9 @@ lin VRead = "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; + 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 = ""}; diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh index be7d1ff6c..c39f1e557 100755 --- a/testsuite/canonical/run.sh +++ b/testsuite/canonical/run.sh @@ -9,7 +9,14 @@ if [ $? -ne 0 ]; then echo "Canonical grammar doesn't compile: FAIL" FAILURES=$((FAILURES+1)) else - echo "Canonical grammar compiles: OK" + # 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 "" From 78b73fba20d45ed8c3f1c87455795fbf7d670950 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 13:53:33 +0200 Subject: [PATCH 09/16] Make cleanupRecordFields also recurse into variants It's possible that more constructors need to be handled --- src/compiler/GF/Compile/GrammarToCanonical.hs | 3 ++- testsuite/canonical/run.sh | 9 --------- 2 files changed, 2 insertions(+), 10 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 57a761a64..a600573ac 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -12,7 +12,7 @@ import GF.Data.ErrM import GF.Text.Pretty import GF.Grammar.Grammar as G import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) -import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt,sortRec) +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) @@ -163,6 +163,7 @@ cleanupRecordFields (RecType ls) (R as) = , 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 diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh index c39f1e557..81c03c5d1 100755 --- a/testsuite/canonical/run.sh +++ b/testsuite/canonical/run.sh @@ -23,15 +23,6 @@ echo "" # https://github.com/GrammaticalFramework/gf-core/issues/101 stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf -# for s in c2 objCtrl; do -# grep VRead --after-context=216 canonical/PhrasebookGer.gf | grep "$s" > /dev/null -# if [ $? -ne 1 ]; then -# echo "Canonical grammar contains \`$s\`: FAIL" -# FAILURES=$((FAILURES+1)) -# else -# echo "Canonical grammar does not contain \`$s\`: OK" -# fi -# done diff canonical/PhrasebookGer.gf gold/PhrasebookGer.gf if [ $? -ne 0 ]; then echo "Canonical grammar doesn't match gold version: FAIL" From a27b07542d731ee0287383feb7a97d5d4708b85e Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 14:05:30 +0200 Subject: [PATCH 10/16] Add run-on-grammar canonical test script --- testsuite/canonical/run-on-grammar.sh | 36 +++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100755 testsuite/canonical/run-on-grammar.sh 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 From b090e9b0ff9c442396358090f0afa276e5531de5 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 15:31:00 +0200 Subject: [PATCH 11/16] Add --haskell=pgf2 flag --- src/compiler/GF/Compile/PGFtoHaskell.hs | 120 +++++++++++++----------- src/compiler/GF/Infra/Option.hs | 104 ++++++++++---------- 2 files changed, 120 insertions(+), 104 deletions(-) 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/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 From d53e1713c7860de8a5c256ffe0eed81d5388ae41 Mon Sep 17 00:00:00 2001 From: Meowyam Date: Fri, 2 Jul 2021 16:08:34 +0800 Subject: [PATCH 12/16] resolves GrammaticalFramework/gf-core/#97 --- src/compiler/GF/Command/CommonCommands.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs index 0b698e79c..578331e65 100644 --- a/src/compiler/GF/Command/CommonCommands.hs +++ b/src/compiler/GF/Command/CommonCommands.hs @@ -170,10 +170,13 @@ 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 $ toStrings arg, flags = [ ("command","the system command applied to the argument") ], + options = [ + ("lines","preserve input lines, and return output as a list of lines") + ], examples = [ mkEx "gt | l | ? wc -- generate trees, linearize, and count words" ] From dff1193f7b7a9f186835de80ca96471034abf182 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 15:31:00 +0200 Subject: [PATCH 13/16] Add --haskell=pgf2 flag --- src/compiler/GF/Compile/PGFtoHaskell.hs | 120 +++++++++++++----------- src/compiler/GF/Infra/Option.hs | 104 ++++++++++---------- 2 files changed, 120 insertions(+), 104 deletions(-) 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/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 From 173ab96839212e042c38629d45bcd30cc6e111ca Mon Sep 17 00:00:00 2001 From: Inari Listenmaa Date: Sat, 6 Jun 2020 11:35:05 +0200 Subject: [PATCH 14/16] Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56 --- src/compiler/GF/Compile/Rename.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) 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 From dff215504a71235d0aeb6852e64ef682cc095668 Mon Sep 17 00:00:00 2001 From: Meowyam Date: Tue, 6 Jul 2021 15:00:17 +0800 Subject: [PATCH 15/16] resolves GrammaticalFramework/gf-core/#97, without l --- src/compiler/GF/Command/CommonCommands.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs index 578331e65..7ca2c0ee4 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 (fromStrings . lines) . restricted . readShellProcess syst . unlines $ toStrings arg, + fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg, + flags = [ ("command","the system command applied to the argument") ], From 1e3de38ac4e9d4eee8bb947fb16682490a1130c5 Mon Sep 17 00:00:00 2001 From: Meowyam Date: Tue, 6 Jul 2021 15:22:59 +0800 Subject: [PATCH 16/16] remove redundant options --- src/compiler/GF/Command/CommonCommands.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs index 7ca2c0ee4..c685fc525 100644 --- a/src/compiler/GF/Command/CommonCommands.hs +++ b/src/compiler/GF/Command/CommonCommands.hs @@ -176,9 +176,6 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [ flags = [ ("command","the system command applied to the argument") ], - options = [ - ("lines","preserve input lines, and return output as a list of lines") - ], examples = [ mkEx "gt | l | ? wc -- generate trees, linearize, and count words" ]