Refactor grammar export code.

5 files changed, 45 insertions, 47 deletions

diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs
index 803fb6017..f442cfa22 100644
--- a/src-3.0/GF/Command/Commands.hs
+++ b/src-3.0/GF/Command/Commands.hs
@@ -441,7 +441,7 @@ allCommands pgf = Map.fromList [
            unlines $ [unwords (la:":": map prCId cs) | 
                        la <- optLangs opts, let cs = missingLins pgf (mkCId la)]
      _ -> case valIdOpts "printer" "pgf" opts of
-       v -> prPGF noOptions (read v) pgf (prCId (absname pgf))
+       v -> concatMap snd $ exportPGF noOptions (read v) pgf
 
    morphos opts s = 
      [lookupMorpho (buildMorpho pgf (mkCId la)) s | la <- optLangs opts]
diff --git a/src-3.0/GF/Compile/Export.hs b/src-3.0/GF/Compile/Export.hs
index 9abdc6789..f88d6d7ba 100644
--- a/src-3.0/GF/Compile/Export.hs
+++ b/src-3.0/GF/Compile/Export.hs
@@ -15,26 +15,35 @@ import GF.Speech.GSL
 import GF.Speech.VoiceXML
 import GF.Text.UTF8
 
+import Data.Maybe
+import System.FilePath
+
 -- top-level access to code generation
 
-prPGF :: Options
-      -> OutputFormat 
-      -> PGF 
-      -> String -- ^ Output name, for example used for generated Haskell
-                -- module name.
-      -> String
-prPGF opts fmt gr name = case fmt of
-  FmtPGF          -> printPGF gr
-  FmtJavaScript   -> pgf2js gr
-  FmtHaskell      -> grammar2haskell gr name
-  FmtHaskell_GADT -> grammar2haskellGADT gr name
-  FmtBNF          -> prCFG $ pgfToCFG gr (outputConcr gr)
-  FmtSRGS_XML     -> srgsXmlPrinter (flag optSISR opts) gr (outputConcr gr)
-  FmtJSGF         -> jsgfPrinter (flag optSISR opts) gr (outputConcr gr)
-  FmtGSL          -> gslPrinter gr (outputConcr gr)
-  FmtVoiceXML     -> grammar2vxml gr (outputConcr gr)
+exportPGF :: Options
+          -> OutputFormat 
+          -> PGF 
+          -> [(FilePath,String)] -- ^ List of recommended file names and contents.
+exportPGF opts fmt pgf = 
+    case fmt of
+      FmtPGF          -> multi "pgf" printPGF
+      FmtJavaScript   -> multi "js"  pgf2js
+      FmtHaskell      -> multi "hs"  (grammar2haskell name)
+      FmtHaskell_GADT -> multi "hs"  (grammar2haskellGADT name)
+      FmtBNF          -> single "bnf"   bnfPrinter
+      FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter sisr)
+      FmtJSGF         -> single "jsgf"  (jsgfPrinter sisr)
+      FmtGSL          -> single "gsl"   gslPrinter
+      FmtVoiceXML     -> single "vxml"  grammar2vxml
+ where
+   name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts)
+   sisr = flag optSISR opts
 
+   multi :: String -> (PGF -> String) -> [(FilePath,String)]
+   multi ext pr = [(name <.> ext, pr pgf)]
 
+   single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
+   single ext pr = [(prCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf]
 
 -- | Get the name of the concrete syntax to generate output from.
 -- FIXME: there should be an option to change this.
diff --git a/src-3.0/GF/Compile/GFCCtoHaskell.hs b/src-3.0/GF/Compile/GFCCtoHaskell.hs
index 31f1dc0b3..9d03aa490 100644
--- a/src-3.0/GF/Compile/GFCCtoHaskell.hs
+++ b/src-3.0/GF/Compile/GFCCtoHaskell.hs
@@ -27,15 +27,15 @@ import Data.List --(isPrefixOf, find, intersperse)
 import qualified Data.Map as Map
 
 -- | the main function
-grammar2haskell :: PGF 
-                -> String  -- ^ Module name.
+grammar2haskell :: String  -- ^ Module name.
+                -> PGF
                 -> String
-grammar2haskell gr name = encodeUTF8 $ foldr (++++) [] $  
+grammar2haskell name gr = encodeUTF8 $ foldr (++++) [] $  
   haskPreamble name ++ [datatypes gr', gfinstances gr']
     where gr' = hSkeleton gr
 
-grammar2haskellGADT :: PGF -> String -> String
-grammar2haskellGADT gr name = encodeUTF8 $ foldr (++++) [] $  
+grammar2haskellGADT :: String -> PGF -> String
+grammar2haskellGADT name gr = encodeUTF8 $ foldr (++++) [] $  
   ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
   haskPreamble name ++ [datatypesGADT gr', gfinstances gr']
     where gr' = hSkeleton gr
diff --git a/src-3.0/GF/Speech/PGFToCFG.hs b/src-3.0/GF/Speech/PGFToCFG.hs
index 168591e6b..1f3ebaeb4 100644
--- a/src-3.0/GF/Speech/PGFToCFG.hs
+++ b/src-3.0/GF/Speech/PGFToCFG.hs
@@ -4,7 +4,7 @@
 --
 -- Approximates PGF grammars with context-free grammars.
 ----------------------------------------------------------------------
-module GF.Speech.PGFToCFG (pgfToCFG) where
+module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where
 
 import PGF.CId
 import PGF.Data as PGF
@@ -19,6 +19,8 @@ import Data.Maybe
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+bnfPrinter :: PGF -> CId -> String
+bnfPrinter pgf cnc = prCFG $ pgfToCFG pgf cnc
 
 pgfToCFG :: PGF 
           -> CId   -- ^ Concrete syntax name
diff --git a/src-3.0/GFC.hs b/src-3.0/GFC.hs
index c663f46c9..17c95eb30 100644
--- a/src-3.0/GFC.hs
+++ b/src-3.0/GFC.hs
@@ -26,30 +26,17 @@ mainGFC opts fs =
                  writeOutputs opts pgf
 
 writeOutputs :: Options -> PGF -> IOE ()
-writeOutputs opts pgf = mapM_ (\fmt -> writeOutput opts fmt pgf) (flag optOutputFormats opts)
-
-writeOutput :: Options -> OutputFormat-> PGF -> IOE ()
-writeOutput opts fmt pgf =
-    do let name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts)
-           path = outputFilePath opts fmt name
-           s = prPGF opts fmt pgf name
-       writeOutputFile path s
-
-outputFilePath :: Options -> OutputFormat -> String -> FilePath
-outputFilePath opts fmt name0 = addDir name <.> fmtExtension fmt
-  where name = fromMaybe name0 (moduleFlag optName opts)
-        addDir = maybe id (</>) (flag optOutputDir opts)
-
-fmtExtension :: OutputFormat -> String
-fmtExtension FmtPGF          = "pgf"
-fmtExtension FmtJavaScript   = "js"
-fmtExtension FmtHaskell      = "hs"
-fmtExtension FmtHaskell_GADT = "hs"
-fmtExtension FmtBNF          = "bnf"
-fmtExtension FmtSRGS_XML     = "grxml"
-fmtExtension FmtJSGF         = "jsgf"
-fmtExtension FmtGSL          = "gsl"
-fmtExtension FmtVoiceXML     = "vxml"
+writeOutputs opts pgf =
+    sequence_ [writeOutput opts name str 
+                   | fmt <- flag optOutputFormats opts, 
+                     (name,str) <- exportPGF opts fmt pgf]
+
+writeOutput :: Options -> FilePath-> String -> IOE ()
+writeOutput opts file str =
+    do let path = case flag optOutputDir opts of
+                    Nothing  -> file
+                    Just dir -> dir </> file
+       writeOutputFile path str
 
 writeOutputFile :: FilePath -> String -> IOE ()
 writeOutputFile outfile output = ioeIO $