mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-15 15:59:32 -06:00
157 lines
4.4 KiB
Haskell
157 lines
4.4 KiB
Haskell
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
|