GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

Nicer formatting of generated GSL.

Browse Source
This commit is contained in:
bringert
2007-03-27 10:21:16 +00:00
parent 5c9a870fc3
commit 91c7b22e8c
1 changed files with 35 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files

63
src/GF/Speech/PrGSL.hs
View File

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