encoding/decoding canonical GF grammars to/from JSON and YAML

1 files changed, 354 insertions, 0 deletions

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
+