From 25dc9348713ce1142c7ea2c8f0b5a9cfdac4c5ec Mon Sep 17 00:00:00 2001 From: krangelov Date: Tue, 26 Feb 2019 19:27:36 +0100 Subject: [PATCH] replace aeson with json --- gf.cabal | 3 +- src/compiler/GF/Compile/Export.hs | 1 - src/compiler/GF/Compiler.hs | 7 +- src/compiler/GF/Grammar/CanonicalJSON.hs | 379 ++++++----------------- src/compiler/GF/Infra/Option.hs | 2 - 5 files changed, 101 insertions(+), 291 deletions(-) diff --git a/gf.cabal b/gf.cabal index 2d956271a..191d2c0e5 100644 --- a/gf.cabal +++ b/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: diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index e1895feb0..e0811d40d 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -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) diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index 539b0b341..efb1ae70f 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -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 diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 39cd32e80..d791e0d9b 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -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 diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 276b41c8a..b99e2dbe9 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -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)"),