mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-21 17:12:50 -06:00
820d2d503f
* In GHC 8.4.1, the operator <> has become a method of the Semigroup class
and is exported from the Prelude. This is unfortunate, since <> is also
exported from the standard library module Text.PrettyPrint, so in any
module that defines a pretty printer, there is likely to be an ambiguity.
This affects ~18 modules in GF. Solution:
import Prelude hiding (<>)
This works also in older versions of GHC, since GHC does't complain if
you hide something that doesn't exists.
* In GHC 8.4.1, Semigroup has become a superclass of Monoid. This means
that anywhere you define an instance of the Monoid class you also have to
define an instance in the Semigroup class.
This affects Data.Binary.Builder in GF. Solution: conditionally define
a Semigroup instance if compiling with base>=4.11 (ghc>=8.4.1)
96 lines
2.4 KiB
Haskell
96 lines
2.4 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : GF.Speech.GSL
|
|
--
|
|
-- This module prints a CFG as a Nuance GSL 2.0 grammar.
|
|
--
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Speech.GSL (gslPrinter) where
|
|
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
|
|
|
--import GF.Data.Utilities
|
|
import GF.Grammar.CFG
|
|
import GF.Speech.SRG
|
|
import GF.Speech.RegExp
|
|
import GF.Infra.Option
|
|
--import GF.Infra.Ident
|
|
import PGF
|
|
|
|
import Data.Char (toUpper,toLower)
|
|
import Data.List (partition)
|
|
import GF.Text.Pretty
|
|
|
|
width :: Int
|
|
width = 75
|
|
|
|
gslPrinter :: Options -> PGF -> CId -> String
|
|
gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
|
|
where st = style { lineLength = width }
|
|
|
|
prGSL :: SRG -> Doc
|
|
prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
|
|
where
|
|
header = ";GSL2.0" $$
|
|
comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
|
|
comment ("Generated by GF")
|
|
mainCat = ".MAIN" <+> prCat (srgStartCat srg)
|
|
prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs)
|
|
-- FIXME: use the probability
|
|
prAlt (SRGAlt mp _ rhs) = prItem rhs
|
|
|
|
|
|
prItem :: SRGItem -> Doc
|
|
prItem = f
|
|
where
|
|
f (REUnion xs) = (if null es then empty else pp "?") <> union (map f nes)
|
|
where (es,nes) = partition isEpsilon xs
|
|
f (REConcat [x]) = f x
|
|
f (REConcat xs) = "(" <> fsep (map f xs) <> ")"
|
|
f (RERepeat x) = "*" <> f x
|
|
f (RESymbol s) = prSymbol s
|
|
|
|
union :: [Doc] -> Doc
|
|
union [x] = x
|
|
union xs = "[" <> fsep xs <> "]"
|
|
|
|
prSymbol :: Symbol SRGNT Token -> Doc
|
|
prSymbol = symbol (prCat . fst) (doubleQuotes . showToken)
|
|
|
|
-- GSL requires an upper case letter in category names
|
|
prCat :: Cat -> Doc
|
|
prCat = pp . firstToUpper
|
|
|
|
|
|
firstToUpper :: String -> String
|
|
firstToUpper [] = []
|
|
firstToUpper (x:xs) = toUpper x : xs
|
|
|
|
{-
|
|
rmPunctCFG :: CGrammar -> CGrammar
|
|
rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g]
|
|
|
|
keepSymbol :: Symbol c Token -> Bool
|
|
keepSymbol (Tok t) = not (all isPunct (prt t))
|
|
keepSymbol _ = True
|
|
-}
|
|
|
|
-- Nuance does not like upper case characters in tokens
|
|
showToken :: Token -> Doc
|
|
showToken = pp . map toLower
|
|
|
|
--isPunct :: Char -> Bool
|
|
--isPunct c = c `elem` "-_.:;.,?!()[]{}"
|
|
|
|
comment :: String -> Doc
|
|
comment s = ";" <+> s
|
|
|
|
|
|
-- Pretty-printing utilities
|
|
|
|
emptyLine :: Doc
|
|
emptyLine = pp ""
|
|
|
|
($++$) :: Doc -> Doc -> Doc
|
|
x $++$ y = x $$ emptyLine $$ y
|