mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-15 15:59:32 -06:00
0a70eca6e2
This avoids a lot of conversion back and forth between Strings and ByteStrings
This commit was cherry-picked from d0c27cdaae (lpgf branch)
299 lines
12 KiB
Haskell
299 lines
12 KiB
Haskell
module GF.Grammar.CanonicalJSON (
|
||
encodeJSON
|
||
) where
|
||
|
||
import Text.JSON
|
||
import Control.Applicative ((<|>))
|
||
import Data.Ratio (denominator, numerator)
|
||
import GF.Grammar.Canonical
|
||
import Control.Monad (guard)
|
||
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
|
||
|
||
|
||
encodeJSON :: FilePath -> Grammar -> IO ()
|
||
encodeJSON fpath g = writeFile fpath (encode g)
|
||
|
||
|
||
-- 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 JSON Grammar where
|
||
showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
|
||
|
||
readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- ** Abstract Syntax
|
||
|
||
instance JSON Abstract where
|
||
showJSON (Abstract absid flags cats funs)
|
||
= makeObj [("abs", showJSON absid),
|
||
("flags", showJSON flags),
|
||
("cats", showJSON cats),
|
||
("funs", showJSON funs)]
|
||
|
||
readJSON o = Abstract
|
||
<$> o!"abs"
|
||
<*>(o!"flags" <|> return (Flags []))
|
||
<*> o!"cats"
|
||
<*> o!"funs"
|
||
|
||
instance JSON CatDef where
|
||
-- non-dependent categories are encoded as simple strings:
|
||
showJSON (CatDef c []) = showJSON c
|
||
showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
|
||
|
||
readJSON o = CatDef <$> readJSON o <*> return []
|
||
<|> CatDef <$> o!"cat" <*> o!"args"
|
||
|
||
instance JSON FunDef where
|
||
showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
|
||
|
||
readJSON o = FunDef <$> o!"fun" <*> o!"type"
|
||
|
||
instance JSON Type where
|
||
showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
|
||
|
||
readJSON o = Type <$> o!".args" <*> o!".result"
|
||
|
||
instance JSON TypeApp where
|
||
-- non-dependent categories are encoded as simple strings:
|
||
showJSON (TypeApp c []) = showJSON c
|
||
showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
|
||
|
||
readJSON o = TypeApp <$> readJSON o <*> return []
|
||
<|> TypeApp <$> o!".cat" <*> o!".args"
|
||
|
||
instance JSON TypeBinding where
|
||
-- non-dependent categories are encoded as simple strings:
|
||
showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
|
||
showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
|
||
|
||
readJSON o = do c <- readJSON o
|
||
return (TypeBinding Anonymous (Type [] (TypeApp c [])))
|
||
<|> TypeBinding <$> o!".var" <*> o!".type"
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- ** Concrete syntax
|
||
|
||
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)]
|
||
|
||
readJSON o = Concrete
|
||
<$> o!"cnc"
|
||
<*> o!"abs"
|
||
<*>(o!"flags" <|> return (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)]
|
||
|
||
readJSON o = ParamDef <$> o!"param" <*> o!"values"
|
||
<|> ParamAliasDef <$> o!"param" <*> o!"alias"
|
||
|
||
instance JSON LincatDef where
|
||
showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
|
||
|
||
readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
|
||
|
||
instance JSON LinDef where
|
||
showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
|
||
|
||
readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
|
||
|
||
instance JSON LinType where
|
||
-- the basic types (Str, Float, Int) are encoded as strings:
|
||
showJSON (StrType) = showJSON "Str"
|
||
showJSON (FloatType) = showJSON "Float"
|
||
showJSON (IntType) = showJSON "Int"
|
||
-- parameters are also encoded as strings:
|
||
showJSON (ParamType pt) = showJSON pt
|
||
-- tables/tuples are encoded as JSON objects:
|
||
showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
|
||
showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)]
|
||
-- records are encoded as records:
|
||
showJSON (RecordType rows) = showJSON rows
|
||
|
||
readJSON o = StrType <$ parseString "Str" o
|
||
<|> FloatType <$ parseString "Float" o
|
||
<|> IntType <$ parseString "Int" o
|
||
<|> ParamType <$> readJSON o
|
||
<|> TableType <$> o!".tblarg" <*> o!".tblval"
|
||
<|> TupleType <$> o!".tuple"
|
||
<|> RecordType <$> readJSON o
|
||
|
||
instance JSON LinValue where
|
||
showJSON (LiteralValue l ) = showJSON l
|
||
-- most values are encoded as JSON objects:
|
||
showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)]
|
||
showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)]
|
||
showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)]
|
||
showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)]
|
||
showJSON (VarValue v ) = makeObj [(".var", showJSON v)]
|
||
showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)]
|
||
showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)]
|
||
showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)]
|
||
showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)]
|
||
showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)]
|
||
-- records are encoded directly as JSON records:
|
||
showJSON (RecordValue rows) = showJSON rows
|
||
-- concatenation is encoded as a JSON array:
|
||
showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
|
||
where flatten (ConcatValue v v') = flatten v . flatten v'
|
||
flatten v = (v :)
|
||
|
||
readJSON o = LiteralValue <$> readJSON o
|
||
<|> ParamConstant <$> o!".param"
|
||
<|> PredefValue <$> o!".predef"
|
||
<|> TableValue <$> o!".tblarg" <*> o!".tblrows"
|
||
<|> 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 <$> readJSON o
|
||
<|> do vs <- readJSON o :: Result [LinValue]
|
||
return (foldr1 ConcatValue vs)
|
||
|
||
instance JSON LinLiteral where
|
||
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
|
||
showJSON (StrConstant s) = showJSON s
|
||
showJSON (FloatConstant f) = showJSON f
|
||
showJSON (IntConstant n) = showJSON n
|
||
|
||
readJSON = readBasicJSON StrConstant IntConstant FloatConstant
|
||
|
||
instance JSON LinPattern where
|
||
-- wildcards and patterns without arguments are encoded as strings:
|
||
showJSON (WildPattern) = showJSON "_"
|
||
showJSON (ParamPattern (Param p [])) = showJSON p
|
||
-- complex patterns are encoded as JSON objects:
|
||
showJSON (ParamPattern pv) = showJSON pv
|
||
-- and records as records:
|
||
showJSON (RecordPattern r) = showJSON r
|
||
|
||
readJSON o = do p <- parseString "_" o; return WildPattern
|
||
<|> do p <- readJSON o; return (ParamPattern (Param p []))
|
||
<|> ParamPattern <$> readJSON o
|
||
<|> RecordPattern <$> readJSON o
|
||
|
||
instance JSON arg => JSON (Param arg) where
|
||
-- parameters without arguments are encoded as strings:
|
||
showJSON (Param p []) = showJSON p
|
||
showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
|
||
|
||
readJSON o = Param <$> readJSON o <*> return []
|
||
<|> Param <$> o!".paramid" <*> o!".args"
|
||
|
||
instance JSON a => JSON (RecordRow a) where
|
||
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
|
||
showJSON row = showJSONs [row]
|
||
showJSONs rows = makeObj (map toRow rows)
|
||
where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
|
||
|
||
readJSON obj = head <$> readJSONs obj
|
||
readJSONs obj = mapM fromRow (assocsJSObject obj)
|
||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||
return (RecordRow (LabelId (rawIdentS lbl)) value)
|
||
|
||
instance JSON rhs => JSON (TableRow rhs) where
|
||
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
|
||
|
||
readJSON o = TableRow <$> o!".pattern" <*> o!".value"
|
||
|
||
|
||
-- *** Identifiers in Concrete Syntax
|
||
|
||
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
|
||
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
|
||
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
|
||
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
|
||
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- ** Used in both Abstract and Concrete Syntax
|
||
|
||
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
|
||
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
|
||
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
|
||
|
||
instance JSON VarId where
|
||
-- the anonymous variable is the underscore:
|
||
showJSON Anonymous = showJSON "_"
|
||
showJSON (VarId x) = showJSON x
|
||
|
||
readJSON o = do parseString "_" o; return Anonymous
|
||
<|> VarId <$> readJSON o
|
||
|
||
instance JSON QualId where
|
||
showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
|
||
showJSON (Unqual n) = showJSON n
|
||
|
||
readJSON o = do qualid <- readJSON o
|
||
let (mod, id) = span (/= '.') qualid
|
||
return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
|
||
|
||
instance JSON RawIdent where
|
||
showJSON i = showJSON $ showRawIdent i
|
||
readJSON o = rawIdentS <$> readJSON o
|
||
|
||
instance JSON Flags where
|
||
-- flags are encoded directly as JSON records (i.e., objects):
|
||
showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
|
||
|
||
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
|
||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||
return (rawIdentS lbl, value)
|
||
|
||
instance JSON FlagValue where
|
||
-- flag values are encoded as basic JSON types:
|
||
showJSON (Str s) = showJSON s
|
||
showJSON (Int i) = showJSON i
|
||
showJSON (Flt f) = showJSON f
|
||
|
||
readJSON = readBasicJSON Str Int Flt
|
||
|
||
|
||
--------------------------------------------------------------------------------
|
||
-- ** Convenience functions
|
||
|
||
parseString :: String -> JSValue -> Result ()
|
||
parseString s o = guard . (== s) =<< readJSON o
|
||
|
||
(!) :: JSON a => JSValue -> String -> Result a
|
||
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
|
||
readJSON
|
||
(lookup key (assocsJSObject obj))
|
||
|
||
assocsJSObject :: JSValue -> [(String, JSValue)]
|
||
assocsJSObject (JSObject o) = fromJSObject o
|
||
assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
|
||
assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
|
||
|
||
|
||
readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
|
||
(String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
|
||
readBasicJSON str int flt o
|
||
= str <$> readJSON o
|
||
<|> int_or_flt <$> readJSON o
|
||
where int_or_flt f | f == fromIntegral n = int n
|
||
| otherwise = flt f
|
||
where n = round f
|