From 47ac01e4b9502ed573e4847ff563ada2670bd4ba Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Peter=20Ljunglo=CC=88f?= <peter.ljunglof@heatherleaf.se>
Date: Fri, 8 Feb 2019 09:10:48 +0100
Subject: [PATCH] enable export of canonical grammars to JSON and YAML

---
 src/compiler/GF/Compile/Export.hs |  2 ++
 src/compiler/GF/Compiler.hs       | 21 ++++++++++++++++-----
 src/compiler/GF/Infra/Option.hs   |  4 ++++
 3 files changed, 22 insertions(+), 5 deletions(-)

diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs
index c86c9dd03..e1895feb0 100644
--- a/src/compiler/GF/Compile/Export.hs
+++ b/src/compiler/GF/Compile/Export.hs
@@ -36,6 +36,8 @@ exportPGF opts fmt pgf =
     case fmt of
       FmtPGFPretty    -> multi "txt" (render . ppPGF)
       FmtCanonicalGF  -> [] -- canon "gf" (render80 . abstract2canonical)
+      FmtCanonicalJson-> []
+      FmtCanonicalYaml-> []
       FmtJavaScript   -> multi "js"  pgf2js
       FmtPython       -> multi "py"  pgf2python
       FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs
index 2bd0fc0cb..539b0b341 100644
--- a/src/compiler/GF/Compiler.hs
+++ b/src/compiler/GF/Compiler.hs
@@ -24,6 +24,7 @@ import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.ByteString.Lazy as BSL
+import GF.Grammar.CanonicalJSON (encodeJSON, encodeYAML)
 import System.FilePath
 import Control.Monad(when,unless,forM_)
 
@@ -48,7 +49,7 @@ mainGFC opts fs = do
 compileSourceFiles :: Options -> [FilePath] -> IOE ()
 compileSourceFiles opts fs = 
     do output <- batchCompile opts fs
-       exportCncs output
+       exportCanonical output
        unless (flag optStopAfterPhase opts == Compile) $
            linkGrammars opts output
   where
@@ -56,13 +57,15 @@ compileSourceFiles opts fs =
     batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
                                return (t,[cnc_gr])
 
-    exportCncs output =
+    exportCanonical (_time, canonical) =
       do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
-           mapM_ cnc2haskell (snd output)
+           mapM_ cnc2haskell canonical
          when (FmtCanonicalGF `elem` ofmts) $
            do createDirectoryIfMissing False "canonical"
-              mapM_ abs2canonical (snd output)
-              mapM_ cnc2canonical (snd output)
+              mapM_ abs2canonical canonical
+              mapM_ cnc2canonical canonical
+         when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
+         when (FmtCanonicalYaml `elem` ofmts) $ mapM_ grammar2yaml canonical
       where
         ofmts = flag optOutputFormats opts
 
@@ -79,6 +82,14 @@ compileSourceFiles opts fs =
       mapM_ (writeExport.fmap render80) $
             concretes2canonical opts (srcAbsName gr cnc) gr
 
+    grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon
+      where absname = srcAbsName gr cnc
+            gr_canon = grammar2canonical opts absname gr
+
+    grammar2yaml (cnc,gr) = encodeYAML (render absname ++ ".yaml") gr_canon
+      where absname = srcAbsName gr cnc
+            gr_canon = grammar2canonical opts absname gr
+
     writeExport (path,s) = writing opts path $ writeUTF8File path s
 
 
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index bd65db2f6..832c37115 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -88,6 +88,8 @@ data Phase = Preproc | Convert | Compile | Link
 
 data OutputFormat = FmtPGFPretty
                   | FmtCanonicalGF
+                  | FmtCanonicalJson
+                  | FmtCanonicalYaml
                   | FmtJavaScript 
                   | FmtPython 
                   | FmtHaskell 
@@ -470,6 +472,8 @@ outputFormatsExpl :: [((String,OutputFormat),String)]
 outputFormatsExpl = 
     [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
+     (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
+     (("canonical_yaml", FmtCanonicalYaml),"Canonical YAML source files"),
      (("js",           FmtJavaScript),"JavaScript (whole grammar)"),
      (("python",       FmtPython),"Python (whole grammar)"),
      (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),