msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Use HughesPJ pretty printer to make JSGF output look nicer.

Browse Source
This commit is contained in:
bringert
2006-12-20 21:39:25 +00:00
parent 0353b7b7cb
commit f07b0ef88e
1 changed files with 41 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

79
src/GF/Speech/PrJSGF.hs
View File

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