GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 09:32:53 -06:00
Code Issues Packages Projects Releases Wiki Activity

cannonical export now may contain some resource modules with parameters

Browse Source
This commit is contained in:
Krasimir Angelov
2025-04-11 10:47:43 +02:00
parent aa3a03e7af
commit c2d64efe68
6 changed files with 203 additions and 199 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/api/GF/Command/Importing.hs
View File

@@ -80,7 +80,7 @@ importPGF opts (Just pgf) f = fmap Just (modifyPGF pgf (mergePGF f) `catc
else throwIO e)) else throwIO e))
importSource :: Options -> Maybe PGF -> [FilePath] -> IO (ModuleName,SourceGrammar) 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 -- for different cf formats
importCF opts files get convert = impCF importCF opts files get convert = impCF

9
src/compiler/api/GF/Compile.hs
View File

@@ -29,7 +29,7 @@ import PGF2(PGF,abstractName,pgfFilePath,readProbabilitiesFromFile)
-- | Compiles a number of source files and builds a 'PGF' structure for them. -- | Compiles a number of source files and builds a 'PGF' structure for them.
-- This is a composition of 'link' and 'batchCompile'. -- This is a composition of 'link' and 'batchCompile'.
compileToPGF :: Options -> Maybe PGF -> [FilePath] -> IOE PGF 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 -- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
-- 'PGF.parse' with the "PGF" run-time system. -- '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). -- used, in which case tags files are produced instead).
-- Existing @.gfo@ files are reused if they are up-to-date -- Existing @.gfo@ files are reused if they are up-to-date
-- (unless the option @-src@ aka @-force-recomp@ is used). -- (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 batchCompile opts mb_pgf files = do
menv <- emptyCompileEnv mb_pgf menv <- emptyCompileEnv mb_pgf
(gr,menv) <- foldM (compileModule opts) menv files (gr,menv) <- foldM (compileModule opts) menv files
let cnc = moduleNameS (justModuleName (last files)) let cnc = moduleNameS (justModuleName (last files))
t = maximum . map snd3 $ Map.elems menv return (cnc,gr)
return (t,(cnc,gr))
where
snd3 (_,y,_) = y
-- | compile with one module as starting point -- | compile with one module as starting point
-- command-line options override options (marked by --#) in the file -- command-line options override options (marked by --#) in the file

79
src/compiler/api/GF/Compile/GrammarToCanonical.hs
View File

@@ -1,18 +1,18 @@
-- | Translate grammars to Canonical form -- | Translate grammars to Canonical form
-- (a common intermediate representation to simplify export to other formats) -- (a common intermediate representation to simplify export to other formats)
module GF.Compile.GrammarToCanonical( module GF.Compile.GrammarToCanonical(
grammar2canonical,abstract2canonical,concretes2canonical, grammar2canonical
) where ) where
import GF.Data.ErrM import GF.Data.ErrM
import GF.Grammar.Grammar import GF.Grammar
import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo) import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
import GF.Infra.Option(Options,noOptions) import GF.Infra.Option(Options,noOptions)
import GF.Infra.CheckM import GF.Infra.CheckM
import GF.Compile.Compute.Concrete2 import GF.Compile.Compute.Concrete2
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Maybe(mapMaybe) import Data.Maybe(mapMaybe,fromMaybe)
import Control.Monad (forM) import Control.Monad (forM)
-- | Generate Canonical code for the named abstract syntax and all associated -- | Generate Canonical code for the named abstract syntax and all associated
@@ -43,21 +43,51 @@ abstract2canonical absname gr = do
-- | Generate Canonical code for the all concrete syntaxes associated with -- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar. -- the named abstract syntax in given the grammar.
concretes2canonical :: Options -> ModuleName -> Grammar -> Check [Module] concretes2canonical :: Options -> ModuleName -> Grammar -> Check [Module]
concretes2canonical opts absname gr = concretes2canonical opts absname gr = do
sequence res <- sequence
[concrete2canonical gr absname cnc modinfo [concrete2canonical gr absname cnc modinfo
| cnc<-allConcretes gr absname, | cnc<-allConcretes gr absname,
let Ok modinfo = lookupModule gr cnc 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. -- | 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 concrete2canonical gr absname cncname modinfo = do
let g = Gl gr (stdPredef g) let g = Gl gr (stdPredef g)
infos <- mapM (convInfo g) (allOrigInfos gr cncname) infos <- mapM (convInfo g) (allOrigInfos gr cncname)
let pts = Set.unions (map fst infos) let pts = Set.unions (map fst infos)
pts <- closure pts (Set.toList pts) return (pts,
return (cncname, ModInfo { (cncname, ModInfo {
mtype = MTConcrete absname, mtype = MTConcrete absname,
mstatus = MSComplete, mstatus = MSComplete,
mflags = convFlags gr cncname, mflags = convFlags gr cncname,
@@ -67,9 +97,8 @@ concrete2canonical gr absname cncname modinfo = do
mexdeps = [], mexdeps = [],
msrc = "", msrc = "",
mseqs = Nothing, mseqs = Nothing,
jments = Map.union (Map.fromList (mapMaybe snd infos)) jments = Map.fromList (mapMaybe snd infos)
pts }))
})
where where
convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
typ <- normalForm g typ 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 ((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) 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 paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
closure pts (q@(_,id):qs) = do paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
(_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
let pts' = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx] paramTypes (Sort _) = Set.empty
new_pts = Set.difference pts' pts paramTypes (EInt _) = Set.empty
infos <- closure (Set.union new_pts pts) (Set.toList new_pts++qs) paramTypes (QC q) = Set.singleton q
return (Map.insert id info infos) paramTypes (FV ts) = Set.unions (map paramTypes ts)
paramTypes _ = Set.empty
convFlags :: Grammar -> ModuleName -> Options convFlags :: Grammar -> ModuleName -> Options
convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn) convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn)

2
src/compiler/api/GF/Compile/Repl.hs
View File

@@ -296,7 +296,7 @@ runRepl opts@ReplOpts { noPrelude, inputFiles } = do
(g0, opens) <- case toLoad of (g0, opens) <- case toLoad of
[] -> pure (mGrammar [], []) [] -> pure (mGrammar [], [])
_ -> do _ -> do
(_, (_, g0)) <- batchCompile noOptions Nothing toLoad (_, g0) <- batchCompile noOptions Nothing toLoad
pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad) pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad)
let let
modInfo = ModInfo modInfo = ModInfo

57
src/compiler/api/GF/Compiler.hs
View File

@@ -11,6 +11,7 @@ import GF.Compile.CFGtoPGF
import GF.Compile.GetGrammar import GF.Compile.GetGrammar
import GF.Grammar.BNFC import GF.Grammar.BNFC
import GF.Grammar.CFG import GF.Grammar.CFG
import GF.Grammar.Grammar
import GF.Grammar.JSON(grammar2json) import GF.Grammar.JSON(grammar2json)
import GF.Grammar.Printer(TermPrintQual(..),ppModule) import GF.Grammar.Printer(TermPrintQual(..),ppModule)
@@ -50,46 +51,30 @@ mainGFC opts fs = do
compileSourceFiles :: Options -> [FilePath] -> IOE () compileSourceFiles :: Options -> [FilePath] -> IOE ()
compileSourceFiles opts fs = compileSourceFiles opts fs =
do output <- batchCompile opts fs do cnc_gr@(cnc,gr) <- S.batchCompile opts Nothing fs
exportCanonical output let absname = srcAbsName gr cnc
unless (flag optStopAfterPhase opts == Compile) $ exportCanonical absname gr
linkGrammars opts output 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 where
batchCompile = maybe batchCompile' parallelBatchCompile (flag optJobs opts) exportCanonical absname gr =
batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts Nothing fs do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $ do
return (t,[cnc_gr]) (res,_) <- runCheck (concretes2haskell opts absname gr)
mapM_ writeExport res
exportCanonical (_time, canonical) =
do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
mapM_ cnc2haskell canonical
when (FmtCanonicalGF `elem` ofmts) $ when (FmtCanonicalGF `elem` ofmts) $
do createDirectoryIfMissing False "canonical" do createDirectoryIfMissing False "canonical"
mapM_ abs2canonical canonical (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
mapM_ cnc2canonical canonical forM_ (modules gr_canon) $ \m@(mn,_) -> do
when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2canonical_json canonical 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 where
ofmts = flag optOutputFormats opts 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 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 -- 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 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
-- recreated. Calls 'writeGrammar' and 'writeOutputs'. -- recreated. Calls 'writeGrammar' and 'writeOutputs'.
linkGrammars opts (t_src,[]) = return () linkGrammars opts (t_src,cnc_gr@(cnc,gr)) =
linkGrammars opts (t_src,cnc_gr@(cnc,gr):cnc_grs) =
do let abs = render (srcAbsName gr cnc) do let abs = render (srcAbsName gr cnc)
pgfFile = outputPath opts (grammarName' opts abs<.>"pgf") pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
t_pgf <- if outputJustPGF opts 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 if t_pgf >= Just t_src
then putIfVerb opts $ pgfFile ++ " is up-to-date." then putIfVerb opts $ pgfFile ++ " is up-to-date."
else do pgf <- link opts Nothing cnc_gr else do pgf <- link opts Nothing cnc_gr
pgf <- foldM (link opts . Just) pgf cnc_grs
writeGrammar opts pgf writeGrammar opts pgf
writeOutputs opts pgf writeOutputs opts pgf

225
src/compiler/api/GF/Grammar/JSON.hs
View File

@@ -14,127 +14,131 @@ import Control.Applicative ((<|>))
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
grammar2json :: TermPrintQual -> Grammar -> JSValue grammar2json :: Grammar -> JSValue
grammar2json q gr = grammar2json gr =
makeObj [(showIdent mn, mi2json q mi) | (MN mn,mi) <- modules 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 case mb_ctxt of
Nothing -> makeObj [] Nothing -> makeObj []
Just (L _ ctxt) -> makeObj [("context", showJSON (map (hypo2json q) ctxt))] Just (L _ ctxt) -> makeObj [("context", showJSON (map hypo2json ctxt))]
info2json q (AbsFun mb_ty mb_arity mb_eqs _) = info2json (AbsFun mb_ty mb_arity mb_eqs _) =
(makeObj . catMaybes) (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 (\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 makeObj [("params", case mb_params of
Nothing -> JSArray [] Nothing -> JSArray []
Just (L _ params) -> showJSON (map (param2json q) params))] Just (L _ params) -> showJSON (map param2json params))]
info2json q (ResValue (L _ ty) _) = info2json (ResValue (L _ ty) _) =
makeObj [("paramtype",term2json q ty)] makeObj [("paramtype",term2json ty)]
info2json q (ResOper mb_ty mb_def) = info2json (ResOper mb_ty mb_def) =
(makeObj . catMaybes) (makeObj . catMaybes)
[ fmap (\(L _ ty) -> ("opertype",term2json q ty)) mb_ty [ fmap (\(L _ ty) -> ("opertype",term2json ty)) mb_ty
, fmap (\(L _ def) -> ("operdef",term2json q def)) mb_def , fmap (\(L _ def) -> ("operdef",term2json def)) mb_def
] ]
info2json q (ResOverload mns overloads) = info2json (ResOverload mns overloads) =
makeObj makeObj
[ ("extends",showJSON mns) [ ("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) (makeObj . catMaybes)
[ fmap (\(L _ ty) -> ("lintype",term2json q ty)) mb_ty [ fmap (\(L _ ty) -> ("lintype",term2json ty)) mb_ty
, fmap (\(L _ def) -> ("lindef",term2json q def)) mb_lindef , fmap (\(L _ def) -> ("lindef",term2json def)) mb_lindef
, fmap (\(L _ ref) -> ("linref",term2json q ref)) mb_linref , fmap (\(L _ ref) -> ("linref",term2json ref)) mb_linref
, fmap (\(L _ prn) -> ("printname",term2json q prn)) mb_pnm , fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
] ]
info2json q (CncFun _ mb_lin mb_pnm _) = info2json (CncFun _ mb_lin mb_pnm _) =
(makeObj . catMaybes) (makeObj . catMaybes)
[ fmap (\(L _ lin) -> ("lin",term2json q lin)) mb_lin [ fmap (\(L _ lin) -> ("lin",term2json lin)) mb_lin
, fmap (\(L _ prn) -> ("printname",term2json q prn)) mb_pnm , fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
] ]
info2json q (AnyInd _ mn) = showJSON mn info2json (AnyInd _ mn) = showJSON mn
hypo2json q (bt,x,ty) = hypo2json (bt,x,ty) =
makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("type", term2json q ty)] makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("type", term2json ty)]
equation2json q (ps,t) = equation2json (ps,t) =
makeObj [("patts", showJSON (map (patt2json q) ps)), ("term", term2json q t)] makeObj [("patts", showJSON (map patt2json ps)), ("term", term2json t)]
param2json q (id, ctxt) = param2json (id, ctxt) =
makeObj [("id", showJSON id), ("context", showJSON (map (hypo2json q) ctxt))] makeObj [("id", showJSON id), ("context", showJSON (map hypo2json ctxt))]
overload2json q (L _ ty,L _ def) = overload2json (L _ ty,L _ def) =
makeObj makeObj
[ ("opertype",term2json q ty) [ ("opertype",term2json ty)
, ("operdef",term2json q def) , ("operdef",term2json def)
] ]
term2json :: TermPrintQual -> Term -> JSValue term2json :: Term -> JSValue
term2json q (Vr v) = makeObj [("vr", showJSON v)] term2json (Vr v) = makeObj [("vr", showJSON v)]
term2json q (Cn v) = makeObj [("cn", showJSON v)] term2json (Cn v) = makeObj [("cn", showJSON v)]
term2json q (Con v) = makeObj [("con", showJSON v)] term2json (Con v) = makeObj [("con", showJSON v)]
term2json q (Sort v) = makeObj [("sort", showJSON v)] term2json (Sort v) = makeObj [("sort", showJSON v)]
term2json q (EInt n) = showJSON n term2json (EInt n) = showJSON n
term2json q (EFloat f) = showJSON f term2json (EFloat f) = showJSON f
term2json q (K s) = showJSON s term2json (K s) = showJSON s
term2json q Empty = JSArray [] term2json Empty = JSArray []
term2json q (App t1 t2) = makeObj [("fun", term2json q t1), ("arg", term2json q t2)] term2json (App t1 t2) = makeObj [("fun", term2json t1), ("arg", term2json t2)]
term2json q (Abs bt x t) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("body", term2json q t)] term2json (Abs bt x t) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("body", term2json t)]
term2json q (Meta id) = makeObj [("metaid", showJSON id)] term2json (Meta id) = makeObj [("metaid", showJSON id)]
term2json q (ImplArg t) = makeObj [("implarg", term2json q t)] term2json (ImplArg t) = makeObj [("implarg", term2json 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 (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON v), ("hypo", term2json t1), ("res", term2json t2)]
term2json q (Typed t ty) = makeObj [("term", term2json q t), ("type", term2json q ty)] term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)]
term2json q (Example t s) = makeObj [("term", term2json q t), ("example", showJSON s)] term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)]
term2json q (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))] term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
where toRow (l,t) = (showLabel l, term2json q t) where toRow (l,t) = (showLabel l, term2json t)
term2json q (R lbls) = makeObj [("record", makeObj (map toRow lbls))] term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
where toRow (l,(_,t)) = (showLabel l, term2json q t) where toRow (l,(_,t)) = (showLabel l, term2json t)
term2json q (P t proj) = makeObj [("project", term2json q t), ("label", showJSON (showLabel proj))] term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))]
term2json q (ExtR t1 t2) = makeObj [("term", term2json q t1), ("ext", term2json q t2)] term2json (ExtR t1 t2) = makeObj [("term", term2json t1), ("ext", term2json t2)]
term2json q (Table t1 t2) = makeObj [("tblhypo", term2json q t1), ("tblres", term2json q t2)] term2json (Table t1 t2) = makeObj [("tblhypo", term2json t1), ("tblres", term2json t2)]
term2json q (T _ cs) = makeObj [("tblcases", showJSON [(patt2json q p, term2json q t) | (p,t) <- cs])] term2json (T _ cs) = makeObj [("tblcases", showJSON [(patt2json p, term2json t) | (p,t) <- cs])]
term2json q (V ty ts) = makeObj [("tbltype", term2json q ty), ("tblvalues", showJSON (map (term2json q) ts))] term2json (V ty ts) = makeObj [("tbltype", term2json ty), ("tblvalues", showJSON (map term2json ts))]
term2json q (S t1 t2) = makeObj [("select", term2json q t1), ("key", term2json q t2)] term2json (S t1 t2) = makeObj [("select", term2json t1), ("key", term2json t2)]
term2json q (Let (v,(_,t1)) t2) = makeObj [("letvar", showJSON v), ("letdef", term2json q t1), ("term", term2json q t2)] term2json (Let (v,(_,t1)) t2) = makeObj [("letvar", showJSON v), ("letdef", term2json t1), ("term", term2json t2)]
term2json q (Q (m,id)) = case q of term2json (Q (m,id)) = makeObj [("mod",showJSON m),("q", showJSON id)]
Qualified -> makeObj [("mod",showJSON m),("q", showJSON id)] term2json (QC (m,id)) = makeObj [("mod",showJSON m),("qc", showJSON id)]
_ -> makeObj [("cn", showJSON id)] term2json (C t1 t2) = showJSON ((flatten t1 . flatten t2) [])
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) [])
where where
flatten Empty = id flatten Empty = id
flatten (C t1 t2) = flatten t1 . flatten t2 flatten (C t1 t2) = flatten t1 . flatten t2
flatten t = (term2json q t :) flatten t = (term2json t :)
term2json q (Glue t1 t2) = makeObj [("glue1",term2json q t1),("glue2", term2json q t2)] term2json (Glue t1 t2) = makeObj [("glue1",term2json t1),("glue2", term2json t2)]
term2json q (EPattType t) = makeObj [("patttype",term2json q t)] term2json (EPattType t) = makeObj [("patttype",term2json t)]
term2json q (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json q t)] term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json t)]
term2json q (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json q t)] term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
term2json q (AdHocOverload ts) = makeObj [("overloaded",showJSON (map (term2json q) ts))] term2json (AdHocOverload ts) = makeObj [("overloaded",showJSON (map term2json ts))]
term2json q (FV ts) = makeObj [("variants",showJSON (map (term2json q) ts))] term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
term2json q (Markup tag attrs children) = makeObj [ ("tag",showJSON tag) term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
, ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json q val)) attrs)) , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
, ("children",showJSON (map (term2json q) children)) , ("children",showJSON (map term2json children))
] ]
term2json q (Reset ctl t) = term2json (Reset ctl t) =
let jctl = case ctl of let jctl = case ctl of
All -> showJSON "all" All -> showJSON "all"
One -> showJSON "one" One -> showJSON "one"
Limit n -> showJSON n Limit n -> showJSON n
Coordination Nothing conj cat -> makeObj [("conj",showJSON conj), ("cat",showJSON cat)] 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)] Coordination (Just mod) conj cat -> makeObj [("mod",showJSON mod), ("conj",showJSON conj), ("cat",showJSON cat)]
in makeObj [("reset",jctl), ("term",term2json q t)] in makeObj [("reset",jctl), ("term",term2json t)]
term2json q (Alts def alts) = makeObj [("def",term2json q def), ("alts",showJSON (map (\(t1,t2) -> (term2json q t1, term2json q t2)) alts))] term2json (Alts def alts) = makeObj [("def",term2json def), ("alts",showJSON (map (\(t1,t2) -> (term2json t1, term2json t2)) alts))]
term2json q (Strs ts) = makeObj [("strs",showJSON (map (term2json q) ts))] term2json (Strs ts) = makeObj [("strs",showJSON (map term2json ts))]
json2term o = Vr <$> o!:"vr" json2term o = Vr <$> o!:"vr"
<|> curry Q <$> o!:"mod" <*> o!:"cn" <|> curry Q <$> o!:"mod" <*> o!:"cn"
@@ -207,40 +211,37 @@ json2term o = Vr <$> o!:"vr"
json2ctl _ = fail "Invalid control value for reset" json2ctl _ = fail "Invalid control value for reset"
patt2json q (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map (patt2json q) ps))] patt2json (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
patt2json q (PP (mn,id) ps) = patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
case q of patt2json (PV id) = makeObj [("pv",showJSON id)]
Qualified -> makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map (patt2json q) ps))] patt2json PW = makeObj [("wildcard",showJSON True)]
_ -> makeObj [ ("pc",showJSON id),("args",showJSON (map (patt2json q) ps))] patt2json (PR lbls) = makeObj (("record", showJSON True) : map toRow lbls)
patt2json q (PV id) = makeObj [("pv",showJSON id)] where toRow (l,t) = (showLabel l, patt2json t)
patt2json q PW = makeObj [("wildcard",showJSON True)] patt2json (PString s) = showJSON s
patt2json q (PR lbls) = makeObj (("record", showJSON True) : map toRow lbls) patt2json (PInt n) = showJSON n
where toRow (l,t) = (showLabel l, patt2json q t) patt2json (PFloat d) = showJSON d
patt2json q (PString s) = showJSON s patt2json (PT ty p) = makeObj [("type", term2json ty), ("patt", patt2json p)]
patt2json q (PInt n) = showJSON n patt2json (PAs id p) = makeObj [("as", showJSON id), ("patt", patt2json p)]
patt2json q (PFloat d) = showJSON d patt2json (PImplArg p) = makeObj [("implarg", patt2json p)]
patt2json q (PT ty p) = makeObj [("type", term2json q ty), ("patt", patt2json q p)] patt2json (PTilde t) = makeObj [("tilde", term2json t)]
patt2json q (PAs id p) = makeObj [("as", showJSON id), ("patt", patt2json q p)] patt2json (PNeg p) = makeObj [("neg", patt2json p)]
patt2json q (PImplArg p) = makeObj [("implarg", patt2json q p)] patt2json (PAlt p1 p2) = makeObj [("alt1", patt2json p1), ("alt2", patt2json p2)]
patt2json q (PTilde t) = makeObj [("tilde", term2json q t)] patt2json (PSeq min1 max1 p1 min2 max2 p2)
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)
= makeObj [("min1", showJSON min1) = makeObj [("min1", showJSON min1)
,("max1", showJSON max1) ,("max1", showJSON max1)
,("patt1", patt2json q p1) ,("patt1", patt2json p1)
,("min2", showJSON min2) ,("min2", showJSON min2)
,("max2", showJSON max2) ,("max2", showJSON max2)
,("patt2", patt2json q p2) ,("patt2", patt2json p2)
] ]
patt2json q (PRep min max p)=makeObj [("min", showJSON min) patt2json (PRep min max p)=makeObj [("min", showJSON min)
,("max", showJSON max) ,("max", showJSON max)
,("patt", patt2json q p) ,("patt", patt2json p)
] ]
patt2json q PChar = makeObj [("char",showJSON True)] patt2json PChar = makeObj [("char",showJSON True)]
patt2json q (PChars cs) = makeObj [("chars",showJSON cs)] patt2json (PChars cs) = makeObj [("chars",showJSON cs)]
patt2json q (PMacro id) = makeObj [("macro",showJSON id)] patt2json (PMacro id) = makeObj [("macro",showJSON id)]
patt2json q (PM (mn,id)) = makeObj [("mod",showJSON mn), ("macro",showJSON id)] patt2json (PM (mn,id)) = makeObj [("mod",showJSON mn), ("macro",showJSON id)]
json2patt :: JSValue -> Result Patt json2patt :: JSValue -> Result Patt
json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt) json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt)