module GF.Compile.PGFtoJSON (pgf2json) where

import PGF(showCId)
import PGF.Internal as M

import qualified Text.JSON as JSON
import Text.JSON (JSValue(..), JSON)
-- import Text.JSON.Pretty (pp_value)
-- import Text.PrettyPrint (render)

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
  -- render $ pp_value $ 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)]) -- TODO
      , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
      , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
      , ("startCats", 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.encJSDict
      [ ("s", start)
      , ("e", 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