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 -> String
pgf2json PGF
pgf =
  JSValue -> String
forall a. JSON a => a -> String
JSON.encode (JSValue -> String) -> JSValue -> String
forall a b. (a -> b) -> a -> b
$ [(String, JSValue)] -> JSValue
JSON.makeObj
    [ (String
"abstract", JSValue
json_abstract)
    , (String
"concretes", JSValue
json_concretes)
    ]
 where
   n :: String
n  = CId -> String
showCId (CId -> String) -> CId -> String
forall a b. (a -> b) -> a -> b
$ PGF -> CId
absname PGF
pgf
   as :: Abstr
as = PGF -> Abstr
abstract PGF
pgf
   cs :: [(CId, Concr)]
cs = Map CId Concr -> [(CId, Concr)]
forall k a. Map k a -> [(k, a)]
Map.assocs (PGF -> Map CId Concr
concretes PGF
pgf)
   start :: String
start = CId -> String
showCId (CId -> String) -> CId -> String
forall a b. (a -> b) -> a -> b
$ PGF -> CId
M.lookStartCat PGF
pgf
   json_abstract :: JSValue
json_abstract = String -> String -> Abstr -> JSValue
abstract2json String
n String
start Abstr
as
   json_concretes :: JSValue
json_concretes = [(String, JSValue)] -> JSValue
JSON.makeObj ([(String, JSValue)] -> JSValue) -> [(String, JSValue)] -> JSValue
forall a b. (a -> b) -> a -> b
$ ((CId, Concr) -> (String, JSValue))
-> [(CId, Concr)] -> [(String, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map (CId, Concr) -> (String, JSValue)
concrete2json [(CId, Concr)]
cs

abstract2json :: String -> String -> Abstr -> JSValue
abstract2json :: String -> String -> Abstr -> JSValue
abstract2json String
name String
start Abstr
ds =
  [(String, JSValue)] -> JSValue
JSON.makeObj
    [ (String
"name", String -> JSValue
mkJSStr String
name)
    , (String
"startcat", String -> JSValue
mkJSStr String
start)
    , (String
"funs", [(String, JSValue)] -> JSValue
JSON.makeObj ([(String, JSValue)] -> JSValue) -> [(String, JSValue)] -> JSValue
forall a b. (a -> b) -> a -> b
$ ((CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))
 -> (String, JSValue))
-> [(CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))]
-> [(String, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map (CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> (String, JSValue)
absdef2json (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> [(CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))]
forall k a. Map k a -> [(k, a)]
Map.assocs (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
ds)))
    ]

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

lit2json :: Literal -> JSValue
lit2json :: Literal -> JSValue
lit2json (LStr String
s) = String -> JSValue
mkJSStr String
s
lit2json (LInt Int
n) = Int -> JSValue
forall a. Integral a => a -> JSValue
mkJSInt Int
n
lit2json (LFlt Double
d) = Bool -> Rational -> JSValue
JSRational Bool
True (Double -> Rational
forall a. Real a => a -> Rational
toRational Double
d)

concrete2json :: (CId,Concr) -> (String,JSValue)
concrete2json :: (CId, Concr) -> (String, JSValue)
concrete2json (CId
c,Concr
cnc) = (CId -> String
showCId CId
c,JSValue
obj)
  where
    obj :: JSValue
obj = [(String, JSValue)] -> JSValue
JSON.makeObj
      [ (String
"flags", [(String, JSValue)] -> JSValue
JSON.makeObj [ (CId -> String
showCId CId
k, Literal -> JSValue
lit2json Literal
v) | (CId
k,Literal
v) <- Map CId Literal -> [(CId, Literal)]
forall k a. Map k a -> [(k, a)]
Map.toList (Concr -> Map CId Literal
cflags Concr
cnc) ])
      , (String
"productions", [(String, JSValue)] -> JSValue
JSON.makeObj [ (Int -> String
forall a. Show a => a -> String
show Int
cat, [JSValue] -> JSValue
JSArray ((Production -> JSValue) -> [Production] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map Production -> JSValue
frule2json (Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
set))) | (Int
cat,Set Production
set) <- IntMap (Set Production) -> [(Int, Set Production)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (Concr -> IntMap (Set Production)
productions Concr
cnc)])
      , (String
"functions", [JSValue] -> JSValue
JSArray ((CncFun -> JSValue) -> [CncFun] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map CncFun -> JSValue
ffun2json (Array Int CncFun -> [CncFun]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems (Concr -> Array Int CncFun
cncfuns Concr
cnc))))
      , (String
"sequences", [JSValue] -> JSValue
JSArray ((Array Int Symbol -> JSValue) -> [Array Int Symbol] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map Array Int Symbol -> JSValue
seq2json (Array Int (Array Int Symbol) -> [Array Int Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems (Concr -> Array Int (Array Int Symbol)
sequences Concr
cnc))))
      , (String
"categories", [(String, JSValue)] -> JSValue
JSON.makeObj ([(String, JSValue)] -> JSValue) -> [(String, JSValue)] -> JSValue
forall a b. (a -> b) -> a -> b
$ ((CId, CncCat) -> (String, JSValue))
-> [(CId, CncCat)] -> [(String, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map (CId, CncCat) -> (String, JSValue)
cats2json (Map CId CncCat -> [(CId, CncCat)]
forall k a. Map k a -> [(k, a)]
Map.assocs (Concr -> Map CId CncCat
cnccats Concr
cnc)))
      , (String
"totalfids", Int -> JSValue
forall a. Integral a => a -> JSValue
mkJSInt (Concr -> Int
totalCats Concr
cnc))
      ]

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

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

farg2json :: PArg -> JSValue
farg2json :: PArg -> JSValue
farg2json (PArg [(Int, Int)]
hypos Int
fid) =
  [(String, JSValue)] -> JSValue
JSON.makeObj
    [ (String
"type", String -> JSValue
mkJSStr String
"PArg")
    , (String
"hypos", [JSValue] -> JSValue
JSArray ([JSValue] -> JSValue) -> [JSValue] -> JSValue
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> JSValue) -> [(Int, Int)] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> JSValue
forall a. Integral a => a -> JSValue
mkJSInt (Int -> JSValue) -> ((Int, Int) -> Int) -> (Int, Int) -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd) [(Int, Int)]
hypos)
    , (String
"fid", Int -> JSValue
forall a. Integral a => a -> JSValue
mkJSInt Int
fid)
    ]

ffun2json :: CncFun -> JSValue
ffun2json :: CncFun -> JSValue
ffun2json (CncFun CId
f UArray Int Int
lins) =
  [(String, JSValue)] -> JSValue
JSON.makeObj
    [ (String
"name", String -> JSValue
mkJSStr (String -> JSValue) -> String -> JSValue
forall a b. (a -> b) -> a -> b
$ CId -> String
showCId CId
f)
    , (String
"lins", [JSValue] -> JSValue
JSArray ((Int -> JSValue) -> [Int] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map Int -> JSValue
forall a. Integral a => a -> JSValue
mkJSInt (UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems UArray Int Int
lins)))
    ]

seq2json :: Array.Array DotPos Symbol -> JSValue
seq2json :: Array Int Symbol -> JSValue
seq2json Array Int Symbol
seq = [JSValue] -> JSValue
JSArray [Symbol -> JSValue
sym2json Symbol
s | Symbol
s <- Array Int Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems Array Int Symbol
seq]

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

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

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

-- | Make JSON value from string
mkJSStr :: String -> JSValue
mkJSStr :: String -> JSValue
mkJSStr = JSString -> JSValue
JSString (JSString -> JSValue) -> (String -> JSString) -> String -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSString
JSON.toJSString

-- | Make JSON value from integer
mkJSInt :: Integral a => a -> JSValue
mkJSInt :: a -> JSValue
mkJSInt = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (a -> Rational) -> a -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rational
forall a. Real a => a -> Rational
toRational