module GF.Speech.JSGF (jsgfPrinter) where
import Prelude hiding ((<>))
import GF.Infra.Option
import GF.Grammar.CFG
import GF.Speech.RegExp
import GF.Speech.SISR
import GF.Speech.SRG
import PGF
import Data.Char
import Data.List
import GF.Text.Pretty
width :: Int
width :: Int
width = Int
75
jsgfPrinter :: Options
-> PGF
-> CId -> String
jsgfPrinter :: Options -> PGF -> CId -> String
jsgfPrinter Options
opts PGF
pgf CId
cnc = Style -> Doc -> String
forall a. Pretty a => Style -> a -> String
renderStyle Style
st (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Maybe SISRFormat -> SRG -> Doc
prJSGF Maybe SISRFormat
sisr (SRG -> Doc) -> SRG -> Doc
forall a b. (a -> b) -> a -> b
$ Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG Options
opts PGF
pgf CId
cnc
where st :: Style
st = Style
style { lineLength :: Int
lineLength = Int
width }
sisr :: Maybe SISRFormat
sisr = (Flags -> Maybe SISRFormat) -> Options -> Maybe SISRFormat
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe SISRFormat
optSISR Options
opts
prJSGF :: Maybe SISRFormat -> SRG -> Doc
prJSGF :: Maybe SISRFormat -> SRG -> Doc
prJSGF Maybe SISRFormat
sisr SRG
srg
= Doc
header Doc -> Doc -> Doc
$++$ Doc
mainCat Doc -> Doc -> Doc
$++$ (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
($++$) Doc
empty ((SRGRule -> Doc) -> [SRGRule] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SRGRule -> Doc
prRule (SRG -> [SRGRule]
srgRules SRG
srg))
where
header :: Doc
header = String
"#JSGF" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"V1.0" Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"UTF-8" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Doc
lang Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> Char
';' Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
String -> Doc
comment (String
"JSGF speech recognition grammar for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SRG -> String
srgName SRG
srg) Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
String -> Doc
comment String
"Generated by GF" Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
(String
"grammar " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SRG -> String
srgName SRG
srg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";")
lang :: Doc
lang = Doc -> (String -> Doc) -> Maybe String -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty String -> Doc
forall a. Pretty a => a -> Doc
pp (SRG -> Maybe String
srgLanguage SRG
srg)
mainCat :: Doc
mainCat = Bool -> String -> [Doc] -> Doc
rule Bool
True String
"MAIN" [String -> Doc
prCat (SRG -> String
srgStartCat SRG
srg)]
prRule :: SRGRule -> Doc
prRule (SRGRule String
cat [SRGAlt]
rhs) = Bool -> String -> [Doc] -> Doc
rule (SRG -> String -> Bool
isExternalCat SRG
srg String
cat) String
cat ((SRGAlt -> Doc) -> [SRGAlt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SRGAlt -> Doc
prAlt [SRGAlt]
rhs)
prAlt :: SRGAlt -> Doc
prAlt (SRGAlt Maybe Double
mp CFTerm
n SRGItem
rhs) = [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep [Doc
initTag, Doc -> Doc
p (Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem Maybe SISRFormat
sisr CFTerm
n SRGItem
rhs), Doc
finalTag]
where initTag :: Doc
initTag | Doc -> Bool
isEmpty Doc
t = Doc
empty
| Bool
otherwise = String
"<NULL>" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Doc
t
where t :: Doc
t = Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Maybe SISRFormat
sisr (CFTerm -> SISRFormat -> SISRTag
profileInitSISR CFTerm
n)
finalTag :: Doc
finalTag = Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Maybe SISRFormat
sisr (CFTerm -> SISRFormat -> SISRTag
profileFinalSISR CFTerm
n)
p :: Doc -> Doc
p = if Doc -> Bool
isEmpty Doc
initTag Bool -> Bool -> Bool
&& Doc -> Bool
isEmpty Doc
finalTag then Doc -> Doc
forall a. a -> a
id else Doc -> Doc
forall a. Pretty a => a -> Doc
parens
prCat :: Cat -> Doc
prCat :: String -> Doc
prCat String
c = Char
'<' Char -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> String
c Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> Char
'>'
prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem Maybe SISRFormat
sisr CFTerm
t = Integer -> SRGItem -> Doc
forall t. (Num t, Ord t) => t -> SRGItem -> Doc
f Integer
0
where
f :: t -> SRGItem -> Doc
f t
_ (REUnion []) = String -> Doc
forall a. Pretty a => a -> Doc
pp String
"<VOID>"
f t
p (REUnion [SRGItem]
xs)
| Bool -> Bool
not ([SRGItem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SRGItem]
es) = Doc -> Doc
forall a. Pretty a => a -> Doc
brackets (t -> SRGItem -> Doc
f t
0 ([SRGItem] -> SRGItem
forall a. [RE a] -> RE a
REUnion [SRGItem]
nes))
| Bool
otherwise = (if t
p t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
1 then Doc -> Doc
forall a. Pretty a => a -> Doc
parens else Doc -> Doc
forall a. a -> a
id) ([Doc] -> Doc
alts ((SRGItem -> Doc) -> [SRGItem] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (t -> SRGItem -> Doc
f t
1) [SRGItem]
xs))
where ([SRGItem]
es,[SRGItem]
nes) = (SRGItem -> Bool) -> [SRGItem] -> ([SRGItem], [SRGItem])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition SRGItem -> Bool
forall a. RE a -> Bool
isEpsilon [SRGItem]
xs
f t
_ (REConcat []) = String -> Doc
forall a. Pretty a => a -> Doc
pp String
"<NULL>"
f t
p (REConcat [SRGItem]
xs) = (if t
p t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
3 then Doc -> Doc
forall a. Pretty a => a -> Doc
parens else Doc -> Doc
forall a. a -> a
id) ([Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep ((SRGItem -> Doc) -> [SRGItem] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (t -> SRGItem -> Doc
f t
2) [SRGItem]
xs))
f t
p (RERepeat SRGItem
x) = t -> SRGItem -> Doc
f t
3 SRGItem
x Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> Char
'*'
f t
_ (RESymbol Symbol SRGNT String
s) = Maybe SISRFormat -> CFTerm -> Symbol SRGNT String -> Doc
prSymbol Maybe SISRFormat
sisr CFTerm
t Symbol SRGNT String
s
prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
prSymbol :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT String -> Doc
prSymbol Maybe SISRFormat
sisr CFTerm
cn (NonTerminal n :: SRGNT
n@(String
c,Int
_)) = String -> Doc
prCat String
c Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Maybe SISRFormat
sisr (CFTerm -> SRGNT -> SISRFormat -> SISRTag
catSISR CFTerm
cn SRGNT
n)
prSymbol Maybe SISRFormat
_ CFTerm
cn (Terminal String
t) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPunct String
t = Doc
empty
| Bool
otherwise = String -> Doc
forall a. Pretty a => a -> Doc
pp String
t
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Maybe SISRFormat
Nothing SISRFormat -> SISRTag
_ = Doc
empty
tag (Just SISRFormat
fmt) SISRFormat -> SISRTag
t = case SISRFormat -> SISRTag
t SISRFormat
fmt of
[] -> Doc
empty
SISRTag
ts -> Char
'{' Char -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> (String -> String
e (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ SISRTag -> String
prSISR SISRTag
ts) Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Char
'}'
where e :: String -> String
e [] = []
e (Char
'}':String
xs) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'}'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
e String
xs
e (Char
'\n':String
xs) = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
e ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
xs)
e (Char
x:String
xs) = Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
e String
xs
isPunct :: Char -> Bool
isPunct :: Char -> Bool
isPunct Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"-_.;.,?!"
comment :: String -> Doc
String
s = String
"//" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
s
alts :: [Doc] -> Doc
alts :: [Doc] -> Doc
alts = [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Doc] -> [Doc]
forall a1. Pretty a1 => a1 -> [Doc] -> [Doc]
prepunctuate (String
"| ")
rule :: Bool -> Cat -> [Doc] -> Doc
rule :: Bool -> String -> [Doc] -> Doc
rule Bool
pub String
c [Doc]
xs = Doc
p Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String -> Doc
prCat String
c Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Char
'=' Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Int -> Doc -> Doc
forall a. Pretty a => Int -> a -> Doc
nest Int
2 ([Doc] -> Doc
alts [Doc]
xs) Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Char
';'
where p :: Doc
p = if Bool
pub then String -> Doc
forall a. Pretty a => a -> Doc
pp String
"public" else Doc
empty
emptyLine :: Doc
emptyLine :: Doc
emptyLine = String -> Doc
forall a. Pretty a => a -> Doc
pp String
""
prepunctuate :: a1 -> [Doc] -> [Doc]
prepunctuate a1
_ [] = []
prepunctuate a1
p (Doc
x:[Doc]
xs) = Doc
x Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (a1
p a1 -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<>) [Doc]
xs
($++$) :: Doc -> Doc -> Doc
Doc
x $++$ :: Doc -> Doc -> Doc
$++$ Doc
y = Doc
x Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Doc
emptyLine Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Doc
y