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 :: FilePath -> Grammar -> IO ()
encodeJSON FilePath
fpath Grammar
g = FilePath -> FilePath -> IO ()
writeFile FilePath
fpath (Grammar -> FilePath
forall a. JSON a => a -> FilePath
encode Grammar
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 -> JSValue
showJSON (Grammar Abstract
abs [Concrete]
cncs) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"abstract", Abstract -> JSValue
forall a. JSON a => a -> JSValue
showJSON Abstract
abs), (FilePath
"concretes", [Concrete] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [Concrete]
cncs)]

  readJSON :: JSValue -> Result Grammar
readJSON JSValue
o = Abstract -> [Concrete] -> Grammar
Grammar (Abstract -> [Concrete] -> Grammar)
-> Result Abstract -> Result ([Concrete] -> Grammar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result Abstract
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"abstract" Result ([Concrete] -> Grammar)
-> Result [Concrete] -> Result Grammar
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [Concrete]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"concretes"


--------------------------------------------------------------------------------
-- ** Abstract Syntax

instance JSON Abstract where
  showJSON :: Abstract -> JSValue
showJSON (Abstract ModId
absid Flags
flags [CatDef]
cats [FunDef]
funs)
    = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"abs", ModId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ModId
absid),
               (FilePath
"flags", Flags -> JSValue
forall a. JSON a => a -> JSValue
showJSON Flags
flags),
               (FilePath
"cats", [CatDef] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [CatDef]
cats),
               (FilePath
"funs", [FunDef] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [FunDef]
funs)]

  readJSON :: JSValue -> Result Abstract
readJSON JSValue
o = ModId -> Flags -> [CatDef] -> [FunDef] -> Abstract
Abstract
    (ModId -> Flags -> [CatDef] -> [FunDef] -> Abstract)
-> Result ModId
-> Result (Flags -> [CatDef] -> [FunDef] -> Abstract)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result ModId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"abs"
    Result (Flags -> [CatDef] -> [FunDef] -> Abstract)
-> Result Flags -> Result ([CatDef] -> [FunDef] -> Abstract)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>(JSValue
oJSValue -> FilePath -> Result Flags
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"flags" Result Flags -> Result Flags -> Result Flags
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Flags -> Result Flags
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FlagName, FlagValue)] -> Flags
Flags []))
    Result ([CatDef] -> [FunDef] -> Abstract)
-> Result [CatDef] -> Result ([FunDef] -> Abstract)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [CatDef]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"cats"
    Result ([FunDef] -> Abstract) -> Result [FunDef] -> Result Abstract
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [FunDef]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"funs"

instance JSON CatDef where
  -- non-dependent categories are encoded as simple strings:
  showJSON :: CatDef -> JSValue
showJSON (CatDef CatId
c []) = CatId -> JSValue
forall a. JSON a => a -> JSValue
showJSON CatId
c
  showJSON (CatDef CatId
c [CatId]
cs) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"cat", CatId -> JSValue
forall a. JSON a => a -> JSValue
showJSON CatId
c), (FilePath
"args", [CatId] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [CatId]
cs)]

  readJSON :: JSValue -> Result CatDef
readJSON JSValue
o = CatId -> [CatId] -> CatDef
CatDef (CatId -> [CatId] -> CatDef)
-> Result CatId -> Result ([CatId] -> CatDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result CatId
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o Result ([CatId] -> CatDef) -> Result [CatId] -> Result CatDef
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [CatId] -> Result [CatId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Result CatDef -> Result CatDef -> Result CatDef
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        CatId -> [CatId] -> CatDef
CatDef (CatId -> [CatId] -> CatDef)
-> Result CatId -> Result ([CatId] -> CatDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result CatId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"cat" Result ([CatId] -> CatDef) -> Result [CatId] -> Result CatDef
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [CatId]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"args"

instance JSON FunDef where
  showJSON :: FunDef -> JSValue
showJSON (FunDef FunId
f Type
ty) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"fun", FunId -> JSValue
forall a. JSON a => a -> JSValue
showJSON FunId
f), (FilePath
"type", Type -> JSValue
forall a. JSON a => a -> JSValue
showJSON Type
ty)]

  readJSON :: JSValue -> Result FunDef
readJSON JSValue
o = FunId -> Type -> FunDef
FunDef (FunId -> Type -> FunDef)
-> Result FunId -> Result (Type -> FunDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result FunId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"fun" Result (Type -> FunDef) -> Result Type -> Result FunDef
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result Type
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"type"

instance JSON Type where
  showJSON :: Type -> JSValue
showJSON (Type [TypeBinding]
bs TypeApp
ty) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".args", [TypeBinding] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [TypeBinding]
bs), (FilePath
".result", TypeApp -> JSValue
forall a. JSON a => a -> JSValue
showJSON TypeApp
ty)]

  readJSON :: JSValue -> Result Type
readJSON JSValue
o = [TypeBinding] -> TypeApp -> Type
Type ([TypeBinding] -> TypeApp -> Type)
-> Result [TypeBinding] -> Result (TypeApp -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result [TypeBinding]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".args" Result (TypeApp -> Type) -> Result TypeApp -> Result Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result TypeApp
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".result"

instance JSON TypeApp where
  -- non-dependent categories are encoded as simple strings:
  showJSON :: TypeApp -> JSValue
showJSON (TypeApp CatId
c [])   = CatId -> JSValue
forall a. JSON a => a -> JSValue
showJSON CatId
c
  showJSON (TypeApp CatId
c [Type]
args) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".cat", CatId -> JSValue
forall a. JSON a => a -> JSValue
showJSON CatId
c), (FilePath
".args", [Type] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [Type]
args)]

  readJSON :: JSValue -> Result TypeApp
readJSON JSValue
o = CatId -> [Type] -> TypeApp
TypeApp (CatId -> [Type] -> TypeApp)
-> Result CatId -> Result ([Type] -> TypeApp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result CatId
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o Result ([Type] -> TypeApp) -> Result [Type] -> Result TypeApp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> Result [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Result TypeApp -> Result TypeApp -> Result TypeApp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        CatId -> [Type] -> TypeApp
TypeApp (CatId -> [Type] -> TypeApp)
-> Result CatId -> Result ([Type] -> TypeApp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result CatId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".cat" Result ([Type] -> TypeApp) -> Result [Type] -> Result TypeApp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [Type]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".args"

instance JSON TypeBinding where
  -- non-dependent categories are encoded as simple strings:
  showJSON :: TypeBinding -> JSValue
showJSON (TypeBinding VarId
Anonymous (Type [] (TypeApp CatId
c []))) = CatId -> JSValue
forall a. JSON a => a -> JSValue
showJSON CatId
c
  showJSON (TypeBinding VarId
x Type
ty) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".var", VarId -> JSValue
forall a. JSON a => a -> JSValue
showJSON VarId
x), (FilePath
".type", Type -> JSValue
forall a. JSON a => a -> JSValue
showJSON Type
ty)]

  readJSON :: JSValue -> Result TypeBinding
readJSON JSValue
o = do CatId
c <- JSValue -> Result CatId
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
                  TypeBinding -> Result TypeBinding
forall (m :: * -> *) a. Monad m => a -> m a
return (VarId -> Type -> TypeBinding
TypeBinding VarId
Anonymous ([TypeBinding] -> TypeApp -> Type
Type [] (CatId -> [Type] -> TypeApp
TypeApp CatId
c [])))
           Result TypeBinding -> Result TypeBinding -> Result TypeBinding
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VarId -> Type -> TypeBinding
TypeBinding (VarId -> Type -> TypeBinding)
-> Result VarId -> Result (Type -> TypeBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result VarId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".var" Result (Type -> TypeBinding) -> Result Type -> Result TypeBinding
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result Type
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".type"


--------------------------------------------------------------------------------
-- ** Concrete syntax

instance JSON Concrete where
  showJSON :: Concrete -> JSValue
showJSON (Concrete ModId
cncid ModId
absid Flags
flags [ParamDef]
params [LincatDef]
lincats [LinDef]
lins)
    = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"cnc", ModId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ModId
cncid),
               (FilePath
"abs", ModId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ModId
absid),
               (FilePath
"flags", Flags -> JSValue
forall a. JSON a => a -> JSValue
showJSON Flags
flags),
               (FilePath
"params", [ParamDef] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [ParamDef]
params),
               (FilePath
"lincats", [LincatDef] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [LincatDef]
lincats),
               (FilePath
"lins", [LinDef] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [LinDef]
lins)]

  readJSON :: JSValue -> Result Concrete
readJSON JSValue
o = ModId
-> ModId
-> Flags
-> [ParamDef]
-> [LincatDef]
-> [LinDef]
-> Concrete
Concrete
    (ModId
 -> ModId
 -> Flags
 -> [ParamDef]
 -> [LincatDef]
 -> [LinDef]
 -> Concrete)
-> Result ModId
-> Result
     (ModId
      -> Flags -> [ParamDef] -> [LincatDef] -> [LinDef] -> Concrete)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result ModId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"cnc"
    Result
  (ModId
   -> Flags -> [ParamDef] -> [LincatDef] -> [LinDef] -> Concrete)
-> Result ModId
-> Result
     (Flags -> [ParamDef] -> [LincatDef] -> [LinDef] -> Concrete)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result ModId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"abs"
    Result (Flags -> [ParamDef] -> [LincatDef] -> [LinDef] -> Concrete)
-> Result Flags
-> Result ([ParamDef] -> [LincatDef] -> [LinDef] -> Concrete)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>(JSValue
oJSValue -> FilePath -> Result Flags
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"flags" Result Flags -> Result Flags -> Result Flags
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Flags -> Result Flags
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FlagName, FlagValue)] -> Flags
Flags []))
    Result ([ParamDef] -> [LincatDef] -> [LinDef] -> Concrete)
-> Result [ParamDef]
-> Result ([LincatDef] -> [LinDef] -> Concrete)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [ParamDef]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"params"
    Result ([LincatDef] -> [LinDef] -> Concrete)
-> Result [LincatDef] -> Result ([LinDef] -> Concrete)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [LincatDef]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"lincats"
    Result ([LinDef] -> Concrete) -> Result [LinDef] -> Result Concrete
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [LinDef]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"lins"

instance JSON ParamDef where
  showJSON :: ParamDef -> JSValue
showJSON (ParamDef      ParamId
p [ParamValueDef]
pvs) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"param", ParamId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamId
p), (FilePath
"values", [ParamValueDef] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [ParamValueDef]
pvs)]
  showJSON (ParamAliasDef ParamId
p LinType
t)   = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"param", ParamId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamId
p), (FilePath
"alias", LinType -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinType
t)]

  readJSON :: JSValue -> Result ParamDef
readJSON JSValue
o = ParamId -> [ParamValueDef] -> ParamDef
ParamDef      (ParamId -> [ParamValueDef] -> ParamDef)
-> Result ParamId -> Result ([ParamValueDef] -> ParamDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result ParamId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"param" Result ([ParamValueDef] -> ParamDef)
-> Result [ParamValueDef] -> Result ParamDef
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [ParamValueDef]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"values"
    Result ParamDef -> Result ParamDef -> Result ParamDef
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        ParamId -> LinType -> ParamDef
ParamAliasDef (ParamId -> LinType -> ParamDef)
-> Result ParamId -> Result (LinType -> ParamDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result ParamId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"param" Result (LinType -> ParamDef) -> Result LinType -> Result ParamDef
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result LinType
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"alias"

instance JSON LincatDef where
  showJSON :: LincatDef -> JSValue
showJSON (LincatDef CatId
c LinType
lt) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"cat", CatId -> JSValue
forall a. JSON a => a -> JSValue
showJSON CatId
c), (FilePath
"lintype", LinType -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinType
lt)]

  readJSON :: JSValue -> Result LincatDef
readJSON JSValue
o = CatId -> LinType -> LincatDef
LincatDef (CatId -> LinType -> LincatDef)
-> Result CatId -> Result (LinType -> LincatDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result CatId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"cat" Result (LinType -> LincatDef) -> Result LinType -> Result LincatDef
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result LinType
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"lintype"

instance JSON LinDef where
  showJSON :: LinDef -> JSValue
showJSON (LinDef FunId
f [VarId]
xs LinValue
lv) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
"fun", FunId -> JSValue
forall a. JSON a => a -> JSValue
showJSON FunId
f), (FilePath
"args", [VarId] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [VarId]
xs), (FilePath
"lin", LinValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinValue
lv)]

  readJSON :: JSValue -> Result LinDef
readJSON JSValue
o = FunId -> [VarId] -> LinValue -> LinDef
LinDef (FunId -> [VarId] -> LinValue -> LinDef)
-> Result FunId -> Result ([VarId] -> LinValue -> LinDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result FunId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"fun" Result ([VarId] -> LinValue -> LinDef)
-> Result [VarId] -> Result (LinValue -> LinDef)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [VarId]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"args" Result (LinValue -> LinDef) -> Result LinValue -> Result LinDef
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result LinValue
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
"lin"

instance JSON LinType where
  -- the basic types (Str, Float, Int) are encoded as strings:
  showJSON :: LinType -> JSValue
showJSON (LinType
StrType)         = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
"Str"
  showJSON (LinType
FloatType)       = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
"Float"
  showJSON (LinType
IntType)         = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
"Int"
  -- parameters are also encoded as strings:
  showJSON (ParamType ParamType
pt)    = ParamType -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamType
pt
  -- tables/tuples are encoded as JSON objects:
  showJSON (TableType LinType
pt LinType
lt) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".tblarg", LinType -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinType
pt), (FilePath
".tblval", LinType -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinType
lt)]
  showJSON (TupleType [LinType]
lts)   = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".tuple",  [LinType] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [LinType]
lts)]
  -- records are encoded as records:
  showJSON (RecordType [RecordRowType]
rows) = [RecordRowType] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [RecordRowType]
rows

  readJSON :: JSValue -> Result LinType
readJSON JSValue
o = LinType
StrType   LinType -> Result () -> Result LinType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FilePath -> JSValue -> Result ()
parseString FilePath
"Str"   JSValue
o
    Result LinType -> Result LinType -> Result LinType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        LinType
FloatType LinType -> Result () -> Result LinType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FilePath -> JSValue -> Result ()
parseString FilePath
"Float" JSValue
o
    Result LinType -> Result LinType -> Result LinType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        LinType
IntType   LinType -> Result () -> Result LinType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FilePath -> JSValue -> Result ()
parseString FilePath
"Int"   JSValue
o
    Result LinType -> Result LinType -> Result LinType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        ParamType -> LinType
ParamType (ParamType -> LinType) -> Result ParamType -> Result LinType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result ParamType
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
    Result LinType -> Result LinType -> Result LinType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        LinType -> LinType -> LinType
TableType  (LinType -> LinType -> LinType)
-> Result LinType -> Result (LinType -> LinType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result LinType
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".tblarg" Result (LinType -> LinType) -> Result LinType -> Result LinType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result LinType
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".tblval"
    Result LinType -> Result LinType -> Result LinType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        [LinType] -> LinType
TupleType  ([LinType] -> LinType) -> Result [LinType] -> Result LinType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result [LinType]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".tuple"
    Result LinType -> Result LinType -> Result LinType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        [RecordRowType] -> LinType
RecordType ([RecordRowType] -> LinType)
-> Result [RecordRowType] -> Result LinType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result [RecordRowType]
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o

instance JSON LinValue where
  showJSON :: LinValue -> JSValue
showJSON (LiteralValue  LinLiteral
l ) = LinLiteral -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinLiteral
l
  -- most values are encoded as JSON objects:
  showJSON (ParamConstant ParamValue
pv) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".param",    ParamValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamValue
pv)]
  showJSON (PredefValue   PredefId
p ) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".predef",   PredefId -> JSValue
forall a. JSON a => a -> JSValue
showJSON PredefId
p)]
  showJSON (TableValue LinType
t [TableRowValue]
tvs) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".tblarg",   LinType -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinType
t), (FilePath
".tblrows", [TableRowValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [TableRowValue]
tvs)]
  showJSON (TupleValue   [LinValue]
lvs) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".tuple",    [LinValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [LinValue]
lvs)]
  showJSON (VarValue      VarValueId
v ) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".var",      VarValueId -> JSValue
forall a. JSON a => a -> JSValue
showJSON VarValueId
v)]
  showJSON (ErrorValue    FilePath
s ) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".error",    FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
s)]
  showJSON (Projection LinValue
lv LabelId
l ) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".project",  LinValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinValue
lv), (FilePath
".label", LabelId -> JSValue
forall a. JSON a => a -> JSValue
showJSON LabelId
l)]
  showJSON (Selection  LinValue
tv LinValue
pv) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".select",   LinValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinValue
tv), (FilePath
".key", LinValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinValue
pv)]
  showJSON (VariantValue  [LinValue]
vs) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".variants", [LinValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [LinValue]
vs)]
  showJSON (PreValue [([FilePath], LinValue)]
pre LinValue
def) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".pre",      [([FilePath], LinValue)] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [([FilePath], LinValue)]
pre),(FilePath
".default", LinValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinValue
def)]
  -- records are encoded directly as JSON records:
  showJSON (RecordValue [RecordRowValue]
rows) = [RecordRowValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [RecordRowValue]
rows
  -- concatenation is encoded as a JSON array:
  showJSON v :: LinValue
v@(ConcatValue LinValue
_ LinValue
_) = [LinValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON (LinValue -> [LinValue] -> [LinValue]
flatten LinValue
v [])
    where flatten :: LinValue -> [LinValue] -> [LinValue]
flatten (ConcatValue LinValue
v LinValue
v') = LinValue -> [LinValue] -> [LinValue]
flatten LinValue
v ([LinValue] -> [LinValue])
-> ([LinValue] -> [LinValue]) -> [LinValue] -> [LinValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinValue -> [LinValue] -> [LinValue]
flatten LinValue
v'
          flatten  LinValue
v                 = (LinValue
v LinValue -> [LinValue] -> [LinValue]
forall a. a -> [a] -> [a]
:)

  readJSON :: JSValue -> Result LinValue
readJSON JSValue
o = LinLiteral -> LinValue
LiteralValue  (LinLiteral -> LinValue) -> Result LinLiteral -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result LinLiteral
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        ParamValue -> LinValue
ParamConstant (ParamValue -> LinValue) -> Result ParamValue -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result ParamValue
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".param"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        PredefId -> LinValue
PredefValue   (PredefId -> LinValue) -> Result PredefId -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result PredefId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".predef"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        LinType -> [TableRowValue] -> LinValue
TableValue    (LinType -> [TableRowValue] -> LinValue)
-> Result LinType -> Result ([TableRowValue] -> LinValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result LinType
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".tblarg"  Result ([TableRowValue] -> LinValue)
-> Result [TableRowValue] -> Result LinValue
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [TableRowValue]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".tblrows"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        [LinValue] -> LinValue
TupleValue    ([LinValue] -> LinValue) -> Result [LinValue] -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result [LinValue]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".tuple"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        VarValueId -> LinValue
VarValue      (VarValueId -> LinValue) -> Result VarValueId -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result VarValueId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".var"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        FilePath -> LinValue
ErrorValue    (FilePath -> LinValue) -> Result FilePath -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result FilePath
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".error"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        LinValue -> LabelId -> LinValue
Projection    (LinValue -> LabelId -> LinValue)
-> Result LinValue -> Result (LabelId -> LinValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result LinValue
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".project" Result (LabelId -> LinValue) -> Result LabelId -> Result LinValue
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result LabelId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".label"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        LinValue -> LinValue -> LinValue
Selection     (LinValue -> LinValue -> LinValue)
-> Result LinValue -> Result (LinValue -> LinValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result LinValue
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".select"  Result (LinValue -> LinValue) -> Result LinValue -> Result LinValue
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result LinValue
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".key"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        [LinValue] -> LinValue
VariantValue  ([LinValue] -> LinValue) -> Result [LinValue] -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result [LinValue]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".variants"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        [([FilePath], LinValue)] -> LinValue -> LinValue
PreValue      ([([FilePath], LinValue)] -> LinValue -> LinValue)
-> Result [([FilePath], LinValue)] -> Result (LinValue -> LinValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result [([FilePath], LinValue)]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".pre"     Result (LinValue -> LinValue) -> Result LinValue -> Result LinValue
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result LinValue
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".default"
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        [RecordRowValue] -> LinValue
RecordValue   ([RecordRowValue] -> LinValue)
-> Result [RecordRowValue] -> Result LinValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result [RecordRowValue]
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
    Result LinValue -> Result LinValue -> Result LinValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        do [LinValue]
vs <- JSValue -> Result [LinValue]
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o :: Result [LinValue]
                  LinValue -> Result LinValue
forall (m :: * -> *) a. Monad m => a -> m a
return ((LinValue -> LinValue -> LinValue) -> [LinValue] -> LinValue
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 LinValue -> LinValue -> LinValue
ConcatValue [LinValue]
vs)

instance JSON LinLiteral where
  -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
  showJSON :: LinLiteral -> JSValue
showJSON (StrConstant   FilePath
s) = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
s
  showJSON (FloatConstant Float
f) = Float -> JSValue
forall a. JSON a => a -> JSValue
showJSON Float
f
  showJSON (IntConstant   Int
n) = Int -> JSValue
forall a. JSON a => a -> JSValue
showJSON Int
n

  readJSON :: JSValue -> Result LinLiteral
readJSON = (FilePath -> LinLiteral)
-> (Int -> LinLiteral)
-> (Float -> LinLiteral)
-> JSValue
-> Result LinLiteral
forall int flt v.
(JSON int, Integral int, JSON flt, RealFloat flt) =>
(FilePath -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
readBasicJSON FilePath -> LinLiteral
StrConstant Int -> LinLiteral
IntConstant Float -> LinLiteral
FloatConstant

instance JSON LinPattern where
  -- wildcards and patterns without arguments are encoded as strings:
  showJSON :: LinPattern -> JSValue
showJSON (LinPattern
WildPattern) = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
"_"
  showJSON (ParamPattern (Param ParamId
p [])) = ParamId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamId
p
  -- complex patterns are encoded as JSON objects:
  showJSON (ParamPattern Param LinPattern
pv) = Param LinPattern -> JSValue
forall a. JSON a => a -> JSValue
showJSON Param LinPattern
pv
  -- and records as records:
  showJSON (RecordPattern [RecordRow LinPattern]
r) = [RecordRow LinPattern] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [RecordRow LinPattern]
r

  readJSON :: JSValue -> Result LinPattern
readJSON JSValue
o = do  ()
p  <- FilePath -> JSValue -> Result ()
parseString FilePath
"_" JSValue
o; LinPattern -> Result LinPattern
forall (m :: * -> *) a. Monad m => a -> m a
return LinPattern
WildPattern
    Result LinPattern -> Result LinPattern -> Result LinPattern
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        do  ParamId
p  <- JSValue -> Result ParamId
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o; LinPattern -> Result LinPattern
forall (m :: * -> *) a. Monad m => a -> m a
return (Param LinPattern -> LinPattern
ParamPattern (ParamId -> [LinPattern] -> Param LinPattern
forall arg. ParamId -> [arg] -> Param arg
Param ParamId
p []))
    Result LinPattern -> Result LinPattern -> Result LinPattern
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        Param LinPattern -> LinPattern
ParamPattern  (Param LinPattern -> LinPattern)
-> Result (Param LinPattern) -> Result LinPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result (Param LinPattern)
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
    Result LinPattern -> Result LinPattern -> Result LinPattern
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        [RecordRow LinPattern] -> LinPattern
RecordPattern ([RecordRow LinPattern] -> LinPattern)
-> Result [RecordRow LinPattern] -> Result LinPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result [RecordRow LinPattern]
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o

instance JSON arg => JSON (Param arg) where
  -- parameters without arguments are encoded as strings:
  showJSON :: Param arg -> JSValue
showJSON (Param ParamId
p [])   = ParamId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamId
p
  showJSON (Param ParamId
p [arg]
args) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".paramid", ParamId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamId
p), (FilePath
".args", [arg] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [arg]
args)]

  readJSON :: JSValue -> Result (Param arg)
readJSON JSValue
o = ParamId -> [arg] -> Param arg
forall arg. ParamId -> [arg] -> Param arg
Param (ParamId -> [arg] -> Param arg)
-> Result ParamId -> Result ([arg] -> Param arg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result ParamId
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o Result ([arg] -> Param arg) -> Result [arg] -> Result (Param arg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [arg] -> Result [arg]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Result (Param arg) -> Result (Param arg) -> Result (Param arg)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        ParamId -> [arg] -> Param arg
forall arg. ParamId -> [arg] -> Param arg
Param (ParamId -> [arg] -> Param arg)
-> Result ParamId -> Result ([arg] -> Param arg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result ParamId
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".paramid" Result ([arg] -> Param arg) -> Result [arg] -> Result (Param arg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result [arg]
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".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 :: RecordRow a -> JSValue
showJSON  RecordRow a
row  = [RecordRow a] -> JSValue
forall a. JSON a => [a] -> JSValue
showJSONs [RecordRow a
row]
  showJSONs :: [RecordRow a] -> JSValue
showJSONs [RecordRow a]
rows = [(FilePath, JSValue)] -> JSValue
makeObj ((RecordRow a -> (FilePath, JSValue))
-> [RecordRow a] -> [(FilePath, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map RecordRow a -> (FilePath, JSValue)
forall a. JSON a => RecordRow a -> (FilePath, JSValue)
toRow [RecordRow a]
rows)
    where toRow :: RecordRow a -> (FilePath, JSValue)
toRow (RecordRow (LabelId FlagName
lbl) a
val) = (FlagName -> FilePath
showRawIdent FlagName
lbl, a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
val)

  readJSON :: JSValue -> Result (RecordRow a)
readJSON  JSValue
obj = [RecordRow a] -> RecordRow a
forall a. [a] -> a
head ([RecordRow a] -> RecordRow a)
-> Result [RecordRow a] -> Result (RecordRow a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result [RecordRow a]
forall a. JSON a => JSValue -> Result [a]
readJSONs JSValue
obj
  readJSONs :: JSValue -> Result [RecordRow a]
readJSONs JSValue
obj = ((FilePath, JSValue) -> Result (RecordRow a))
-> [(FilePath, JSValue)] -> Result [RecordRow a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath, JSValue) -> Result (RecordRow a)
forall rhs.
JSON rhs =>
(FilePath, JSValue) -> Result (RecordRow rhs)
fromRow (JSValue -> [(FilePath, JSValue)]
assocsJSObject JSValue
obj)
    where fromRow :: (FilePath, JSValue) -> Result (RecordRow rhs)
fromRow (FilePath
lbl, JSValue
jsvalue) = do rhs
value <- JSValue -> Result rhs
forall a. JSON a => JSValue -> Result a
readJSON JSValue
jsvalue
                                      RecordRow rhs -> Result (RecordRow rhs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelId -> rhs -> RecordRow rhs
forall rhs. LabelId -> rhs -> RecordRow rhs
RecordRow (FlagName -> LabelId
LabelId (FilePath -> FlagName
rawIdentS FilePath
lbl)) rhs
value)

instance JSON rhs => JSON (TableRow rhs) where
  showJSON :: TableRow rhs -> JSValue
showJSON (TableRow LinPattern
l rhs
v) = [(FilePath, JSValue)] -> JSValue
makeObj [(FilePath
".pattern", LinPattern -> JSValue
forall a. JSON a => a -> JSValue
showJSON LinPattern
l), (FilePath
".value", rhs -> JSValue
forall a. JSON a => a -> JSValue
showJSON rhs
v)]

  readJSON :: JSValue -> Result (TableRow rhs)
readJSON JSValue
o = LinPattern -> rhs -> TableRow rhs
forall rhs. LinPattern -> rhs -> TableRow rhs
TableRow (LinPattern -> rhs -> TableRow rhs)
-> Result LinPattern -> Result (rhs -> TableRow rhs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue
oJSValue -> FilePath -> Result LinPattern
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".pattern" Result (rhs -> TableRow rhs) -> Result rhs -> Result (TableRow rhs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue
oJSValue -> FilePath -> Result rhs
forall a. JSON a => JSValue -> FilePath -> Result a
!FilePath
".value"


-- *** Identifiers in Concrete Syntax

instance JSON PredefId   where showJSON :: PredefId -> JSValue
showJSON (PredefId    FlagName
s) = FlagName -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagName
s ; readJSON :: JSValue -> Result PredefId
readJSON = (FlagName -> PredefId) -> Result FlagName -> Result PredefId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FlagName -> PredefId
PredefId    (Result FlagName -> Result PredefId)
-> (JSValue -> Result FlagName) -> JSValue -> Result PredefId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result FlagName
forall a. JSON a => JSValue -> Result a
readJSON
instance JSON LabelId    where showJSON :: LabelId -> JSValue
showJSON (LabelId     FlagName
s) = FlagName -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagName
s ; readJSON :: JSValue -> Result LabelId
readJSON = (FlagName -> LabelId) -> Result FlagName -> Result LabelId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FlagName -> LabelId
LabelId     (Result FlagName -> Result LabelId)
-> (JSValue -> Result FlagName) -> JSValue -> Result LabelId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result FlagName
forall a. JSON a => JSValue -> Result a
readJSON
instance JSON VarValueId where showJSON :: VarValueId -> JSValue
showJSON (VarValueId  QualId
s) = QualId -> JSValue
forall a. JSON a => a -> JSValue
showJSON QualId
s ; readJSON :: JSValue -> Result VarValueId
readJSON = (QualId -> VarValueId) -> Result QualId -> Result VarValueId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QualId -> VarValueId
VarValueId  (Result QualId -> Result VarValueId)
-> (JSValue -> Result QualId) -> JSValue -> Result VarValueId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result QualId
forall a. JSON a => JSValue -> Result a
readJSON
instance JSON ParamId    where showJSON :: ParamId -> JSValue
showJSON (ParamId     QualId
s) = QualId -> JSValue
forall a. JSON a => a -> JSValue
showJSON QualId
s ; readJSON :: JSValue -> Result ParamId
readJSON = (QualId -> ParamId) -> Result QualId -> Result ParamId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QualId -> ParamId
ParamId     (Result QualId -> Result ParamId)
-> (JSValue -> Result QualId) -> JSValue -> Result ParamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result QualId
forall a. JSON a => JSValue -> Result a
readJSON
instance JSON ParamType  where showJSON :: ParamType -> JSValue
showJSON (ParamTypeId ParamId
s) = ParamId -> JSValue
forall a. JSON a => a -> JSValue
showJSON ParamId
s ; readJSON :: JSValue -> Result ParamType
readJSON = (ParamId -> ParamType) -> Result ParamId -> Result ParamType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParamId -> ParamType
ParamTypeId (Result ParamId -> Result ParamType)
-> (JSValue -> Result ParamId) -> JSValue -> Result ParamType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result ParamId
forall a. JSON a => JSValue -> Result a
readJSON


--------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax

instance JSON ModId where showJSON :: ModId -> JSValue
showJSON (ModId FlagName
s) = FlagName -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagName
s ; readJSON :: JSValue -> Result ModId
readJSON = (FlagName -> ModId) -> Result FlagName -> Result ModId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FlagName -> ModId
ModId (Result FlagName -> Result ModId)
-> (JSValue -> Result FlagName) -> JSValue -> Result ModId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result FlagName
forall a. JSON a => JSValue -> Result a
readJSON
instance JSON CatId where showJSON :: CatId -> JSValue
showJSON (CatId FlagName
s) = FlagName -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagName
s ; readJSON :: JSValue -> Result CatId
readJSON = (FlagName -> CatId) -> Result FlagName -> Result CatId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FlagName -> CatId
CatId (Result FlagName -> Result CatId)
-> (JSValue -> Result FlagName) -> JSValue -> Result CatId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result FlagName
forall a. JSON a => JSValue -> Result a
readJSON
instance JSON FunId where showJSON :: FunId -> JSValue
showJSON (FunId FlagName
s) = FlagName -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagName
s ; readJSON :: JSValue -> Result FunId
readJSON = (FlagName -> FunId) -> Result FlagName -> Result FunId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FlagName -> FunId
FunId (Result FlagName -> Result FunId)
-> (JSValue -> Result FlagName) -> JSValue -> Result FunId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> Result FlagName
forall a. JSON a => JSValue -> Result a
readJSON

instance JSON VarId where
  -- the anonymous variable is the underscore:
  showJSON :: VarId -> JSValue
showJSON VarId
Anonymous = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
"_"
  showJSON (VarId FlagName
x) = FlagName -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagName
x

  readJSON :: JSValue -> Result VarId
readJSON JSValue
o = do FilePath -> JSValue -> Result ()
parseString FilePath
"_" JSValue
o; VarId -> Result VarId
forall (m :: * -> *) a. Monad m => a -> m a
return VarId
Anonymous
    Result VarId -> Result VarId -> Result VarId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>        FlagName -> VarId
VarId (FlagName -> VarId) -> Result FlagName -> Result VarId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result FlagName
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o

instance JSON QualId where
  showJSON :: QualId -> JSValue
showJSON (Qual (ModId FlagName
m) FlagName
n) = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON (FlagName -> FilePath
showRawIdent FlagName
mFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"."FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FlagName -> FilePath
showRawIdent FlagName
n)
  showJSON (Unqual FlagName
n) = FlagName -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagName
n

  readJSON :: JSValue -> Result QualId
readJSON JSValue
o = do FilePath
qualid <- JSValue -> Result FilePath
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
                  let (FilePath
mod, FilePath
id) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') FilePath
qualid
                  QualId -> Result QualId
forall (m :: * -> *) a. Monad m => a -> m a
return (QualId -> Result QualId) -> QualId -> Result QualId
forall a b. (a -> b) -> a -> b
$ if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
mod then FlagName -> QualId
Unqual (FilePath -> FlagName
rawIdentS FilePath
id) else ModId -> FlagName -> QualId
Qual (FlagName -> ModId
ModId (FilePath -> FlagName
rawIdentS FilePath
mod)) (FilePath -> FlagName
rawIdentS FilePath
id)

instance JSON RawIdent where
  showJSON :: FlagName -> JSValue
showJSON FlagName
i = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON (FilePath -> JSValue) -> FilePath -> JSValue
forall a b. (a -> b) -> a -> b
$ FlagName -> FilePath
showRawIdent FlagName
i
  readJSON :: JSValue -> Result FlagName
readJSON JSValue
o = FilePath -> FlagName
rawIdentS (FilePath -> FlagName) -> Result FilePath -> Result FlagName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result FilePath
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o

instance JSON Flags where
  -- flags are encoded directly as JSON records (i.e., objects):
  showJSON :: Flags -> JSValue
showJSON (Flags [(FlagName, FlagValue)]
fs) = [(FilePath, JSValue)] -> JSValue
makeObj [(FlagName -> FilePath
showRawIdent FlagName
f, FlagValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON FlagValue
v) | (FlagName
f, FlagValue
v) <- [(FlagName, FlagValue)]
fs]

  readJSON :: JSValue -> Result Flags
readJSON JSValue
obj = [(FlagName, FlagValue)] -> Flags
Flags ([(FlagName, FlagValue)] -> Flags)
-> Result [(FlagName, FlagValue)] -> Result Flags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FilePath, JSValue) -> Result (FlagName, FlagValue))
-> [(FilePath, JSValue)] -> Result [(FlagName, FlagValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath, JSValue) -> Result (FlagName, FlagValue)
forall b. JSON b => (FilePath, JSValue) -> Result (FlagName, b)
fromRow (JSValue -> [(FilePath, JSValue)]
assocsJSObject JSValue
obj)
    where fromRow :: (FilePath, JSValue) -> Result (FlagName, b)
fromRow (FilePath
lbl, JSValue
jsvalue) = do b
value <- JSValue -> Result b
forall a. JSON a => JSValue -> Result a
readJSON JSValue
jsvalue
                                      (FlagName, b) -> Result (FlagName, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FlagName
rawIdentS FilePath
lbl, b
value)

instance JSON FlagValue where
  -- flag values are encoded as basic JSON types:
  showJSON :: FlagValue -> JSValue
showJSON (Str FilePath
s) = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON FilePath
s
  showJSON (Int Int
i) = Int -> JSValue
forall a. JSON a => a -> JSValue
showJSON Int
i
  showJSON (Flt Double
f) = Double -> JSValue
forall a. JSON a => a -> JSValue
showJSON Double
f

  readJSON :: JSValue -> Result FlagValue
readJSON = (FilePath -> FlagValue)
-> (Int -> FlagValue)
-> (Double -> FlagValue)
-> JSValue
-> Result FlagValue
forall int flt v.
(JSON int, Integral int, JSON flt, RealFloat flt) =>
(FilePath -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
readBasicJSON FilePath -> FlagValue
Str Int -> FlagValue
Int Double -> FlagValue
Flt


--------------------------------------------------------------------------------
-- ** Convenience functions

parseString :: String -> JSValue -> Result ()
parseString :: FilePath -> JSValue -> Result ()
parseString FilePath
s JSValue
o = Bool -> Result ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Result ()) -> (FilePath -> Bool) -> FilePath -> Result ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
s) (FilePath -> Result ()) -> Result FilePath -> Result ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSValue -> Result FilePath
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o

(!) :: JSON a => JSValue -> String -> Result a
JSValue
obj ! :: JSValue -> FilePath -> Result a
! FilePath
key = Result a -> (JSValue -> Result a) -> Maybe JSValue -> Result a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Result a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Result a) -> FilePath -> Result a
forall a b. (a -> b) -> a -> b
$ FilePath
"CanonicalJSON.(!): Could not find key: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
key)
            JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON
            (FilePath -> [(FilePath, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
key (JSValue -> [(FilePath, JSValue)]
assocsJSObject JSValue
obj))

assocsJSObject :: JSValue -> [(String, JSValue)]
assocsJSObject :: JSValue -> [(FilePath, JSValue)]
assocsJSObject (JSObject JSObject JSValue
o) = JSObject JSValue -> [(FilePath, JSValue)]
forall e. JSObject e -> [(FilePath, e)]
fromJSObject JSObject JSValue
o
assocsJSObject (JSArray  [JSValue]
_) = FilePath -> [(FilePath, JSValue)]
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> [(FilePath, JSValue)])
-> FilePath -> [(FilePath, JSValue)]
forall a b. (a -> b) -> a -> b
$ FilePath
"CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
assocsJSObject  JSValue
jsvalue     = FilePath -> [(FilePath, JSValue)]
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> [(FilePath, JSValue)])
-> FilePath -> [(FilePath, JSValue)]
forall a b. (a -> b) -> a -> b
$ FilePath
"CanonicalJSON.assocsJSObject: Expected a JSON object, found " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ JSValue -> FilePath
forall a. Show a => a -> FilePath
show JSValue
jsvalue


readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
                 (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
readBasicJSON :: (FilePath -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
readBasicJSON FilePath -> v
str int -> v
int flt -> v
flt JSValue
o
  =   FilePath -> v
str        (FilePath -> v) -> Result FilePath -> Result v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result FilePath
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
  Result v -> Result v -> Result v
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> flt -> v
int_or_flt (flt -> v) -> Result flt -> Result v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result flt
forall a. JSON a => JSValue -> Result a
readJSON JSValue
o
  where int_or_flt :: flt -> v
int_or_flt flt
f | flt
f flt -> flt -> Bool
forall a. Eq a => a -> a -> Bool
== int -> flt
forall a b. (Integral a, Num b) => a -> b
fromIntegral int
n = int -> v
int int
n
                     | Bool
otherwise           = flt -> v
flt flt
f
          where n :: int
n = flt -> int
forall a b. (RealFrac a, Integral b) => a -> b
round flt
f