mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-20 08:32:50 -06:00
138 lines
4.5 KiB
Haskell
138 lines
4.5 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : PrJSGF
|
|
-- Maintainer : BB
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/11/01 20:09:04 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.16 $
|
|
--
|
|
-- This module prints a CFG as a JSGF grammar.
|
|
--
|
|
-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
|
|
-- categories in the grammar
|
|
--
|
|
-- FIXME: convert to UTF-8
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Speech.PrJSGF (jsgfPrinter) where
|
|
|
|
import GF.Conversion.Types
|
|
import GF.Data.Utilities
|
|
import GF.Formalism.CFG
|
|
import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), filterCats)
|
|
import GF.Infra.Ident
|
|
import GF.Infra.Print
|
|
import GF.Infra.Option
|
|
import GF.Probabilistic.Probabilistic (Probs)
|
|
import GF.Speech.SISR
|
|
import GF.Speech.SRG
|
|
import GF.Speech.RegExp
|
|
|
|
import Data.Char
|
|
import Data.List
|
|
import Text.PrettyPrint.HughesPJ
|
|
import Debug.Trace
|
|
|
|
|
|
jsgfPrinter :: Ident -- ^ Grammar name
|
|
-> String -- ^ Start category
|
|
-> Options
|
|
-> Maybe SISRFormat
|
|
-> Maybe Probs -> CGrammar -> String
|
|
jsgfPrinter name start opts sisr probs cfg = show (prJSGF srg sisr)
|
|
where srg = makeSimpleSRG name start opts probs cfg
|
|
|
|
prJSGF :: SRG -> Maybe SISRFormat -> Doc
|
|
prJSGF srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) sisr
|
|
= header $++$ mainCat $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs)
|
|
where
|
|
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)
|
|
-- FIXME: use the probability
|
|
-- prAlt (EBnfSRGAlt mp n rhs) = tag sisr (profileInitSISR n) . showChar ' '. prItem sisr rhs
|
|
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 c)
|
|
|
|
catFormId :: String -> String
|
|
catFormId = (++ "_cat")
|
|
|
|
prCat :: SRGCat -> Doc
|
|
prCat c = char '<' <> text c <> char '>'
|
|
|
|
{-
|
|
prItem :: Maybe SISRFormat -> EBnfSRGItem -> ShowS
|
|
prItem sisr = f 1
|
|
where
|
|
f _ (REUnion []) = showString "<VOID>"
|
|
f p (REUnion xs)
|
|
| not (null es) = wrap "[" (f 0 (REUnion nes)) "]"
|
|
| otherwise = (if p >= 1 then paren else id) (joinS " | " (map (f 1) xs))
|
|
where (es,nes) = partition (== REConcat []) xs
|
|
f _ (REConcat []) = showString "<NULL>"
|
|
f p (REConcat xs) = (if p >= 3 then paren else id) (unwordsS (map (f 2) xs))
|
|
f p (RERepeat x) = f 3 x . showString "*"
|
|
f _ (RESymbol s) = prSymbol sisr s
|
|
-}
|
|
|
|
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 -> 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) -> Doc
|
|
tag Nothing _ = empty
|
|
tag (Just fmt) t = case t fmt of
|
|
[] -> empty
|
|
ts -> char '{' <+> text (e $ prSISR ts) <+> char '}'
|
|
where e [] = []
|
|
e ('}':xs) = '\\':'}':e xs
|
|
e ('\n':xs) = ' ' : e (dropWhile isSpace xs)
|
|
e (x:xs) = x:e xs
|
|
|
|
isPunct :: Char -> Bool
|
|
isPunct c = c `elem` "-_.;.,?!"
|
|
|
|
comment :: String -> Doc
|
|
comment s = text "//" <+> text s
|
|
|
|
|
|
|
|
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
|
|
|
|
-- Pretty-printing utilities
|
|
|
|
emptyLine :: Doc
|
|
emptyLine = text ""
|
|
|
|
prepunctuate :: Doc -> [Doc] -> [Doc]
|
|
prepunctuate _ [] = []
|
|
prepunctuate p (x:xs) = x : map (p <>) xs
|
|
|
|
($++$) :: Doc -> Doc -> Doc
|
|
x $++$ y = x $$ emptyLine $$ y
|