Nicer formatting of generated GSL.

1 files changed, 35 insertions, 28 deletions

diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
index dbd7d44e3..3d9632521 100644
--- a/src/GF/Speech/PrGSL.hs
+++ b/src/GF/Speech/PrGSL.hs
@@ -32,50 +32,48 @@ import GF.Compile.ShellState (StateGrammar)
 
 import Data.Char (toUpper,toLower)
 import Data.List (partition)
+import Text.PrettyPrint.HughesPJ
 
 gslPrinter :: Options -> StateGrammar -> String
-gslPrinter opts s = prGSL $ makeSimpleSRG opts s
+gslPrinter opts s = show $ prGSL $ makeSimpleSRG opts s
 
-prGSL :: SRG -> String
+prGSL :: SRG -> Doc
 prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
-    = (header . mainCat . unlinesS (map prRule rs)) ""
+    = header $++$ mainCat $++$ foldr ($++$) empty (map prRule rs)
     where
-    header = showString ";GSL2.0" . nl 
-	     . comments ["Nuance speech recognition grammar for " ++ name,
-			 "Generated by GF"] . nl . nl
-    mainCat = showString ("; Start category: " ++ origStart) . nl 
-	      . showString ".MAIN " . prCat start . nl . nl
+    header = text ";GSL2.0" $$
+	     comment ("Nuance speech recognition grammar for " ++ name) $$
+             comment ("Generated by GF") 
+    mainCat = comment ("Start category: " ++ origStart) $$
+	      text ".MAIN" <+> prCat start
     prRule (SRGRule cat origCat rhs) = 
-	showString "; " . prtS origCat . nl
-        . prCat cat . sp . brackets (unwordsS (map prAlt (ebnfSRGAlts rhs))) . nl
+	comment (prt origCat) $$ 
+        prCat cat <+> union (map prAlt (ebnfSRGAlts rhs))
     -- FIXME: use the probability
     prAlt (EBnfSRGAlt mp _ rhs) = prItem rhs
 
 
-prItem :: EBnfSRGItem -> ShowS
+prItem :: EBnfSRGItem -> Doc
 prItem = f
   where
-    f (REUnion xs) 
-        | not (null es) = showString "?" . f (REUnion nes)
-        | otherwise = brackets (unwordsS (map f xs))
+    f (REUnion xs) = (if null es then empty else text "?") <> union (map f nes)
       where (es,nes) = partition isEpsilon xs
     f (REConcat [x]) = f x
-    f (REConcat xs) = parens (unwordsS (map f xs))
-    f (RERepeat x)  = showString "*" . f x
+    f (REConcat xs) = text "(" <> sep (map f xs) <> text ")"
+    f (RERepeat x)  = text "*" <> f x
     f (RESymbol s)  = prSymbol s
 
-parens x = wrap "(" x ")"
+union :: [Doc] -> Doc
+union [x] = x
+union xs = text "[" <> sep xs <> text "]"
 
-brackets x = wrap "[" x "]"
-
-
-prSymbol :: Symbol SRGNT Token -> ShowS
+prSymbol :: Symbol SRGNT Token -> Doc
 prSymbol (Cat (c,_)) = prCat c
-prSymbol (Tok t) = wrap "\"" (showString (showToken t)) "\""
+prSymbol (Tok t) = doubleQuotes (showToken t)
 
 -- GSL requires an upper case letter in category names
-prCat :: SRGCat -> ShowS
-prCat c = showString (firstToUpper c)
+prCat :: SRGCat -> Doc
+prCat c = text (firstToUpper c)
 
 
 firstToUpper :: String -> String
@@ -92,11 +90,20 @@ keepSymbol _ = True
 -}
 
 -- Nuance does not like upper case characters in tokens
-showToken :: Token -> String
-showToken t = map toLower (prt t)
+showToken :: Token -> Doc
+showToken t = text (map toLower (prt t))
 
 isPunct :: Char -> Bool
 isPunct c = c `elem` "-_.:;.,?!()[]{}"
 
-comments :: [String] -> ShowS
-comments = unlinesS . map (showString . ("; " ++))
+comment :: String -> Doc
+comment s = text ";" <+> text s
+
+
+-- Pretty-printing utilities
+
+emptyLine :: Doc
+emptyLine = text ""
+
+($++$) :: Doc -> Doc -> Doc
+x $++$ y = x $$ emptyLine $$ y
\ No newline at end of file