From a0c1da2548ac1a6395e13e681cfb08ca02550ff8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Peter=20Ljunglo=CC=88f?= Date: Fri, 8 Feb 2019 09:10:04 +0100 Subject: [PATCH] encoding/decoding canonical GF grammars to/from JSON and YAML --- gf.cabal | 6 + src/compiler/GF/Grammar/CanonicalJSON.hs | 354 +++++++++++++++++++++++ 2 files changed, 360 insertions(+) create mode 100644 src/compiler/GF/Grammar/CanonicalJSON.hs diff --git a/gf.cabal b/gf.cabal index 3a4604d49..02614ecb4 100644 --- a/gf.cabal +++ b/gf.cabal @@ -80,6 +80,11 @@ Library utf8-string, random, pretty, + aeson, + yaml, + unordered-containers, + scientific, + text, mtl, exceptions hs-source-dirs: src/runtime/haskell @@ -192,6 +197,7 @@ Library GF.Compile.ConcreteToHaskell GF.Compile.ConcreteToCanonical GF.Grammar.Canonical + GF.Grammar.CanonicalJSON GF.Compile.PGFtoJS GF.Compile.PGFtoProlog GF.Compile.PGFtoPython diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs new file mode 100644 index 000000000..39cd32e80 --- /dev/null +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -0,0 +1,354 @@ +{-# language OverloadedStrings, OverloadedLists #-} + +module GF.Grammar.CanonicalJSON ( + encodeJSON, encodeYAML, + decodeJSON, decodeYAML + ) where + + +import qualified Control.Monad as CM (mapM, msum) +import qualified Data.HashMap.Strict as HM (toList) +import qualified Data.Yaml as Yaml (encodeFile, decodeFileEither, ParseException) +import qualified Data.Aeson as Aeson (encodeFile, eitherDecodeFileStrict') +import Data.Aeson (ToJSON(..), object, (.=)) +import Data.Aeson (FromJSON(..), Value(..), withObject, (.:), (.:?), (.!=)) +import Data.Aeson.Types (typeMismatch, modifyFailure, Pair, Parser) +import Data.Text (Text, pack, unpack) +import Data.Scientific (floatingOrInteger) + +import GF.Grammar.Canonical + + +encodeJSON :: FilePath -> Grammar -> IO () +encodeJSON = Aeson.encodeFile + +encodeYAML :: FilePath -> Grammar -> IO () +encodeYAML = Yaml.encodeFile + +decodeJSON :: FilePath -> IO (Either String Grammar) +decodeJSON = Aeson.eitherDecodeFileStrict' + +decodeYAML :: FilePath -> IO (Either Yaml.ParseException Grammar) +decodeYAML = Yaml.decodeFileEither + + +-- in general we encode grammars using JSON objects/records, +-- except for newtypes/coercions/direct values + +-- the top-level definitions use normal record labels, +-- but recursive types/values/ids use labels staring with a "." + +instance ToJSON Grammar where + toJSON (Grammar abs cncs) = object ["abstract" .= abs, "concretes" .= cncs] + +instance FromJSON Grammar where + parseJSON = withObject "Grammar" $ \o -> Grammar <$> o .: "abstract" <*> o .: "concretes" + + +-------------------------------------------------------------------------------- +-- ** Abstract Syntax + +instance ToJSON Abstract where + toJSON (Abstract absid flags cats funs) + = object ["abs" .= absid, + "flags" .= flags, + "cats" .= cats, + "funs" .= funs] + +instance FromJSON Abstract where + parseJSON = withObject "Abstract" $ \o -> Abstract + <$> o .: "abs" + <*> o .:? "flags" .!= Flags [] + <*> o .: "cats" + <*> o .: "funs" + + +instance ToJSON CatDef where + -- non-dependent categories are encoded as simple strings: + toJSON (CatDef c []) = toJSON c + toJSON (CatDef c cs) = object ["cat" .= c, "args" .= cs] + +instance FromJSON CatDef where + parseJSON (String s) = return $ CatDef (CatId (unpack s)) [] + parseJSON (Object o) = CatDef <$> o .: "cat" <*> o .: "args" + parseJSON val = typeMismatch "CatDef" val + + +instance ToJSON FunDef where + toJSON (FunDef f ty) = object ["fun" .= f, "type" .= ty] + +instance FromJSON FunDef where + parseJSON = withObject "FunDef" $ \o -> FunDef <$> o .: "fun" <*> o .: "type" + + +instance ToJSON Type where + toJSON (Type bs ty) = object [".args" .= bs, ".result" .= ty] + +instance FromJSON Type where + parseJSON = withObject "Type" $ \o -> Type <$> o .: ".args" <*> o .: ".result" + + +instance ToJSON TypeApp where + -- non-dependent categories are encoded as simple strings: + toJSON (TypeApp c []) = toJSON c + toJSON (TypeApp c args) = object [".cat" .= c, ".args" .= args] + +instance FromJSON TypeApp where + parseJSON (String s) = return $ TypeApp (CatId (unpack s)) [] + parseJSON (Object o) = TypeApp <$> o .: ".cat" <*> o .: ".args" + parseJSON val = typeMismatch "TypeApp" val + + +instance ToJSON TypeBinding where + -- non-dependent categories are encoded as simple strings: + toJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = toJSON c + toJSON (TypeBinding x ty) = object [".var" .= x, ".type" .= ty] + +instance FromJSON TypeBinding where + parseJSON (String s) = return $ TypeBinding Anonymous (Type [] (TypeApp (CatId (unpack s)) [])) + parseJSON (Object o) = TypeBinding <$> o .: ".var" <*> o .: ".type" + parseJSON val = typeMismatch "TypeBinding" val + + +-------------------------------------------------------------------------------- +-- ** Concrete syntax + +instance ToJSON Concrete where + toJSON (Concrete cncid absid flags params lincats lins) + = object ["cnc" .= cncid, + "abs" .= absid, + "flags" .= flags, + "params" .= params, + "lincats" .= lincats, + "lins" .= lins] + +instance FromJSON Concrete where + parseJSON = withObject "Concrete" $ \o -> Concrete + <$> o .: "cnc" + <*> o .: "abs" + <*> o .:? "flags" .!= Flags [] + <*> o .: "params" + <*> o .: "lincats" + <*> o .: "lins" + + +instance ToJSON ParamDef where + toJSON (ParamDef p pvs) = object ["param" .= p, "values" .= pvs] + toJSON (ParamAliasDef p t) = object ["param" .= p, "alias" .= t] + +instance FromJSON ParamDef where + parseJSON = withObject "ParamDef" $ \o -> + choose [ ParamDef <$> o .: "param" <*> o .: "values" + , ParamAliasDef <$> o .: "param" <*> o .: "alias" + ] + + +instance ToJSON LincatDef where + toJSON (LincatDef c lt) = object ["cat" .= c, "lintype" .= lt] + +instance FromJSON LincatDef where + parseJSON = withObject "LincatDef" $ \v -> LincatDef <$> v .: "cat" <*> v .: "lintype" + + +instance ToJSON LinDef where + toJSON (LinDef f xs lv) = object ["fun" .= f, "args" .= xs, "lin" .= lv] + +instance FromJSON LinDef where + parseJSON = withObject "LinDef" $ \v -> LinDef <$> v .: "fun" <*> v .: "args" <*> v .: "lin" + + +instance ToJSON LinType where + toJSON lt = case lt of + -- the basic types (Str, Float, Int) are encoded as strings: + StrType -> "Str" + FloatType -> "Float" + IntType -> "Int" + -- parameters are also encoded as strings: + ParamType pt -> toJSON pt + -- tables/tuples are encoded as JSON objects: + TableType pt lt -> object [".tblarg" .= pt, ".tblval" .= lt] + TupleType lts -> object [".tuple" .= lts] + -- records are encoded as records: + RecordType rows -> toJSON rows + +instance FromJSON LinType where + parseJSON (String "Str") = return StrType + parseJSON (String "Float") = return FloatType + parseJSON (String "Int") = return IntType + parseJSON (String param) = return (ParamType (ParamTypeId (ParamId (unpack param)))) + parseJSON val@(Object o) = choose [ (TableType <$> o .: ".tblarg" <*> o .: ".tblval") + , (TupleType <$> o .: ".tuple") + , (RecordType <$> parseJSON val) + ] + parseJSON val = typeMismatch "LinType" val + + +instance ToJSON LinValue where + toJSON lv = case lv of + -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: + StrConstant s -> toJSON s + FloatConstant f -> toJSON f + IntConstant n -> toJSON n + -- concatenation is encoded as a JSON array: + ConcatValue v v' -> Array [toJSON v, toJSON v'] + -- most values are encoded as JSON objects: + ParamConstant pv -> object [".param" .= pv] + PredefValue p -> object [".predef" .= p] + TableValue t tvs -> object [".tblarg" .= t, ".tblrows" .= tvs] +-- VTableValue t ts -> object [".vtblarg" .= t, ".vtblrows" .= ts] + TupleValue lvs -> object [".tuple" .= lvs] + VarValue v -> object [".var" .= v] + ErrorValue s -> object [".error" .= s] + Projection lv l -> object [".project" .= lv, ".label" .= l] + Selection tv pv -> object [".select" .= tv, ".key" .= pv] + VariantValue vs -> object [".variants" .= vs] + PreValue alts def -> object [".pre" .= alts, ".default" .= def] + -- records are encoded directly as JSON records: + RecordValue rows -> toJSON rows + +instance FromJSON LinValue where + parseJSON (String s) = return (StrConstant (unpack s)) + parseJSON (Number n) = return (either FloatConstant IntConstant (floatingOrInteger n)) + parseJSON (Array [v,v']) = ConcatValue <$> parseJSON v <*> parseJSON v' + parseJSON val@(Object o) = choose [ ParamConstant <$> o .: ".param" + , PredefValue <$> o .: ".predef" + , TableValue <$> o .: ".tblarg" <*> o .: ".tblrows" +-- , VTableValue <$> o .: ".vtblarg" <*> o .: ".vtblrows" + , 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 <$> parseJSON val + ] + parseJSON val = typeMismatch "LinValue" val + + +instance ToJSON LinPattern where + toJSON linpat = case linpat of + -- wildcards and patterns without arguments are encoded as strings: + WildPattern -> "_" + ParamPattern (Param p []) -> toJSON p + -- complex patterns are encoded as JSON objects: + ParamPattern pv -> toJSON pv + -- and records as records: + RecordPattern r -> toJSON r + +instance FromJSON LinPattern where + parseJSON (String "_") = return WildPattern + parseJSON (String s) = return (ParamPattern (Param (ParamId (unpack s)) [])) + parseJSON val = choose [ ParamPattern <$> parseJSON val + , RecordPattern <$> parseJSON val + , typeMismatch "LinPattern" val + ] + + +instance ToJSON arg => ToJSON (Param arg) where + -- parameters without arguments are encoded as strings: + toJSON (Param p []) = toJSON p + toJSON (Param p args) = object [".paramid" .= p, ".args" .= args] + +instance FromJSON arg => FromJSON (Param arg) where + parseJSON (String p) = return (Param (ParamId (unpack p)) []) + parseJSON (Object o) = Param <$> o .: ".paramid" <*> o .: ".args" + parseJSON val = typeMismatch "Param" val + + +instance ToJSON a => ToJSON (RecordRow a) where + -- record rows and lists of record rows are both encoded as JSON records (i.e., objects) + toJSON row = object [toJSONRecordRow row] + toJSONList = object . map toJSONRecordRow + +toJSONRecordRow :: ToJSON a => RecordRow a -> Pair +toJSONRecordRow (RecordRow (LabelId lbl) val) = pack lbl .= val + +instance FromJSON a => FromJSON (RecordRow a) where + parseJSON = withObject "RecordRow" $ \o -> parseJSONRecordRow (head (HM.toList o)) + parseJSONList = withObject "[RecordRow]" $ \o -> CM.mapM parseJSONRecordRow (HM.toList o) + +parseJSONRecordRow :: FromJSON a => (Text, Value) -> Parser (RecordRow a) +parseJSONRecordRow (lbl, val) = do val' <- parseJSON val + return (RecordRow (LabelId (unpack lbl)) val') + + +instance ToJSON TableRowValue where + toJSON (TableRowValue l v) = object [".pattern" .= l, ".value" .= v] + +instance FromJSON TableRowValue where + parseJSON = withObject "TableRowValue" $ \v -> TableRowValue <$> v .: ".pattern" <*> v .: ".value" + + +-- *** Identifiers in Concrete Syntax + +instance ToJSON PredefId where toJSON (PredefId s) = toJSON s +instance ToJSON LabelId where toJSON (LabelId s) = toJSON s +instance ToJSON VarValueId where toJSON (VarValueId s) = toJSON s +instance ToJSON ParamId where toJSON (ParamId s) = toJSON s +instance ToJSON ParamType where toJSON (ParamTypeId s) = toJSON s + +instance FromJSON PredefId where parseJSON = coerceFrom "PredefId" PredefId +instance FromJSON LabelId where parseJSON = coerceFrom "LabelId" LabelId +instance FromJSON VarValueId where parseJSON = coerceFrom "VarValueId" VarValueId +instance FromJSON ParamId where parseJSON = coerceFrom "ParamId" ParamId +instance FromJSON ParamType where parseJSON = coerceFrom "ParamType" ParamTypeId + + +-------------------------------------------------------------------------------- +-- ** Used in both Abstract and Concrete Syntax + +instance ToJSON ModId where toJSON (ModId s) = toJSON s +instance ToJSON CatId where toJSON (CatId s) = toJSON s +instance ToJSON FunId where toJSON (FunId s) = toJSON s + +instance FromJSON ModId where parseJSON = coerceFrom "ModId" ModId +instance FromJSON CatId where parseJSON = coerceFrom "CatId" CatId +instance FromJSON FunId where parseJSON = coerceFrom "FunId" FunId + + +instance ToJSON VarId where + -- the anonymous variable is the underscore: + toJSON Anonymous = "_" + toJSON (VarId x) = toJSON x + +instance FromJSON VarId where + parseJSON (String "_") = return Anonymous + parseJSON (String s) = return (VarId (unpack s)) + parseJSON val = typeMismatch "VarId" val + + +instance ToJSON Flags where + -- flags are encoded directly as JSON records (i.e., objects): + toJSON (Flags fs) = object [ pack f .= v | (f, v) <- fs ] + +instance FromJSON Flags where + parseJSON = withObject "Flags" $ \o -> Flags <$> CM.mapM parseJSONFlag (HM.toList o) + where parseJSONFlag (flag, val) = do val' <- parseJSON val + return (unpack flag, val') + + +instance ToJSON FlagValue where + -- flag values are encoded as basic JSON types: + toJSON (Str s) = toJSON s + toJSON (Int i) = toJSON i + toJSON (Flt f) = toJSON f + +instance FromJSON FlagValue where + parseJSON (String s) = return $ Str (unpack s) + parseJSON (Number n) = return $ case floatingOrInteger n of + Left f -> Flt f + Right i -> Int i + parseJSON invalid = typeMismatch "FlagValue" invalid + + +-------------------------------------------------------------------------------- +-- ** Helper functions + +choose :: [Parser a] -> Parser a +choose = CM.msum + +coerceFrom :: FromJSON s => String -> (s -> a) -> Value -> Parser a +coerceFrom expected constructor obj = modifyFailure failure $ fmap constructor $ parseJSON obj + where failure f = "(while parsing " ++ expected ++ ") " ++ f +