diff --git a/src/compiler/api/GF/Command/Importing.hs b/src/compiler/api/GF/Command/Importing.hs index 8d483198d..ec2070605 100644 --- a/src/compiler/api/GF/Command/Importing.hs +++ b/src/compiler/api/GF/Command/Importing.hs @@ -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 diff --git a/src/compiler/api/GF/Compile.hs b/src/compiler/api/GF/Compile.hs index ca5b31666..9a6e9cc6a 100644 --- a/src/compiler/api/GF/Compile.hs +++ b/src/compiler/api/GF/Compile.hs @@ -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 diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs index 4b2e56c50..94dcd0387 100644 --- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/api/GF/Compile/GrammarToCanonical.hs @@ -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) diff --git a/src/compiler/api/GF/Compile/Repl.hs b/src/compiler/api/GF/Compile/Repl.hs index e9a909f6d..8cb7d92a0 100644 --- a/src/compiler/api/GF/Compile/Repl.hs +++ b/src/compiler/api/GF/Compile/Repl.hs @@ -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 diff --git a/src/compiler/api/GF/Compiler.hs b/src/compiler/api/GF/Compiler.hs index 7bc387f13..78ec1796e 100644 --- a/src/compiler/api/GF/Compiler.hs +++ b/src/compiler/api/GF/Compiler.hs @@ -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 diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs index 056e66212..45a41d46d 100644 --- a/src/compiler/api/GF/Grammar/JSON.hs +++ b/src/compiler/api/GF/Grammar/JSON.hs @@ -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)