mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
replace aeson with json
This commit is contained in:
krangelov
3
gf.cabal
3
gf.cabal
@@ -143,8 +143,7 @@ Library
|
||||
---- GF compiler as a library:
|
||||
|
||||
build-depends: filepath, directory, time, time-compat,
|
||||
process, haskeline, parallel>=3,
|
||||
aeson>=1.3, yaml, unordered-containers, scientific, text
|
||||
process, haskeline, parallel>=3
|
||||
|
||||
hs-source-dirs: src/compiler
|
||||
exposed-modules:
|
||||
|
||||
@@ -37,7 +37,6 @@ exportPGF opts fmt pgf =
|
||||
FmtPGFPretty -> multi "txt" (render . ppPGF)
|
||||
FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical)
|
||||
FmtCanonicalJson-> []
|
||||
FmtCanonicalYaml-> []
|
||||
FmtJavaScript -> multi "js" pgf2js
|
||||
FmtPython -> multi "py" pgf2python
|
||||
FmtHaskell -> multi "hs" (grammar2haskell opts name)
|
||||
|
||||
@@ -24,7 +24,7 @@ import Data.Maybe
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import GF.Grammar.CanonicalJSON (encodeJSON, encodeYAML)
|
||||
import GF.Grammar.CanonicalJSON (encodeJSON)
|
||||
import System.FilePath
|
||||
import Control.Monad(when,unless,forM_)
|
||||
|
||||
@@ -65,7 +65,6 @@ compileSourceFiles opts fs =
|
||||
mapM_ abs2canonical canonical
|
||||
mapM_ cnc2canonical canonical
|
||||
when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
|
||||
when (FmtCanonicalYaml `elem` ofmts) $ mapM_ grammar2yaml canonical
|
||||
where
|
||||
ofmts = flag optOutputFormats opts
|
||||
|
||||
@@ -86,10 +85,6 @@ compileSourceFiles opts fs =
|
||||
where absname = srcAbsName gr cnc
|
||||
gr_canon = grammar2canonical opts absname gr
|
||||
|
||||
grammar2yaml (cnc,gr) = encodeYAML (render absname ++ ".yaml") gr_canon
|
||||
where absname = srcAbsName gr cnc
|
||||
gr_canon = grammar2canonical opts absname gr
|
||||
|
||||
writeExport (path,s) = writing opts path $ writeUTF8File path s
|
||||
|
||||
|
||||
|
||||
@@ -1,35 +1,14 @@
|
||||
{-# language OverloadedStrings, OverloadedLists #-}
|
||||
|
||||
module GF.Grammar.CanonicalJSON (
|
||||
encodeJSON, encodeYAML,
|
||||
decodeJSON, decodeYAML
|
||||
encodeJSON
|
||||
) where
|
||||
|
||||
|
||||
import Text.JSON
|
||||
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
|
||||
encodeJSON fpath g = writeFile fpath (encode g)
|
||||
|
||||
|
||||
-- in general we encode grammars using JSON objects/records,
|
||||
@@ -38,317 +17,157 @@ decodeYAML = Yaml.decodeFileEither
|
||||
-- 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"
|
||||
instance JSON Grammar where
|
||||
showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Abstract Syntax
|
||||
|
||||
instance ToJSON Abstract where
|
||||
toJSON (Abstract absid flags cats funs)
|
||||
= object ["abs" .= absid,
|
||||
"flags" .= flags,
|
||||
"cats" .= cats,
|
||||
"funs" .= funs]
|
||||
instance JSON Abstract where
|
||||
showJSON (Abstract absid flags cats funs)
|
||||
= makeObj [("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
("cats", showJSON cats),
|
||||
("funs", showJSON funs)]
|
||||
|
||||
instance FromJSON Abstract where
|
||||
parseJSON = withObject "Abstract" $ \o -> Abstract
|
||||
<$> o .: "abs"
|
||||
<*> o .:? "flags" .!= Flags []
|
||||
<*> o .: "cats"
|
||||
<*> o .: "funs"
|
||||
|
||||
|
||||
instance ToJSON CatDef where
|
||||
instance JSON 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]
|
||||
showJSON (CatDef c []) = showJSON c
|
||||
showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
|
||||
|
||||
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)]
|
||||
|
||||
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
|
||||
instance JSON TypeApp where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
toJSON (TypeApp c []) = toJSON c
|
||||
toJSON (TypeApp c args) = object [".cat" .= c, ".args" .= args]
|
||||
showJSON (TypeApp c []) = showJSON c
|
||||
showJSON (TypeApp c args) = makeObj [("cat", showJSON c), ("args", showJSON 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
|
||||
instance JSON 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
|
||||
showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
|
||||
showJSON (TypeBinding x ty) = makeObj [("var", showJSON x), ("type", showJSON ty)]
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** 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 JSON Concrete where
|
||||
showJSON (Concrete cncid absid flags params lincats lins)
|
||||
= makeObj [("cnc", showJSON cncid),
|
||||
("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
("params", showJSON params),
|
||||
("lincats", showJSON lincats),
|
||||
("lins", showJSON lins)]
|
||||
|
||||
instance FromJSON Concrete where
|
||||
parseJSON = withObject "Concrete" $ \o -> Concrete
|
||||
<$> o .: "cnc"
|
||||
<*> o .: "abs"
|
||||
<*> o .:? "flags" .!= 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)]
|
||||
|
||||
instance JSON LincatDef where
|
||||
showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
|
||||
|
||||
instance ToJSON ParamDef where
|
||||
toJSON (ParamDef p pvs) = object ["param" .= p, "values" .= pvs]
|
||||
toJSON (ParamAliasDef p t) = object ["param" .= p, "alias" .= t]
|
||||
instance JSON LinDef where
|
||||
showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
|
||||
|
||||
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
|
||||
instance JSON LinType where
|
||||
showJSON lt = case lt of
|
||||
-- the basic types (Str, Float, Int) are encoded as strings:
|
||||
StrType -> "Str"
|
||||
FloatType -> "Float"
|
||||
IntType -> "Int"
|
||||
StrType -> showJSON "Str"
|
||||
FloatType -> showJSON "Float"
|
||||
IntType -> showJSON "Int"
|
||||
-- parameters are also encoded as strings:
|
||||
ParamType pt -> toJSON pt
|
||||
ParamType pt -> showJSON pt
|
||||
-- tables/tuples are encoded as JSON objects:
|
||||
TableType pt lt -> object [".tblarg" .= pt, ".tblval" .= lt]
|
||||
TupleType lts -> object [".tuple" .= lts]
|
||||
TableType pt lt -> makeObj [("tblarg", showJSON pt), ("tblval", showJSON lt)]
|
||||
TupleType lts -> makeObj [("tuple", showJSON lts)]
|
||||
-- records are encoded as records:
|
||||
RecordType rows -> toJSON rows
|
||||
RecordType rows -> showJSON 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
|
||||
instance JSON LinValue where
|
||||
showJSON 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
|
||||
StrConstant s -> showJSON s
|
||||
FloatConstant f -> showJSON f
|
||||
IntConstant n -> showJSON n
|
||||
-- concatenation is encoded as a JSON array:
|
||||
ConcatValue v v' -> Array [toJSON v, toJSON v']
|
||||
ConcatValue v v' -> showJSON [showJSON v, showJSON 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]
|
||||
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)]
|
||||
-- records are encoded directly as JSON records:
|
||||
RecordValue rows -> toJSON rows
|
||||
RecordValue rows -> showJSON 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
|
||||
instance JSON LinPattern where
|
||||
showJSON linpat = case linpat of
|
||||
-- wildcards and patterns without arguments are encoded as strings:
|
||||
WildPattern -> "_"
|
||||
ParamPattern (Param p []) -> toJSON p
|
||||
WildPattern -> showJSON "_"
|
||||
ParamPattern (Param p []) -> showJSON p
|
||||
-- complex patterns are encoded as JSON objects:
|
||||
ParamPattern pv -> toJSON pv
|
||||
ParamPattern pv -> showJSON pv
|
||||
-- and records as records:
|
||||
RecordPattern r -> toJSON r
|
||||
RecordPattern r -> showJSON 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
|
||||
instance JSON arg => JSON (Param arg) where
|
||||
-- parameters without arguments are encoded as strings:
|
||||
toJSON (Param p []) = toJSON p
|
||||
toJSON (Param p args) = object [".paramid" .= p, ".args" .= args]
|
||||
showJSON (Param p []) = showJSON p
|
||||
showJSON (Param p args) = makeObj [("paramid", showJSON p), ("args", showJSON 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
|
||||
instance JSON a => JSON (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
|
||||
showJSON row = makeObj [toJSONRecordRow row]
|
||||
|
||||
toJSONRecordRow :: ToJSON a => RecordRow a -> Pair
|
||||
toJSONRecordRow (RecordRow (LabelId lbl) val) = pack lbl .= val
|
||||
toJSONRecordRow :: JSON a => RecordRow a -> (String,JSValue)
|
||||
toJSONRecordRow (RecordRow (LabelId lbl) val) = (lbl, showJSON 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"
|
||||
instance JSON TableRowValue where
|
||||
showJSON (TableRowValue l v) = makeObj [("pattern", showJSON l), ("value", showJSON l)]
|
||||
|
||||
|
||||
-- *** 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
|
||||
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** 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 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 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
|
||||
instance JSON VarId where
|
||||
-- the anonymous variable is the underscore:
|
||||
toJSON Anonymous = "_"
|
||||
toJSON (VarId x) = toJSON x
|
||||
showJSON Anonymous = showJSON "_"
|
||||
showJSON (VarId x) = showJSON 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
|
||||
instance JSON Flags where
|
||||
-- flags are encoded directly as JSON records (i.e., objects):
|
||||
toJSON (Flags fs) = object [ pack f .= v | (f, v) <- fs ]
|
||||
showJSON (Flags fs) = makeObj [(f,showJSON 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
|
||||
instance JSON 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
|
||||
showJSON (Str s) = showJSON s
|
||||
showJSON (Int i) = showJSON i
|
||||
showJSON (Flt f) = showJSON f
|
||||
|
||||
|
||||
@@ -89,7 +89,6 @@ data Phase = Preproc | Convert | Compile | Link
|
||||
data OutputFormat = FmtPGFPretty
|
||||
| FmtCanonicalGF
|
||||
| FmtCanonicalJson
|
||||
| FmtCanonicalYaml
|
||||
| FmtJavaScript
|
||||
| FmtPython
|
||||
| FmtHaskell
|
||||
@@ -474,7 +473,6 @@ outputFormatsExpl =
|
||||
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
|
||||
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
|
||||
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
|
||||
(("canonical_yaml", FmtCanonicalYaml),"Canonical YAML source files"),
|
||||
(("js", FmtJavaScript),"JavaScript (whole grammar)"),
|
||||
(("python", FmtPython),"Python (whole grammar)"),
|
||||
(("haskell", FmtHaskell),"Haskell (abstract syntax)"),
|
||||
|
||||
Reference in New Issue
Block a user