From 5b401f3880f68828272dccfb3787cc3b3abd4cc3 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 7 Mar 2019 17:41:16 +0100 Subject: Expose GF.Grammar.Canonical + some refactoring to make it available in other tools by depending on the gf package and importing it --- src/compiler/GF/Grammar/CanonicalJSON.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'src/compiler/GF/Grammar/CanonicalJSON.hs') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index d791e0d9b..c14716eea 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -95,10 +95,7 @@ instance JSON LinType where instance JSON LinValue where showJSON lv = case lv of - -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: - StrConstant s -> showJSON s - FloatConstant f -> showJSON f - IntConstant n -> showJSON n + LiteralValue l -> showJSON l -- concatenation is encoded as a JSON array: ConcatValue v v' -> showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: @@ -115,6 +112,13 @@ instance JSON LinValue where -- records are encoded directly as JSON records: RecordValue rows -> showJSON rows +instance JSON LinLiteral where + showJSON l = case l of + -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: + StrConstant s -> showJSON s + FloatConstant f -> showJSON f + IntConstant n -> showJSON n + instance JSON LinPattern where showJSON linpat = case linpat of -- wildcards and patterns without arguments are encoded as strings: @@ -161,6 +165,10 @@ instance JSON VarId where showJSON Anonymous = showJSON "_" showJSON (VarId x) = showJSON x +instance JSON QualId where + showJSON (Qual (ModId m) n) = showJSON (m++"_"++n) + showJSON (Unqual n) = showJSON n + instance JSON Flags where -- flags are encoded directly as JSON records (i.e., objects): showJSON (Flags fs) = makeObj [(f,showJSON v) | (f, v) <- fs] -- cgit v1.2.3 From 3328279120ce771c676b30689283cd7f2493c0f6 Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 17:35:01 +0100 Subject: corrected json printing some object labels must be preceded by ".", to not be in conflict with GF records (which are stored as json objects) plus some minor bugfixes and cleaning --- src/compiler/GF/Grammar/CanonicalJSON.hs | 55 +++++++++++++++----------------- 1 file changed, 25 insertions(+), 30 deletions(-) (limited to 'src/compiler/GF/Grammar/CanonicalJSON.hs') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index c14716eea..347af1390 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -3,7 +3,6 @@ module GF.Grammar.CanonicalJSON ( ) where import Text.JSON -import qualified Control.Monad as CM (mapM, msum) import GF.Grammar.Canonical @@ -38,23 +37,19 @@ instance JSON CatDef where instance JSON FunDef where showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)] -{- -instance FromJSON FunDef where - parseJSON = withObject "FunDef" $ \o -> FunDef <$> o .: "fun" <*> o .: "type" --} instance JSON Type where - showJSON (Type bs ty) = makeObj [("args", showJSON bs), ("result", showJSON ty)] + showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)] instance JSON TypeApp where -- non-dependent categories are encoded as simple strings: showJSON (TypeApp c []) = showJSON c - showJSON (TypeApp c args) = makeObj [("cat", showJSON c), ("args", showJSON args)] + showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)] instance JSON TypeBinding where -- non-dependent categories are encoded as simple strings: showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c - showJSON (TypeBinding x ty) = makeObj [("var", showJSON x), ("type", showJSON ty)] + showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)] -------------------------------------------------------------------------------- @@ -88,29 +83,29 @@ instance JSON LinType where -- parameters are also encoded as strings: ParamType pt -> showJSON pt -- tables/tuples are encoded as JSON objects: - TableType pt lt -> makeObj [("tblarg", showJSON pt), ("tblval", showJSON lt)] - TupleType lts -> makeObj [("tuple", showJSON lts)] + TableType pt lt -> makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] + TupleType lts -> makeObj [(".tuple", showJSON lts)] -- records are encoded as records: RecordType rows -> showJSON rows instance JSON LinValue where showJSON lv = case lv of - LiteralValue l -> showJSON l + LiteralValue l -> showJSON l -- concatenation is encoded as a JSON array: - ConcatValue v v' -> showJSON [showJSON v, showJSON v'] + ConcatValue v v' -> showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: - ParamConstant pv -> makeObj [("param", showJSON pv)] - PredefValue p -> makeObj [("predef", showJSON p)] - TableValue t tvs -> makeObj [("tblarg", showJSON t), ("tblrows", showJSON tvs)] - TupleValue lvs -> makeObj [("tuple", showJSON lvs)] - VarValue v -> makeObj [("var", showJSON v)] - ErrorValue s -> makeObj [("error", showJSON s)] - Projection lv l -> makeObj [("project", showJSON lv), ("label", showJSON l)] - Selection tv pv -> makeObj [("select", showJSON tv), ("key", showJSON pv)] - VariantValue vs -> makeObj [("variants", showJSON vs)] - PreValue alts def -> makeObj [("pre", showJSON alts), ("default", showJSON def)] + ParamConstant pv -> makeObj [(".param", showJSON pv)] + PredefValue p -> makeObj [(".predef", showJSON p)] + TableValue t tvs -> makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] + TupleValue lvs -> makeObj [(".tuple", showJSON lvs)] + VarValue v -> makeObj [(".var", showJSON v)] + ErrorValue s -> makeObj [(".error", showJSON s)] + Projection lv l -> makeObj [(".project", showJSON lv), (".label", showJSON l)] + Selection tv pv -> makeObj [(".select", showJSON tv), (".key", showJSON pv)] + VariantValue vs -> makeObj [(".variants", showJSON vs)] + PreValue pre def -> makeObj [(".pre", showJSON pre),(".default", showJSON def)] -- records are encoded directly as JSON records: - RecordValue rows -> showJSON rows + RecordValue rows -> showJSON rows instance JSON LinLiteral where showJSON l = case l of @@ -132,17 +127,17 @@ instance JSON LinPattern where instance JSON arg => JSON (Param arg) where -- parameters without arguments are encoded as strings: showJSON (Param p []) = showJSON p - showJSON (Param p args) = makeObj [("paramid", showJSON p), ("args", showJSON args)] + showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)] 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 = makeObj [toJSONRecordRow row] + showJSON row = showJSONs [row] + showJSONs rows = makeObj (map toRow rows) + where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) -toJSONRecordRow :: JSON a => RecordRow a -> (String,JSValue) -toJSONRecordRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) instance JSON TableRowValue where - showJSON (TableRowValue l v) = makeObj [("pattern", showJSON l), ("value", showJSON l)] + showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] -- *** Identifiers in Concrete Syntax @@ -166,12 +161,12 @@ instance JSON VarId where showJSON (VarId x) = showJSON x instance JSON QualId where - showJSON (Qual (ModId m) n) = showJSON (m++"_"++n) + showJSON (Qual (ModId m) n) = showJSON (m++"."++n) showJSON (Unqual n) = showJSON n 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 [(f, showJSON v) | (f, v) <- fs] instance JSON FlagValue where -- flag values are encoded as basic JSON types: -- cgit v1.2.3 From 21140fc0c0dce1e7730a3d679815e48db0ab3804 Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 17:57:02 +0100 Subject: remove case expressions (no particular reason) --- src/compiler/GF/Grammar/CanonicalJSON.hs | 80 +++++++++++++++----------------- 1 file changed, 38 insertions(+), 42 deletions(-) (limited to 'src/compiler/GF/Grammar/CanonicalJSON.hs') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 347af1390..3be47a1a8 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -75,54 +75,50 @@ instance JSON LinDef where showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)] instance JSON LinType where - showJSON lt = case lt of - -- the basic types (Str, Float, Int) are encoded as strings: - StrType -> showJSON "Str" - FloatType -> showJSON "Float" - IntType -> showJSON "Int" - -- parameters are also encoded as strings: - ParamType pt -> showJSON pt - -- tables/tuples are encoded as JSON objects: - TableType pt lt -> makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] - TupleType lts -> makeObj [(".tuple", showJSON lts)] - -- records are encoded as records: - RecordType rows -> showJSON rows + -- the basic types (Str, Float, Int) are encoded as strings: + showJSON (StrType) = showJSON "Str" + showJSON (FloatType) = showJSON "Float" + showJSON (IntType) = showJSON "Int" + -- parameters are also encoded as strings: + showJSON (ParamType pt) = showJSON pt + -- tables/tuples are encoded as JSON objects: + showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] + showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)] + -- records are encoded as records: + showJSON (RecordType rows) = showJSON rows instance JSON LinValue where - showJSON lv = case lv of - LiteralValue l -> showJSON l - -- concatenation is encoded as a JSON array: - ConcatValue v v' -> showJSON [showJSON v, showJSON v'] - -- most values are encoded as JSON objects: - ParamConstant pv -> makeObj [(".param", showJSON pv)] - PredefValue p -> makeObj [(".predef", showJSON p)] - TableValue t tvs -> makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] - TupleValue lvs -> makeObj [(".tuple", showJSON lvs)] - VarValue v -> makeObj [(".var", showJSON v)] - ErrorValue s -> makeObj [(".error", showJSON s)] - Projection lv l -> makeObj [(".project", showJSON lv), (".label", showJSON l)] - Selection tv pv -> makeObj [(".select", showJSON tv), (".key", showJSON pv)] - VariantValue vs -> makeObj [(".variants", showJSON vs)] - PreValue pre def -> makeObj [(".pre", showJSON pre),(".default", showJSON def)] - -- records are encoded directly as JSON records: - RecordValue rows -> showJSON rows + showJSON (LiteralValue l ) = showJSON l + -- concatenation is encoded as a JSON array: + showJSON (ConcatValue v v') = showJSON [showJSON v, showJSON v'] + -- most values are encoded as JSON objects: + showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)] + showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)] + showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] + showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)] + showJSON (VarValue v ) = makeObj [(".var", showJSON v)] + showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)] + showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)] + showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)] + showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)] + showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)] + -- records are encoded directly as JSON records: + showJSON (RecordValue rows) = showJSON rows instance JSON LinLiteral where - showJSON l = case l of - -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: - StrConstant s -> showJSON s - FloatConstant f -> showJSON f - IntConstant n -> showJSON n + -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: + showJSON (StrConstant s) = showJSON s + showJSON (FloatConstant f) = showJSON f + showJSON (IntConstant n) = showJSON n instance JSON LinPattern where - showJSON linpat = case linpat of - -- wildcards and patterns without arguments are encoded as strings: - WildPattern -> showJSON "_" - ParamPattern (Param p []) -> showJSON p - -- complex patterns are encoded as JSON objects: - ParamPattern pv -> showJSON pv - -- and records as records: - RecordPattern r -> showJSON r + -- wildcards and patterns without arguments are encoded as strings: + showJSON (WildPattern) = showJSON "_" + showJSON (ParamPattern (Param p [])) = showJSON p + -- complex patterns are encoded as JSON objects: + showJSON (ParamPattern pv) = showJSON pv + -- and records as records: + showJSON (RecordPattern r) = showJSON r instance JSON arg => JSON (Param arg) where -- parameters without arguments are encoded as strings: -- cgit v1.2.3 From 926a5cf41475e7aec0b40920d2bc30444afda39c Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 17:58:24 +0100 Subject: added parsing of json into canonical GF --- src/compiler/GF/Grammar/CanonicalJSON.hs | 129 +++++++++++++++++++++++++++++-- 1 file changed, 121 insertions(+), 8 deletions(-) (limited to 'src/compiler/GF/Grammar/CanonicalJSON.hs') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 3be47a1a8..ae2c5fab5 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -3,6 +3,8 @@ module GF.Grammar.CanonicalJSON ( ) where import Text.JSON +import Control.Applicative ((<|>)) +import Data.Ratio (denominator, numerator) import GF.Grammar.Canonical @@ -19,6 +21,8 @@ encodeJSON fpath g = writeFile fpath (encode g) instance JSON Grammar where showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)] + readJSON o = Grammar <$> o!"abstract" <*> o!"concretes" + -------------------------------------------------------------------------------- -- ** Abstract Syntax @@ -30,27 +34,47 @@ instance JSON Abstract where ("cats", showJSON cats), ("funs", showJSON funs)] + readJSON o = Abstract + <$> o!"abs" + <*>(o!"flags" <|> return (Flags [])) + <*> o!"cats" + <*> o!"funs" + instance JSON CatDef where -- non-dependent categories are encoded as simple strings: showJSON (CatDef c []) = showJSON c showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)] + readJSON o = CatDef <$> readJSON o <*> return [] + <|> CatDef <$> o!"cat" <*> o!"args" + instance JSON FunDef where showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)] + readJSON o = FunDef <$> o!"fun" <*> o!"type" + instance JSON Type where showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)] + readJSON o = Type <$> o!".args" <*> o!".result" + instance JSON TypeApp where -- non-dependent categories are encoded as simple strings: showJSON (TypeApp c []) = showJSON c showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)] + readJSON o = TypeApp <$> readJSON o <*> return [] + <|> TypeApp <$> o!".cat" <*> o!".args" + instance JSON TypeBinding where -- non-dependent categories are encoded as simple strings: showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)] + readJSON o = do c <- readJSON o + return (TypeBinding Anonymous (Type [] (TypeApp c []))) + <|> TypeBinding <$> o!".var" <*> o!".type" + -------------------------------------------------------------------------------- -- ** Concrete syntax @@ -64,16 +88,31 @@ instance JSON Concrete where ("lincats", showJSON lincats), ("lins", showJSON lins)] + readJSON o = Concrete + <$> o!"cnc" + <*> o!"abs" + <*>(o!"flags" <|> return (Flags [])) + <*> o!"params" + <*> o!"lincats" + <*> o!"lins" + instance JSON ParamDef where showJSON (ParamDef p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)] showJSON (ParamAliasDef p t) = makeObj [("param", showJSON p), ("alias", showJSON t)] + readJSON o = ParamDef <$> o!"param" <*> o!"values" + <|> ParamAliasDef <$> o!"param" <*> o!"alias" + instance JSON LincatDef where showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)] + readJSON o = LincatDef <$> o!"cat" <*> o!"lintype" + instance JSON LinDef where showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)] + readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin" + instance JSON LinType where -- the basic types (Str, Float, Int) are encoded as strings: showJSON (StrType) = showJSON "Str" @@ -87,6 +126,14 @@ instance JSON LinType where -- records are encoded as records: showJSON (RecordType rows) = showJSON rows + readJSON o = do "Str" <- readJSON o; return StrType + <|> do "Float" <- readJSON o; return FloatType + <|> do "Int" <- readJSON o; return IntType + <|> do ptype <- readJSON o; return (ParamType ptype) + <|> TableType <$> o!".tblarg" <*> o!".tblval" + <|> TupleType <$> o!".tuple" + <|> RecordType <$> readJSON o + instance JSON LinValue where showJSON (LiteralValue l ) = showJSON l -- concatenation is encoded as a JSON array: @@ -105,12 +152,27 @@ instance JSON LinValue where -- records are encoded directly as JSON records: showJSON (RecordValue rows) = showJSON rows + readJSON o = LiteralValue <$> readJSON o + <|> ParamConstant <$> o!".param" + <|> PredefValue <$> o!".predef" + <|> TableValue <$> o!".tblarg" <*> o!".tblrows" + <|> TupleValue <$> o!".tuple" + <|> VarValue <$> o!".var" + <|> ErrorValue <$> o!".error" + <|> Projection <$> o!".project" <*> o!".label" + <|> Selection <$> o!".select" <*> o!".key" + <|> VariantValue <$> o!".variants" + <|> PreValue <$> o!".pre" <*> o!".default" + <|> RecordValue <$> readJSON o + instance JSON LinLiteral where -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: showJSON (StrConstant s) = showJSON s showJSON (FloatConstant f) = showJSON f showJSON (IntConstant n) = showJSON n + readJSON = readBasicJSON StrConstant IntConstant FloatConstant + instance JSON LinPattern where -- wildcards and patterns without arguments are encoded as strings: showJSON (WildPattern) = showJSON "_" @@ -120,53 +182,104 @@ instance JSON LinPattern where -- and records as records: showJSON (RecordPattern r) = showJSON r + readJSON o = do "_" <- readJSON o; return WildPattern + <|> do p <- readJSON o; return (ParamPattern (Param p [])) + <|> ParamPattern <$> readJSON o + <|> RecordPattern <$> readJSON o + instance JSON arg => JSON (Param arg) where -- parameters without arguments are encoded as strings: showJSON (Param p []) = showJSON p showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)] + readJSON o = Param <$> readJSON o <*> return [] + <|> Param <$> o!".paramid" <*> o!".args" + 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) + readJSON obj = head <$> readJSONs obj + readJSONs obj = mapM fromRow (assocsJSObject obj) + where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue + return (RecordRow (LabelId lbl) value) instance JSON TableRowValue where showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] + readJSON o = TableRowValue <$> o!".pattern" <*> o!".value" + -- *** Identifiers in Concrete Syntax -instance JSON PredefId where showJSON (PredefId s) = showJSON s -instance JSON LabelId where showJSON (LabelId s) = showJSON s -instance JSON VarValueId where showJSON (VarValueId s) = showJSON s -instance JSON ParamId where showJSON (ParamId s) = showJSON s -instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s +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 -instance JSON CatId where showJSON (CatId s) = showJSON s -instance JSON FunId where showJSON (FunId s) = showJSON s +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: showJSON Anonymous = showJSON "_" showJSON (VarId x) = showJSON x + readJSON o = do "_" <- readJSON o; return Anonymous + <|> VarId <$> readJSON o + instance JSON QualId where showJSON (Qual (ModId m) n) = showJSON (m++"."++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 + instance JSON Flags where -- flags are encoded directly as JSON records (i.e., objects): showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs] + readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj) + where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue + return (lbl, value) + instance JSON FlagValue where -- flag values are encoded as basic JSON types: showJSON (Str s) = showJSON s showJSON (Int i) = showJSON i showJSON (Flt f) = showJSON f + readJSON = readBasicJSON Str Int Flt + + +-------------------------------------------------------------------------------- +-- ** Convenience functions + +(!) :: JSON a => JSValue -> String -> Result a +obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key) + readJSON + (lookup key (assocsJSObject obj)) + +assocsJSObject :: JSValue -> [(String, JSValue)] +assocsJSObject (JSObject o) = fromJSObject o +assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array" +assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue + + +readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) => + (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v +readBasicJSON str int flt o + = str <$> readJSON o + <|> int_or_flt <$> readJSON o + where int_or_flt f | f == fromIntegral n = int n + | otherwise = flt f + where n = round f -- cgit v1.2.3 From 01b9e8da8da56279122395219440760972b4fe49 Mon Sep 17 00:00:00 2001 From: Peter Ljunglöf Date: Fri, 8 Mar 2019 18:33:56 +0100 Subject: canonical GF: flatten several concatenations into one json array, and parse the array back into concatenations --- src/compiler/GF/Grammar/CanonicalJSON.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'src/compiler/GF/Grammar/CanonicalJSON.hs') diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index ae2c5fab5..8024fe99a 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -136,8 +136,6 @@ instance JSON LinType where instance JSON LinValue where showJSON (LiteralValue l ) = showJSON l - -- concatenation is encoded as a JSON array: - showJSON (ConcatValue v v') = showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)] showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)] @@ -151,6 +149,10 @@ instance JSON LinValue where showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)] -- records are encoded directly as JSON records: showJSON (RecordValue rows) = showJSON rows + -- concatenation is encoded as a JSON array: + showJSON v@(ConcatValue _ _) = showJSON (flatten v []) + where flatten (ConcatValue v v') = flatten v . flatten v' + flatten v = (v :) readJSON o = LiteralValue <$> readJSON o <|> ParamConstant <$> o!".param" @@ -164,6 +166,8 @@ instance JSON LinValue where <|> VariantValue <$> o!".variants" <|> PreValue <$> o!".pre" <*> o!".default" <|> RecordValue <$> readJSON o + <|> do vs <- readJSON o :: Result [LinValue] + return (foldr1 ConcatValue vs) instance JSON LinLiteral where -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: -- cgit v1.2.3 From b11d7d93dcb22b26564f49158414f07f1bd3f4cc Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Wed, 13 Mar 2019 01:51:26 +0100 Subject: GF.Grammar.Canonical: some Functor/Foldable/Traversable instances --- src/compiler/GF/Compile/ConcreteToHaskell.hs | 10 +++++----- src/compiler/GF/Compile/GrammarToCanonical.hs | 10 +++++----- src/compiler/GF/Grammar/Canonical.hs | 17 +++++++++++------ src/compiler/GF/Grammar/CanonicalJSON.hs | 6 +++--- 4 files changed, 24 insertions(+), 19 deletions(-) (limited to 'src/compiler/GF/Grammar/CanonicalJSON.hs') diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 6d2bf398f..d74fcdacd 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -194,8 +194,8 @@ concrete2haskell opts else LambdaCase (map ppCase cs) where (ds,ts') = dedup ts - (ps,ts) = unzip [(p,t)|TableRowValue p t<-cs] - ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t) + (ps,ts) = unzip [(p,t)|TableRow p t<-cs] + ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t) {- ppPredef n = case predef n of @@ -309,8 +309,8 @@ instance Records LinValue where Selection v1 v2 -> records (v1,v2) _ -> S.empty -instance Records TableRowValue where - records (TableRowValue _ v) = records v +instance Records rhs => Records (TableRow rhs) where + records (TableRow _ v) = records v -- | Record subtyping is converted into explicit coercions in Haskell @@ -318,7 +318,7 @@ coerce env ty t = case (ty,t) of (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts) (TableType ti tv,TableValue _ cs) -> - TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-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]] diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 7442bd495..3b21f7702 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -151,7 +151,7 @@ convert' gr vs = ppT case t of -- Abs b x t -> ... -- V ty ts -> VTableValue (convType ty) (map ppT ts) - V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts] + V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts] where Ok pts = allParamValues gr ty Ok ps = mapM term2patt pts @@ -174,7 +174,7 @@ convert' gr vs = ppT Alts t' vs -> alts vs (ppT t') _ -> error $ "convert' "++show t - ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) + ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t) ppPredef n = case predef n of @@ -249,19 +249,19 @@ proj r l = selection t v = case t of TableValue tt r -> - case nub [rv|TableRowValue _ rv<-keep] of + case nub [rv|TableRow _ rv<-keep] of [rv] -> rv _ -> Selection (TableValue tt r') v where r' = if null discard then r - else keep++[TableRowValue WildPattern impossible] + else keep++[TableRow WildPattern impossible] (keep,discard) = partition (mightMatchRow v) r _ -> Selection t v impossible = ErrorValue "impossible" -mightMatchRow v (TableRowValue p _) = +mightMatchRow v (TableRow p _) = case p of WildPattern -> True _ -> mightMatch v p diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 8be659e1b..ed4f3fc9e 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -7,6 +7,7 @@ -- by partial evaluation. This is intended as a common intermediate -- representation to simplify export to other formats. +{-# LANGUAGE DeriveTraversable #-} module GF.Grammar.Canonical where import Prelude hiding ((<>)) import GF.Text.Pretty @@ -87,13 +88,17 @@ type ParamValue = Param LinValue type ParamPattern = Param LinPattern type ParamValueDef = Param ParamId -data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show) +data Param arg = Param ParamId [arg] + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -type RecordRowType = RecordRow LinType +type RecordRowType = RecordRow LinType type RecordRowValue = RecordRow LinValue +type TableRowValue = TableRow LinValue -data RecordRow rhs = RecordRow LabelId rhs deriving (Eq,Ord,Show) -data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show) +data RecordRow rhs = RecordRow LabelId rhs + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) +data TableRow rhs = TableRow LinPattern rhs + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -- *** Identifiers in Concrete Syntax @@ -265,8 +270,8 @@ instance RhsSeparator LinPattern where rhsSep _ = pp "=" instance RhsSeparator rhs => Pretty (RecordRow rhs) where pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v -instance Pretty TableRowValue where - pp (TableRowValue l v) = hang (l<+>"=>") 2 v +instance Pretty rhs => Pretty (TableRow rhs) where + pp (TableRow l v) = hang (l<+>"=>") 2 v -------------------------------------------------------------------------------- instance Pretty ModId where pp (ModId s) = pp s diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 8024fe99a..8b3464674 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -210,10 +210,10 @@ instance JSON a => JSON (RecordRow a) where where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue return (RecordRow (LabelId lbl) value) -instance JSON TableRowValue where - showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] +instance JSON rhs => JSON (TableRow rhs) where + showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] - readJSON o = TableRowValue <$> o!".pattern" <*> o!".value" + readJSON o = TableRow <$> o!".pattern" <*> o!".value" -- *** Identifiers in Concrete Syntax -- cgit v1.2.3