mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-20 10:19:32 -06:00
111 lines
3.5 KiB
Haskell
111 lines
3.5 KiB
Haskell
module GF.Compile.PGFtoJSON (pgf2json) where
|
|
|
|
import PGF2
|
|
import PGF2.Internal
|
|
import Text.JSON
|
|
import qualified Data.Map as Map
|
|
|
|
pgf2json :: PGF -> String
|
|
pgf2json pgf =
|
|
encode $ makeObj
|
|
[ ("abstract", abstract2json pgf)
|
|
, ("concretes", makeObj $ map concrete2json
|
|
(Map.toList (languages pgf)))
|
|
]
|
|
|
|
abstract2json :: PGF -> JSValue
|
|
abstract2json pgf =
|
|
makeObj
|
|
[ ("name", showJSON (abstractName pgf))
|
|
, ("startcat", showJSON (showType [] (startCat pgf)))
|
|
, ("funs", makeObj $ map (absdef2json pgf) (functions pgf))
|
|
]
|
|
|
|
absdef2json :: PGF -> Fun -> (String,JSValue)
|
|
absdef2json pgf f = (f,sig)
|
|
where
|
|
Just (hypos,cat,_) = fmap unType (functionType pgf f)
|
|
sig = makeObj
|
|
[ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
|
|
, ("cat", showJSON cat)
|
|
]
|
|
|
|
lit2json :: Literal -> JSValue
|
|
lit2json (LStr s) = showJSON s
|
|
lit2json (LInt n) = showJSON n
|
|
lit2json (LFlt d) = showJSON d
|
|
|
|
concrete2json :: (ConcName,Concr) -> (String,JSValue)
|
|
concrete2json (c,cnc) = (c,obj)
|
|
where
|
|
obj = makeObj
|
|
[ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc])
|
|
, ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]])
|
|
, ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]])
|
|
, ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]])
|
|
, ("categories", makeObj $ map cat2json (concrCategories cnc))
|
|
, ("totalfids", showJSON (concrTotalCats cnc))
|
|
]
|
|
|
|
cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
|
|
cat2json (cat,start,end,_) = (cat, ixs)
|
|
where
|
|
ixs = makeObj
|
|
[ ("start", showJSON start)
|
|
, ("end", showJSON end)
|
|
]
|
|
|
|
frule2json :: Production -> JSValue
|
|
frule2json (PApply fid args) =
|
|
makeObj
|
|
[ ("type", showJSON "Apply")
|
|
, ("fid", showJSON fid)
|
|
, ("args", showJSON (map farg2json args))
|
|
]
|
|
frule2json (PCoerce arg) =
|
|
makeObj
|
|
[ ("type", showJSON "Coerce")
|
|
, ("arg", showJSON arg)
|
|
]
|
|
|
|
farg2json :: PArg -> JSValue
|
|
farg2json (PArg hypos fid) =
|
|
makeObj
|
|
[ ("type", showJSON "PArg")
|
|
, ("hypos", JSArray $ map (showJSON . snd) hypos)
|
|
, ("fid", showJSON fid)
|
|
]
|
|
|
|
ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
|
|
ffun2json funid (fun,seqids) =
|
|
makeObj
|
|
[ ("name", showJSON fun)
|
|
, ("lins", showJSON seqids)
|
|
]
|
|
|
|
seq2json :: SeqId -> [Symbol] -> JSValue
|
|
seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
|
|
|
|
sym2json :: Symbol -> JSValue
|
|
sym2json (SymCat n l) = new "SymCat" [showJSON n, showJSON l]
|
|
sym2json (SymLit n l) = new "SymLit" [showJSON n, showJSON l]
|
|
sym2json (SymVar n l) = new "SymVar" [showJSON n, showJSON l]
|
|
sym2json (SymKS t) = new "SymKS" [showJSON t]
|
|
sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)]
|
|
sym2json SymBIND = new "SymKS" [showJSON "&+"]
|
|
sym2json SymSOFT_BIND = new "SymKS" [showJSON "&+"]
|
|
sym2json SymSOFT_SPACE = new "SymKS" [showJSON "&+"]
|
|
sym2json SymCAPIT = new "SymKS" [showJSON "&|"]
|
|
sym2json SymALL_CAPIT = new "SymKS" [showJSON "&|"]
|
|
sym2json SymNE = new "SymNE" []
|
|
|
|
alt2json :: ([Symbol],[String]) -> JSValue
|
|
alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
|
|
|
|
new :: String -> [JSValue] -> JSValue
|
|
new f xs =
|
|
makeObj
|
|
[ ("type", showJSON f)
|
|
, ("args", showJSON xs)
|
|
]
|