forked from GitHub/gf-core
encoding/decoding canonical GF grammars to/from JSON and YAML
This commit is contained in:
Peter Ljunglöf
6
gf.cabal
6
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
|
||||
|
||||
354
src/compiler/GF/Grammar/CanonicalJSON.hs
Normal file
354
src/compiler/GF/Grammar/CanonicalJSON.hs
Normal file
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user