PGFtoJSON.hs

module GF.Compile.PGFtoJSON (pgf2json) where

import PGF (showCId)
import qualified PGF.Internal as M
import PGF.Internal (
  Abstr,
  CId,
  CncCat(..),
  CncFun(..),
  Concr,
  DotPos,
  Equation(..),
  Literal(..),
  PArg(..),
  PGF,
  Production(..),
  Symbol(..),
  Type,
  absname,
  abstract,
  cflags,
  cnccats,
  cncfuns,
  concretes,
  funs,
  productions,
  sequences,
  totalCats
  )

import qualified Text.JSON as JSON
import Text.JSON (JSValue(..))

import qualified Data.Array.IArray as Array
import Data.Map (Map)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap

pgf2json :: PGF -> String
pgf2json pgf =
  JSON.encode $ JSON.makeObj
    [ ("abstract", json_abstract)
    , ("concretes", json_concretes)
    ]
 where
   n  = showCId $ absname pgf
   as = abstract pgf
   cs = Map.assocs (concretes pgf)
   start = showCId $ M.lookStartCat pgf
   json_abstract = abstract2json n start as
   json_concretes = JSON.makeObj $ map concrete2json cs

abstract2json :: String -> String -> Abstr -> JSValue
abstract2json name start ds =
  JSON.makeObj
    [ ("name", mkJSStr name)
    , ("startcat", mkJSStr start)
    , ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds)))
    ]

absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
  where
    (args,cat) = M.catSkeleton typ
    sig = JSON.makeObj
      [ ("args", JSArray $ map (mkJSStr.showCId) args)
      , ("cat", mkJSStr $ showCId cat)
      ]

lit2json :: Literal -> JSValue
lit2json (LStr s) = mkJSStr s
lit2json (LInt n) = mkJSInt n
lit2json (LFlt d) = JSRational True (toRational d)

concrete2json :: (CId,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (showCId c,obj)
  where
    obj = JSON.makeObj
      [ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ])
      , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)])
      , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
      , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
      , ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc)))
      , ("totalfids", mkJSInt (totalCats cnc))
      ]

cats2json :: (CId, CncCat) -> (String,JSValue)
cats2json (c,CncCat start end _) = (showCId c, ixs)
  where
    ixs = JSON.makeObj
      [ ("start", mkJSInt start)
      , ("end", mkJSInt end)
      ]

frule2json :: Production -> JSValue
frule2json (PApply fid args) =
  JSON.makeObj
    [ ("type", mkJSStr "Apply")
    , ("fid", mkJSInt fid)
    , ("args", JSArray (map farg2json args))
    ]
frule2json (PCoerce arg) =
  JSON.makeObj
    [ ("type", mkJSStr "Coerce")
    , ("arg", mkJSInt arg)
    ]

farg2json :: PArg -> JSValue
farg2json (PArg hypos fid) =
  JSON.makeObj
    [ ("type", mkJSStr "PArg")
    , ("hypos", JSArray $ map (mkJSInt . snd) hypos)
    , ("fid", mkJSInt fid)
    ]

ffun2json :: CncFun -> JSValue
ffun2json (CncFun f lins) =
  JSON.makeObj
    [ ("name", mkJSStr $ showCId f)
    , ("lins", JSArray (map mkJSInt (Array.elems lins)))
    ]

seq2json :: Array.Array DotPos Symbol -> JSValue
seq2json seq = JSArray [sym2json s | s <- Array.elems seq]

sym2json :: Symbol -> JSValue
sym2json (SymCat n l)    = new "SymCat" [mkJSInt n, mkJSInt l]
sym2json (SymLit n l)    = new "SymLit" [mkJSInt n, mkJSInt l]
sym2json (SymVar n l)    = new "SymVar" [mkJSInt n, mkJSInt l]
sym2json (SymKS t)       = new "SymKS"  [mkJSStr t]
sym2json (SymKP ts alts) = new "SymKP"  [JSArray (map sym2json ts), JSArray (map alt2json alts)]
sym2json SymBIND         = new "SymKS"  [mkJSStr "&+"]
sym2json SymSOFT_BIND    = new "SymKS"  [mkJSStr "&+"]
sym2json SymSOFT_SPACE   = new "SymKS"  [mkJSStr "&+"]
sym2json SymCAPIT        = new "SymKS"  [mkJSStr "&|"]
sym2json SymALL_CAPIT    = new "SymKS"  [mkJSStr "&|"]
sym2json SymNE           = new "SymNE"  []

alt2json :: ([Symbol],[String]) -> JSValue
alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]

new :: String -> [JSValue] -> JSValue
new f xs =
  JSON.makeObj
    [ ("type", mkJSStr f)
    , ("args", JSArray xs)
    ]

-- | Make JSON value from string
mkJSStr :: String -> JSValue
mkJSStr = JSString . JSON.toJSString

-- | Make JSON value from integer
mkJSInt :: Integral a => a -> JSValue
mkJSInt = JSRational False . toRational