CanonicalJSON.hs

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 <$