mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-17 16:59:34 -06:00
cannonical export now may contain some resource modules with parameters
This commit is contained in:
Krasimir Angelov
@@ -80,7 +80,7 @@ importPGF opts (Just pgf) f = fmap Just (modifyPGF pgf (mergePGF f) `catc
|
||||
else throwIO e))
|
||||
|
||||
importSource :: Options -> Maybe PGF -> [FilePath] -> IO (ModuleName,SourceGrammar)
|
||||
importSource opts mb_pgf files = fmap snd (batchCompile opts mb_pgf files)
|
||||
importSource opts mb_pgf files = batchCompile opts mb_pgf files
|
||||
|
||||
-- for different cf formats
|
||||
importCF opts files get convert = impCF
|
||||
|
||||
@@ -29,7 +29,7 @@ import PGF2(PGF,abstractName,pgfFilePath,readProbabilitiesFromFile)
|
||||
-- | Compiles a number of source files and builds a 'PGF' structure for them.
|
||||
-- This is a composition of 'link' and 'batchCompile'.
|
||||
compileToPGF :: Options -> Maybe PGF -> [FilePath] -> IOE PGF
|
||||
compileToPGF opts mb_pgf fs = link opts mb_pgf . snd =<< batchCompile opts mb_pgf fs
|
||||
compileToPGF opts mb_pgf fs = link opts mb_pgf =<< batchCompile opts mb_pgf fs
|
||||
|
||||
-- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
|
||||
-- 'PGF.parse' with the "PGF" run-time system.
|
||||
@@ -56,15 +56,12 @@ srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
|
||||
-- used, in which case tags files are produced instead).
|
||||
-- Existing @.gfo@ files are reused if they are up-to-date
|
||||
-- (unless the option @-src@ aka @-force-recomp@ is used).
|
||||
batchCompile :: Options -> Maybe PGF -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar))
|
||||
batchCompile :: Options -> Maybe PGF -> [FilePath] -> IOE (ModuleName,Grammar)
|
||||
batchCompile opts mb_pgf files = do
|
||||
menv <- emptyCompileEnv mb_pgf
|
||||
(gr,menv) <- foldM (compileModule opts) menv files
|
||||
let cnc = moduleNameS (justModuleName (last files))
|
||||
t = maximum . map snd3 $ Map.elems menv
|
||||
return (t,(cnc,gr))
|
||||
where
|
||||
snd3 (_,y,_) = y
|
||||
return (cnc,gr)
|
||||
|
||||
-- | compile with one module as starting point
|
||||
-- command-line options override options (marked by --#) in the file
|
||||
|
||||
@@ -1,18 +1,18 @@
|
||||
-- | Translate grammars to Canonical form
|
||||
-- (a common intermediate representation to simplify export to other formats)
|
||||
module GF.Compile.GrammarToCanonical(
|
||||
grammar2canonical,abstract2canonical,concretes2canonical,
|
||||
grammar2canonical
|
||||
) where
|
||||
|
||||
import GF.Data.ErrM
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
|
||||
import GF.Infra.Option(Options,noOptions)
|
||||
import GF.Infra.CheckM
|
||||
import GF.Compile.Compute.Concrete2
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Maybe(mapMaybe)
|
||||
import Data.Maybe(mapMaybe,fromMaybe)
|
||||
import Control.Monad (forM)
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax and all associated
|
||||
@@ -43,33 +43,62 @@ abstract2canonical absname gr = do
|
||||
-- | Generate Canonical code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2canonical :: Options -> ModuleName -> Grammar -> Check [Module]
|
||||
concretes2canonical opts absname gr =
|
||||
sequence
|
||||
[concrete2canonical gr absname cnc modinfo
|
||||
| cnc<-allConcretes gr absname,
|
||||
let Ok modinfo = lookupModule gr cnc
|
||||
]
|
||||
concretes2canonical opts absname gr = do
|
||||
res <- sequence
|
||||
[concrete2canonical gr absname cnc modinfo
|
||||
| cnc<-allConcretes gr absname,
|
||||
let Ok modinfo = lookupModule gr cnc]
|
||||
let pts = Set.unions (map fst res)
|
||||
ms <- closure pts (Set.toList pts) (Map.fromList (map snd res))
|
||||
return (Map.toList ms)
|
||||
where
|
||||
closure pts [] ms = return ms
|
||||
closure pts (q@(m,id):qs) ms = do
|
||||
(_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q
|
||||
let pts' = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx]
|
||||
new_pts = Set.difference pts' pts
|
||||
closure (Set.union new_pts pts) (Set.toList new_pts++qs) (insert q info ms)
|
||||
|
||||
insert (m,id) info ms =
|
||||
let mi0 = fromMaybe emptyRes (Map.lookup m ms)
|
||||
mi = mi0{jments=Map.insert id info (jments mi0)}
|
||||
in Map.insert m mi ms
|
||||
|
||||
emptyRes =
|
||||
ModInfo {
|
||||
mtype = MTResource,
|
||||
mstatus = MSComplete,
|
||||
mflags = noOptions,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.empty
|
||||
}
|
||||
|
||||
type QSet = Set.Set (ModuleName,Ident)
|
||||
|
||||
-- | Generate Canonical GF for the given concrete module.
|
||||
concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Module
|
||||
concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check (QSet,Module)
|
||||
concrete2canonical gr absname cncname modinfo = do
|
||||
let g = Gl gr (stdPredef g)
|
||||
infos <- mapM (convInfo g) (allOrigInfos gr cncname)
|
||||
let pts = Set.unions (map fst infos)
|
||||
pts <- closure pts (Set.toList pts)
|
||||
return (cncname, ModInfo {
|
||||
mtype = MTConcrete absname,
|
||||
mstatus = MSComplete,
|
||||
mflags = convFlags gr cncname,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.union (Map.fromList (mapMaybe snd infos))
|
||||
pts
|
||||
})
|
||||
return (pts,
|
||||
(cncname, ModInfo {
|
||||
mtype = MTConcrete absname,
|
||||
mstatus = MSComplete,
|
||||
mflags = convFlags gr cncname,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.fromList (mapMaybe snd infos)
|
||||
}))
|
||||
where
|
||||
convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
|
||||
typ <- normalForm g typ
|
||||
@@ -84,22 +113,16 @@ concrete2canonical gr absname cncname modinfo = do
|
||||
eta_expand t ((Implicit,x,_):ctx) = Abs Implicit x (eta_expand (App t (ImplArg (Vr x))) ctx)
|
||||
eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x)) ctx)
|
||||
|
||||
paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
|
||||
paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
|
||||
paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
|
||||
paramTypes (Sort _) = Set.empty
|
||||
paramTypes (EInt _) = Set.empty
|
||||
paramTypes (QC q) = Set.singleton q
|
||||
paramTypes (FV ts) = Set.unions (map paramTypes ts)
|
||||
paramTypes _ = Set.empty
|
||||
|
||||
closure pts [] = return Map.empty
|
||||
closure pts (q@(_,id):qs) = do
|
||||
(_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q
|
||||
let pts' = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx]
|
||||
new_pts = Set.difference pts' pts
|
||||
infos <- closure (Set.union new_pts pts) (Set.toList new_pts++qs)
|
||||
return (Map.insert id info infos)
|
||||
paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
|
||||
paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
|
||||
paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
|
||||
paramTypes (Sort _) = Set.empty
|
||||
paramTypes (EInt _) = Set.empty
|
||||
paramTypes (QC q) = Set.singleton q
|
||||
paramTypes (FV ts) = Set.unions (map paramTypes ts)
|
||||
paramTypes _ = Set.empty
|
||||
|
||||
|
||||
convFlags :: Grammar -> ModuleName -> Options
|
||||
convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn)
|
||||
|
||||
@@ -296,7 +296,7 @@ runRepl opts@ReplOpts { noPrelude, inputFiles } = do
|
||||
(g0, opens) <- case toLoad of
|
||||
[] -> pure (mGrammar [], [])
|
||||
_ -> do
|
||||
(_, (_, g0)) <- batchCompile noOptions Nothing toLoad
|
||||
(_, g0) <- batchCompile noOptions Nothing toLoad
|
||||
pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad)
|
||||
let
|
||||
modInfo = ModInfo
|
||||
|
||||
@@ -11,6 +11,7 @@ import GF.Compile.CFGtoPGF
|
||||
import GF.Compile.GetGrammar
|
||||
import GF.Grammar.BNFC
|
||||
import GF.Grammar.CFG
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.JSON(grammar2json)
|
||||
import GF.Grammar.Printer(TermPrintQual(..),ppModule)
|
||||
|
||||
@@ -50,46 +51,30 @@ mainGFC opts fs = do
|
||||
|
||||
compileSourceFiles :: Options -> [FilePath] -> IOE ()
|
||||
compileSourceFiles opts fs =
|
||||
do output <- batchCompile opts fs
|
||||
exportCanonical output
|
||||
unless (flag optStopAfterPhase opts == Compile) $
|
||||
linkGrammars opts output
|
||||
do cnc_gr@(cnc,gr) <- S.batchCompile opts Nothing fs
|
||||
let absname = srcAbsName gr cnc
|
||||
exportCanonical absname gr
|
||||
unless (flag optStopAfterPhase opts == Compile) $ do
|
||||
let pgfFile = outputPath opts (grammarName' opts (render absname)<.>"pgf")
|
||||
pgf <- link opts Nothing cnc_gr
|
||||
writeGrammar opts pgf
|
||||
writeOutputs opts pgf
|
||||
where
|
||||
batchCompile = maybe batchCompile' parallelBatchCompile (flag optJobs opts)
|
||||
batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts Nothing fs
|
||||
return (t,[cnc_gr])
|
||||
|
||||
exportCanonical (_time, canonical) =
|
||||
do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
|
||||
mapM_ cnc2haskell canonical
|
||||
exportCanonical absname gr =
|
||||
do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $ do
|
||||
(res,_) <- runCheck (concretes2haskell opts absname gr)
|
||||
mapM_ writeExport res
|
||||
when (FmtCanonicalGF `elem` ofmts) $
|
||||
do createDirectoryIfMissing False "canonical"
|
||||
mapM_ abs2canonical canonical
|
||||
mapM_ cnc2canonical canonical
|
||||
when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2canonical_json canonical
|
||||
(gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
|
||||
forM_ (modules gr_canon) $ \m@(mn,_) -> do
|
||||
writeExport ("canonical/"++render mn++".gf",render80 (ppModule Unqualified m))
|
||||
when (FmtCanonicalJson `elem` ofmts) $
|
||||
do (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
|
||||
writeExport (render absname ++ ".json", encode (grammar2json gr_canon))
|
||||
where
|
||||
ofmts = flag optOutputFormats opts
|
||||
|
||||
cnc2haskell (cnc,gr) = do
|
||||
(res,_) <- runCheck (concretes2haskell opts (srcAbsName gr cnc) gr)
|
||||
mapM_ writeExport res
|
||||
|
||||
abs2canonical (cnc,gr) = do
|
||||
(canAbs,_) <- runCheck (abstract2canonical absname gr)
|
||||
writeExport ("canonical/"++render absname++".gf",render80 (ppModule Unqualified canAbs))
|
||||
where
|
||||
absname = srcAbsName gr cnc
|
||||
|
||||
cnc2canonical (cnc,gr) = do
|
||||
(res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
|
||||
sequence_ [writeExport ("canonical/"++render mn++".gf",render80 (ppModule Unqualified m)) | m@(mn,mi) <- res]
|
||||
|
||||
grammar2canonical_json (cnc,gr) = do
|
||||
(gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
|
||||
writeExport (render absname ++ ".json", encode (grammar2json Unqualified gr_canon))
|
||||
where
|
||||
absname = srcAbsName gr cnc
|
||||
|
||||
writeExport (path,s) = writing opts path $ writeUTF8File path s
|
||||
|
||||
|
||||
@@ -98,8 +83,7 @@ compileSourceFiles opts fs =
|
||||
-- If a @.pgf@ file by the same name already exists and it is newer than the
|
||||
-- source grammar files (as indicated by the 'UTCTime' argument), it is not
|
||||
-- recreated. Calls 'writeGrammar' and 'writeOutputs'.
|
||||
linkGrammars opts (t_src,[]) = return ()
|
||||
linkGrammars opts (t_src,cnc_gr@(cnc,gr):cnc_grs) =
|
||||
linkGrammars opts (t_src,cnc_gr@(cnc,gr)) =
|
||||
do let abs = render (srcAbsName gr cnc)
|
||||
pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
|
||||
t_pgf <- if outputJustPGF opts
|
||||
@@ -108,7 +92,6 @@ linkGrammars opts (t_src,cnc_gr@(cnc,gr):cnc_grs) =
|
||||
if t_pgf >= Just t_src
|
||||
then putIfVerb opts $ pgfFile ++ " is up-to-date."
|
||||
else do pgf <- link opts Nothing cnc_gr
|
||||
pgf <- foldM (link opts . Just) pgf cnc_grs
|
||||
writeGrammar opts pgf
|
||||
writeOutputs opts pgf
|
||||
|
||||
|
||||
@@ -14,127 +14,131 @@ import Control.Applicative ((<|>))
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (catMaybes)
|
||||
|
||||
grammar2json :: TermPrintQual -> Grammar -> JSValue
|
||||
grammar2json q gr =
|
||||
makeObj [(showIdent mn, mi2json q mi) | (MN mn,mi) <- modules gr]
|
||||
grammar2json :: Grammar -> JSValue
|
||||
grammar2json gr =
|
||||
makeObj [(showIdent mn, mi2json mi) | (MN mn,mi) <- modules gr]
|
||||
|
||||
mi2json q mi = makeObj [("jments",makeObj (map (jment2json q) (Map.toList (jments mi))))]
|
||||
mi2json mi = makeObj [("type", mtype2json (mtype mi))
|
||||
,("jments",makeObj (map jment2json (Map.toList (jments mi))))
|
||||
]
|
||||
|
||||
jment2json q (id,info) = (showIdent id, info2json q info)
|
||||
mtype2json MTAbstract = showJSON "abstract"
|
||||
mtype2json MTResource = showJSON "resource"
|
||||
mtype2json (MTConcrete _) = showJSON "concrete"
|
||||
mtype2json MTInterface = showJSON "interface"
|
||||
mtype2json (MTInstance _) = showJSON "instance"
|
||||
|
||||
info2json q (AbsCat mb_ctxt) =
|
||||
jment2json (id,info) = (showIdent id, info2json info)
|
||||
|
||||
info2json (AbsCat mb_ctxt) =
|
||||
case mb_ctxt of
|
||||
Nothing -> makeObj []
|
||||
Just (L _ ctxt) -> makeObj [("context", showJSON (map (hypo2json q) ctxt))]
|
||||
info2json q (AbsFun mb_ty mb_arity mb_eqs _) =
|
||||
Just (L _ ctxt) -> makeObj [("context", showJSON (map hypo2json ctxt))]
|
||||
info2json (AbsFun mb_ty mb_arity mb_eqs _) =
|
||||
(makeObj . catMaybes)
|
||||
[ fmap (\(L _ ty) -> ("abstype",term2json q ty)) mb_ty
|
||||
[ fmap (\(L _ ty) -> ("abstype",term2json ty)) mb_ty
|
||||
, fmap (\a -> ("arity",showJSON a)) mb_arity
|
||||
, fmap (\eqs -> ("equations",showJSON (map (\(L _ eq) -> equation2json q eq) eqs))) mb_eqs
|
||||
, fmap (\eqs -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
|
||||
]
|
||||
info2json q (ResParam mb_params _) =
|
||||
info2json (ResParam mb_params _) =
|
||||
makeObj [("params", case mb_params of
|
||||
Nothing -> JSArray []
|
||||
Just (L _ params) -> showJSON (map (param2json q) params))]
|
||||
info2json q (ResValue (L _ ty) _) =
|
||||
makeObj [("paramtype",term2json q ty)]
|
||||
info2json q (ResOper mb_ty mb_def) =
|
||||
Just (L _ params) -> showJSON (map param2json params))]
|
||||
info2json (ResValue (L _ ty) _) =
|
||||
makeObj [("paramtype",term2json ty)]
|
||||
info2json (ResOper mb_ty mb_def) =
|
||||
(makeObj . catMaybes)
|
||||
[ fmap (\(L _ ty) -> ("opertype",term2json q ty)) mb_ty
|
||||
, fmap (\(L _ def) -> ("operdef",term2json q def)) mb_def
|
||||
[ fmap (\(L _ ty) -> ("opertype",term2json ty)) mb_ty
|
||||
, fmap (\(L _ def) -> ("operdef",term2json def)) mb_def
|
||||
]
|
||||
info2json q (ResOverload mns overloads) =
|
||||
info2json (ResOverload mns overloads) =
|
||||
makeObj
|
||||
[ ("extends",showJSON mns)
|
||||
, ("overloads",showJSON (map (overload2json q) overloads))
|
||||
, ("overloads",showJSON (map overload2json overloads))
|
||||
]
|
||||
info2json q (CncCat mb_ty mb_lindef mb_linref mb_pnm _) =
|
||||
info2json (CncCat mb_ty mb_lindef mb_linref mb_pnm _) =
|
||||
(makeObj . catMaybes)
|
||||
[ fmap (\(L _ ty) -> ("lintype",term2json q ty)) mb_ty
|
||||
, fmap (\(L _ def) -> ("lindef",term2json q def)) mb_lindef
|
||||
, fmap (\(L _ ref) -> ("linref",term2json q ref)) mb_linref
|
||||
, fmap (\(L _ prn) -> ("printname",term2json q prn)) mb_pnm
|
||||
[ fmap (\(L _ ty) -> ("lintype",term2json ty)) mb_ty
|
||||
, fmap (\(L _ def) -> ("lindef",term2json def)) mb_lindef
|
||||
, fmap (\(L _ ref) -> ("linref",term2json ref)) mb_linref
|
||||
, fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
|
||||
]
|
||||
info2json q (CncFun _ mb_lin mb_pnm _) =
|
||||
info2json (CncFun _ mb_lin mb_pnm _) =
|
||||
(makeObj . catMaybes)
|
||||
[ fmap (\(L _ lin) -> ("lin",term2json q lin)) mb_lin
|
||||
, fmap (\(L _ prn) -> ("printname",term2json q prn)) mb_pnm
|
||||
[ fmap (\(L _ lin) -> ("lin",term2json lin)) mb_lin
|
||||
, fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
|
||||
]
|
||||
info2json q (AnyInd _ mn) = showJSON mn
|
||||
info2json (AnyInd _ mn) = showJSON mn
|
||||
|
||||
hypo2json q (bt,x,ty) =
|
||||
makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("type", term2json q ty)]
|
||||
hypo2json (bt,x,ty) =
|
||||
makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("type", term2json ty)]
|
||||
|
||||
equation2json q (ps,t) =
|
||||
makeObj [("patts", showJSON (map (patt2json q) ps)), ("term", term2json q t)]
|
||||
equation2json (ps,t) =
|
||||
makeObj [("patts", showJSON (map patt2json ps)), ("term", term2json t)]
|
||||
|
||||
param2json q (id, ctxt) =
|
||||
makeObj [("id", showJSON id), ("context", showJSON (map (hypo2json q) ctxt))]
|
||||
param2json (id, ctxt) =
|
||||
makeObj [("id", showJSON id), ("context", showJSON (map hypo2json ctxt))]
|
||||
|
||||
overload2json q (L _ ty,L _ def) =
|
||||
overload2json (L _ ty,L _ def) =
|
||||
makeObj
|
||||
[ ("opertype",term2json q ty)
|
||||
, ("operdef",term2json q def)
|
||||
[ ("opertype",term2json ty)
|
||||
, ("operdef",term2json def)
|
||||
]
|
||||
|
||||
term2json :: TermPrintQual -> Term -> JSValue
|
||||
term2json q (Vr v) = makeObj [("vr", showJSON v)]
|
||||
term2json q (Cn v) = makeObj [("cn", showJSON v)]
|
||||
term2json q (Con v) = makeObj [("con", showJSON v)]
|
||||
term2json q (Sort v) = makeObj [("sort", showJSON v)]
|
||||
term2json q (EInt n) = showJSON n
|
||||
term2json q (EFloat f) = showJSON f
|
||||
term2json q (K s) = showJSON s
|
||||
term2json q Empty = JSArray []
|
||||
term2json q (App t1 t2) = makeObj [("fun", term2json q t1), ("arg", term2json q t2)]
|
||||
term2json q (Abs bt x t) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("body", term2json q t)]
|
||||
term2json q (Meta id) = makeObj [("metaid", showJSON id)]
|
||||
term2json q (ImplArg t) = makeObj [("implarg", term2json q t)]
|
||||
term2json q (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON v), ("hypo", term2json q t1), ("res", term2json q t2)]
|
||||
term2json q (Typed t ty) = makeObj [("term", term2json q t), ("type", term2json q ty)]
|
||||
term2json q (Example t s) = makeObj [("term", term2json q t), ("example", showJSON s)]
|
||||
term2json q (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
|
||||
where toRow (l,t) = (showLabel l, term2json q t)
|
||||
term2json q (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
|
||||
where toRow (l,(_,t)) = (showLabel l, term2json q t)
|
||||
term2json q (P t proj) = makeObj [("project", term2json q t), ("label", showJSON (showLabel proj))]
|
||||
term2json q (ExtR t1 t2) = makeObj [("term", term2json q t1), ("ext", term2json q t2)]
|
||||
term2json q (Table t1 t2) = makeObj [("tblhypo", term2json q t1), ("tblres", term2json q t2)]
|
||||
term2json q (T _ cs) = makeObj [("tblcases", showJSON [(patt2json q p, term2json q t) | (p,t) <- cs])]
|
||||
term2json q (V ty ts) = makeObj [("tbltype", term2json q ty), ("tblvalues", showJSON (map (term2json q) ts))]
|
||||
term2json q (S t1 t2) = makeObj [("select", term2json q t1), ("key", term2json q t2)]
|
||||
term2json q (Let (v,(_,t1)) t2) = makeObj [("letvar", showJSON v), ("letdef", term2json q t1), ("term", term2json q t2)]
|
||||
term2json q (Q (m,id)) = case q of
|
||||
Qualified -> makeObj [("mod",showJSON m),("q", showJSON id)]
|
||||
_ -> makeObj [("cn", showJSON id)]
|
||||
term2json q (QC (m,id)) = case q of
|
||||
Qualified -> makeObj [("mod",showJSON m),("qc", showJSON id)]
|
||||
_ -> makeObj [("con", showJSON id)]
|
||||
term2json q (C t1 t2) = showJSON ((flatten t1 . flatten t2) [])
|
||||
term2json :: Term -> JSValue
|
||||
term2json (Vr v) = makeObj [("vr", showJSON v)]
|
||||
term2json (Cn v) = makeObj [("cn", showJSON v)]
|
||||
term2json (Con v) = makeObj [("con", showJSON v)]
|
||||
term2json (Sort v) = makeObj [("sort", showJSON v)]
|
||||
term2json (EInt n) = showJSON n
|
||||
term2json (EFloat f) = showJSON f
|
||||
term2json (K s) = showJSON s
|
||||
term2json Empty = JSArray []
|
||||
term2json (App t1 t2) = makeObj [("fun", term2json t1), ("arg", term2json t2)]
|
||||
term2json (Abs bt x t) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("body", term2json t)]
|
||||
term2json (Meta id) = makeObj [("metaid", showJSON id)]
|
||||
term2json (ImplArg t) = makeObj [("implarg", term2json t)]
|
||||
term2json (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON v), ("hypo", term2json t1), ("res", term2json t2)]
|
||||
term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)]
|
||||
term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)]
|
||||
term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
|
||||
where toRow (l,t) = (showLabel l, term2json t)
|
||||
term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
|
||||
where toRow (l,(_,t)) = (showLabel l, term2json t)
|
||||
term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))]
|
||||
term2json (ExtR t1 t2) = makeObj [("term", term2json t1), ("ext", term2json t2)]
|
||||
term2json (Table t1 t2) = makeObj [("tblhypo", term2json t1), ("tblres", term2json t2)]
|
||||
term2json (T _ cs) = makeObj [("tblcases", showJSON [(patt2json p, term2json t) | (p,t) <- cs])]
|
||||
term2json (V ty ts) = makeObj [("tbltype", term2json ty), ("tblvalues", showJSON (map term2json ts))]
|
||||
term2json (S t1 t2) = makeObj [("select", term2json t1), ("key", term2json t2)]
|
||||
term2json (Let (v,(_,t1)) t2) = makeObj [("letvar", showJSON v), ("letdef", term2json t1), ("term", term2json t2)]
|
||||
term2json (Q (m,id)) = makeObj [("mod",showJSON m),("q", showJSON id)]
|
||||
term2json (QC (m,id)) = makeObj [("mod",showJSON m),("qc", showJSON id)]
|
||||
term2json (C t1 t2) = showJSON ((flatten t1 . flatten t2) [])
|
||||
where
|
||||
flatten Empty = id
|
||||
flatten (C t1 t2) = flatten t1 . flatten t2
|
||||
flatten t = (term2json q t :)
|
||||
term2json q (Glue t1 t2) = makeObj [("glue1",term2json q t1),("glue2", term2json q t2)]
|
||||
term2json q (EPattType t) = makeObj [("patttype",term2json q t)]
|
||||
term2json q (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json q t)]
|
||||
term2json q (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json q t)]
|
||||
term2json q (AdHocOverload ts) = makeObj [("overloaded",showJSON (map (term2json q) ts))]
|
||||
term2json q (FV ts) = makeObj [("variants",showJSON (map (term2json q) ts))]
|
||||
term2json q (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
|
||||
, ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json q val)) attrs))
|
||||
, ("children",showJSON (map (term2json q) children))
|
||||
]
|
||||
term2json q (Reset ctl t) =
|
||||
flatten t = (term2json t :)
|
||||
term2json (Glue t1 t2) = makeObj [("glue1",term2json t1),("glue2", term2json t2)]
|
||||
term2json (EPattType t) = makeObj [("patttype",term2json t)]
|
||||
term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json t)]
|
||||
term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
|
||||
term2json (AdHocOverload ts) = makeObj [("overloaded",showJSON (map term2json ts))]
|
||||
term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
|
||||
term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
|
||||
, ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
|
||||
, ("children",showJSON (map term2json children))
|
||||
]
|
||||
term2json (Reset ctl t) =
|
||||
let jctl = case ctl of
|
||||
All -> showJSON "all"
|
||||
One -> showJSON "one"
|
||||
Limit n -> showJSON n
|
||||
Coordination Nothing conj cat -> makeObj [("conj",showJSON conj), ("cat",showJSON cat)]
|
||||
Coordination (Just mod) conj cat -> makeObj [("mod",showJSON mod), ("conj",showJSON conj), ("cat",showJSON cat)]
|
||||
in makeObj [("reset",jctl), ("term",term2json q t)]
|
||||
term2json q (Alts def alts) = makeObj [("def",term2json q def), ("alts",showJSON (map (\(t1,t2) -> (term2json q t1, term2json q t2)) alts))]
|
||||
term2json q (Strs ts) = makeObj [("strs",showJSON (map (term2json q) ts))]
|
||||
in makeObj [("reset",jctl), ("term",term2json t)]
|
||||
term2json (Alts def alts) = makeObj [("def",term2json def), ("alts",showJSON (map (\(t1,t2) -> (term2json t1, term2json t2)) alts))]
|
||||
term2json (Strs ts) = makeObj [("strs",showJSON (map term2json ts))]
|
||||
|
||||
json2term o = Vr <$> o!:"vr"
|
||||
<|> curry Q <$> o!:"mod" <*> o!:"cn"
|
||||
@@ -207,40 +211,37 @@ json2term o = Vr <$> o!:"vr"
|
||||
json2ctl _ = fail "Invalid control value for reset"
|
||||
|
||||
|
||||
patt2json q (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map (patt2json q) ps))]
|
||||
patt2json q (PP (mn,id) ps) =
|
||||
case q of
|
||||
Qualified -> makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map (patt2json q) ps))]
|
||||
_ -> makeObj [ ("pc",showJSON id),("args",showJSON (map (patt2json q) ps))]
|
||||
patt2json q (PV id) = makeObj [("pv",showJSON id)]
|
||||
patt2json q PW = makeObj [("wildcard",showJSON True)]
|
||||
patt2json q (PR lbls) = makeObj (("record", showJSON True) : map toRow lbls)
|
||||
where toRow (l,t) = (showLabel l, patt2json q t)
|
||||
patt2json q (PString s) = showJSON s
|
||||
patt2json q (PInt n) = showJSON n
|
||||
patt2json q (PFloat d) = showJSON d
|
||||
patt2json q (PT ty p) = makeObj [("type", term2json q ty), ("patt", patt2json q p)]
|
||||
patt2json q (PAs id p) = makeObj [("as", showJSON id), ("patt", patt2json q p)]
|
||||
patt2json q (PImplArg p) = makeObj [("implarg", patt2json q p)]
|
||||
patt2json q (PTilde t) = makeObj [("tilde", term2json q t)]
|
||||
patt2json q (PNeg p) = makeObj [("neg", patt2json q p)]
|
||||
patt2json q (PAlt p1 p2) = makeObj [("alt1", patt2json q p1), ("alt2", patt2json q p2)]
|
||||
patt2json q (PSeq min1 max1 p1 min2 max2 p2)
|
||||
patt2json (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
|
||||
patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
|
||||
patt2json (PV id) = makeObj [("pv",showJSON id)]
|
||||
patt2json PW = makeObj [("wildcard",showJSON True)]
|
||||
patt2json (PR lbls) = makeObj (("record", showJSON True) : map toRow lbls)
|
||||
where toRow (l,t) = (showLabel l, patt2json t)
|
||||
patt2json (PString s) = showJSON s
|
||||
patt2json (PInt n) = showJSON n
|
||||
patt2json (PFloat d) = showJSON d
|
||||
patt2json (PT ty p) = makeObj [("type", term2json ty), ("patt", patt2json p)]
|
||||
patt2json (PAs id p) = makeObj [("as", showJSON id), ("patt", patt2json p)]
|
||||
patt2json (PImplArg p) = makeObj [("implarg", patt2json p)]
|
||||
patt2json (PTilde t) = makeObj [("tilde", term2json t)]
|
||||
patt2json (PNeg p) = makeObj [("neg", patt2json p)]
|
||||
patt2json (PAlt p1 p2) = makeObj [("alt1", patt2json p1), ("alt2", patt2json p2)]
|
||||
patt2json (PSeq min1 max1 p1 min2 max2 p2)
|
||||
= makeObj [("min1", showJSON min1)
|
||||
,("max1", showJSON max1)
|
||||
,("patt1", patt2json q p1)
|
||||
,("patt1", patt2json p1)
|
||||
,("min2", showJSON min2)
|
||||
,("max2", showJSON max2)
|
||||
,("patt2", patt2json q p2)
|
||||
,("patt2", patt2json p2)
|
||||
]
|
||||
patt2json q (PRep min max p)=makeObj [("min", showJSON min)
|
||||
,("max", showJSON max)
|
||||
,("patt", patt2json q p)
|
||||
]
|
||||
patt2json q PChar = makeObj [("char",showJSON True)]
|
||||
patt2json q (PChars cs) = makeObj [("chars",showJSON cs)]
|
||||
patt2json q (PMacro id) = makeObj [("macro",showJSON id)]
|
||||
patt2json q (PM (mn,id)) = makeObj [("mod",showJSON mn), ("macro",showJSON id)]
|
||||
patt2json (PRep min max p)=makeObj [("min", showJSON min)
|
||||
,("max", showJSON max)
|
||||
,("patt", patt2json p)
|
||||
]
|
||||
patt2json PChar = makeObj [("char",showJSON True)]
|
||||
patt2json (PChars cs) = makeObj [("chars",showJSON cs)]
|
||||
patt2json (PMacro id) = makeObj [("macro",showJSON id)]
|
||||
patt2json (PM (mn,id)) = makeObj [("mod",showJSON mn), ("macro",showJSON id)]
|
||||
|
||||
json2patt :: JSValue -> Result Patt
|
||||
json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt)
|
||||
|
||||
Reference in New Issue
Block a user