From 0a70eca6e2913c462c5c65361131f3ed341e539d Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 30 Jun 2021 10:58:23 +0200 Subject: 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(-) (limited to 'src') 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 -- cgit v1.2.3 From 587004f985b9a0172b531abd76253a224b8cf77d Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 30 Jun 2021 14:14:54 +0200 Subject: 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(-) (limited to 'src') 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 -- cgit v1.2.3 From 13575b093f265eb8c089df0f40b43ba5fd0f67af Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 10:13:42 +0200 Subject: Add top-level signatures and general code cleanup --- src/compiler/GF/Compile/GrammarToCanonical.hs | 91 +++++++++++++++++++-------- 1 file changed, 64 insertions(+), 27 deletions(-) (limited to 'src') 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)] -- cgit v1.2.3 From e5a2aed5b6e31fe89e94e9fd9c22e2488f85cae8 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 11:47:14 +0200 Subject: 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 (limited to 'src') 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 "" -- cgit v1.2.3 From 78b73fba20d45ed8c3f1c87455795fbf7d670950 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 1 Jul 2021 13:53:33 +0200 Subject: 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(-) (limited to 'src') 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" -- cgit v1.2.3