Use HughesPJ pretty printer to make JSGF output look nicer.

src/GF/Speech/PrJSGF.hs

@@ -33,6 +33,7 @@ import GF.Speech.RegExp
 
 import Data.Char
 import Data.List
+import Text.PrettyPrint.HughesPJ
 import Debug.Trace
 
 
@@ -41,35 +42,33 @@ jsgfPrinter :: Ident -- ^ Grammar name
 	    -> Options 
             -> Maybe SISRFormat
             -> Maybe Probs -> CGrammar -> String
-jsgfPrinter name start opts sisr probs cfg = prJSGF srg sisr ""
+jsgfPrinter name start opts sisr probs cfg = show (prJSGF srg sisr)
     where srg = makeSimpleSRG name start opts probs cfg
 
-prJSGF :: SRG -> Maybe SISRFormat -> ShowS
+prJSGF :: SRG -> Maybe SISRFormat -> Doc
 prJSGF srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) sisr
-    = header . nl
-      . mainCat . nl
-      . unlinesS topCatRules . nl
-      . unlinesS (map prRule rs)
+    = header $$ mainCat $$ vcat topCatRules $$ vcat (map prRule rs)
     where
-    header = showString "#JSGF V1.0 UTF-8;" . nl 
-	     . comment ("JSGF speech recognition grammar for " ++ name)
-             . comment "Generated by GF"
-	     . showString ("grammar " ++ name ++ ";") . nl
-    mainCat = comment ("Start category: " ++ origStart)
-	      . rule True "MAIN" [prCat start]
+    header = text "#JSGF V1.0 UTF-8;" $$
+             comment ("JSGF speech recognition grammar for " ++ name) $$
+             comment "Generated by GF" $$
+	     text ("grammar " ++ name ++ ";")
+    mainCat = comment ("Start category: " ++ origStart) $$
+	      rule True "MAIN" [prCat start]
     prRule (SRGRule cat origCat rhs) = 
-	comment origCat
---        . rule False cat (map prAlt (ebnfSRGAlts rhs))
-        . rule False cat (map prAlt rhs)
+	comment origCat $$
+--        rule False cat (map prAlt (ebnfSRGAlts rhs))
+        rule False cat (map prAlt rhs) $$ text "" 
     -- FIXME: use the probability
 --    prAlt (EBnfSRGAlt mp n rhs) = tag sisr (profileInitSISR n) . showChar ' '. prItem sisr rhs
-    prAlt (SRGAlt mp n rhs) = initTag . showChar ' '. prItem sisr n rhs . tag sisr (profileFinalSISR n)
-      where initTag | null (t "") = id
-                    | otherwise = showString "<NULL>" . showChar ' ' . t
+    prAlt (SRGAlt mp n rhs) = initTag <+> prItem sisr n rhs <+> finalTag
+      where initTag | isEmpty t = empty
+                    | otherwise = text "<NULL>" <+>  t
                 where t = tag sisr (profileInitSISR n)
+            finalTag = tag sisr (profileFinalSISR n)
 
     topCatRules = [rule True (catFormId tc) (map (it tc) cs) | (tc,cs) <- srgTopCats srg]
-        where it i c = prCat c . tag sisr (topCatSISR (catFieldId i) c)
+        where it i c = prCat c <+> tag sisr (topCatSISR (catFieldId i) c)
 
 catFormId :: String -> String
 catFormId = (++ "_cat")
@@ -77,8 +76,8 @@ catFormId = (++ "_cat")
 catFieldId :: String -> String
 catFieldId = (++ "_field")
 
-prCat :: SRGCat -> ShowS
-prCat c = showChar '<' . showString c . showChar '>'
+prCat :: SRGCat -> Doc
+prCat c = char '<' <> text c <> char '>'
 
 {-
 prItem :: Maybe SISRFormat -> EBnfSRGItem -> ShowS
@@ -95,20 +94,21 @@ prItem sisr = f 1
     f _ (RESymbol s)  = prSymbol sisr s
 -}
 
-prItem :: Maybe SISRFormat -> CFTerm -> [Symbol SRGNT Token] -> ShowS
-prItem _ _ [] = showString "<NULL>"
-prItem sisr cn ss = paren $ unwordsS $ map (prSymbol sisr cn) ss
+prItem :: Maybe SISRFormat -> CFTerm -> [Symbol SRGNT Token] -> Doc
+prItem _ _ [] = text "<NULL>"
+prItem sisr cn ss = paren $ hsep $ map (prSymbol sisr cn) ss
+  where paren = if length ss == 1 then id else parens
 
-prSymbol :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> ShowS
-prSymbol sisr cn (Cat n@(c,_)) = prCat c . tag sisr (catSISR cn n)
-prSymbol _ cn (Tok t) | all isPunct (prt t) = id -- removes punctuation
-                      | otherwise = prtS t -- FIXME: quote if there is whitespace or odd chars
+prSymbol :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> Doc
+prSymbol sisr cn (Cat n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
+prSymbol _ cn (Tok t) | all isPunct (prt t) = empty  -- removes punctuation
+                      | otherwise = text (prt t) -- FIXME: quote if there is whitespace or odd chars
 
-tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> ShowS
-tag Nothing _ = id
+tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
+tag Nothing _ = empty
 tag (Just fmt) t = case t fmt of
-                     [] -> id
-                     ts -> showString "{" . showString (e $ prSISR ts) . showString "}"
+                     [] -> empty
+                     ts -> char '{' <+> text (e $ prSISR ts) <+> char '}'
   where e [] = []
         e ('}':xs) = '\\':'}':e xs
         e ('\n':xs) = ' ' : e (dropWhile isSpace xs)
@@ -117,11 +117,14 @@ tag (Just fmt) t = case t fmt of
 isPunct :: Char -> Bool
 isPunct c = c `elem` "-_.;.,?!"
 
-comment :: String -> ShowS
-comment s = showString "// " . showString s . nl
+comment :: String -> Doc
+comment s = text "//" <+> text s
 
-paren f = wrap "(" f ")"
+prepunctuate :: Doc -> [Doc] -> [Doc]
+prepunctuate _ [] = []
+prepunctuate p (x:xs) = x : map (p <>) xs
 
-rule :: Bool -> SRGCat -> [ShowS] -> ShowS
-rule pub c xs = p . prCat c . showString " = " . joinS " | " xs . showChar ';' . nl
-  where p = if pub then showString "public " else id
+rule :: Bool -> SRGCat -> [Doc] -> Doc
+rule pub c xs = p <+> prCat c <+> char '=' 
+                $$ nest 2 (sep (prepunctuate (text "| ") xs) <+> char ';')
+  where p = if pub then text "public" else empty