module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
import Prelude hiding ((<>))
import GF.Infra.Option
import GF.Grammar.CFG
import GF.Speech.SISR as SISR
import GF.Speech.SRG
import GF.Speech.RegExp
import PGF (PGF, CId)
import Data.List
import Data.Maybe
import GF.Text.Pretty
width :: Int
width :: Int
width = Int
75
srgsAbnfPrinter :: Options
-> PGF -> CId -> String
srgsAbnfPrinter :: Options -> PGF -> CId -> String
srgsAbnfPrinter Options
opts PGF
pgf CId
cnc = Doc -> String
showDoc (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Maybe SISRFormat -> SRG -> Doc
prABNF 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 sisr :: Maybe SISRFormat
sisr = (Flags -> Maybe SISRFormat) -> Options -> Maybe SISRFormat
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe SISRFormat
optSISR Options
opts
srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String
srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String
srgsAbnfNonRecursivePrinter Options
opts PGF
pgf CId
cnc = Doc -> String
showDoc (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Maybe SISRFormat -> SRG -> Doc
prABNF Maybe SISRFormat
forall a. Maybe a
Nothing (SRG -> Doc) -> SRG -> Doc
forall a b. (a -> b) -> a -> b
$ Options -> PGF -> CId -> SRG
makeNonRecursiveSRG Options
opts PGF
pgf CId
cnc
showDoc :: Doc -> String
showDoc = Style -> Doc -> String
forall a. Pretty a => Style -> a -> String
renderStyle (Style
style { lineLength :: Int
lineLength = Int
width })
prABNF :: Maybe SISRFormat -> SRG -> Doc
prABNF :: Maybe SISRFormat -> SRG -> Doc
prABNF Maybe SISRFormat
sisr SRG
srg
= Doc
header 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
"#ABNF 1.0 UTF-8;" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
String -> String -> Doc
meta String
"description" (String
"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 -> String -> Doc
meta String
"generator" String
"Grammatical Framework" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
Doc
language Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Doc
tagFormat Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Doc
mainCat
language :: Doc
language = Doc -> (String -> Doc) -> Maybe String -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\String
l -> String
"language" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
l Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> Char
';') (SRG -> Maybe String
srgLanguage SRG
srg)
tagFormat :: Doc
tagFormat | Maybe SISRFormat -> Bool
forall a. Maybe a -> Bool
isJust Maybe SISRFormat
sisr = String
"tag-format" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"<semantics/1.0>" Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> Char
';'
| Bool
otherwise = Doc
empty
mainCat :: Doc
mainCat = String
"root" String -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String -> Doc
prCat (SRG -> String
srgStartCat SRG
srg) Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> Char
';'
prRule :: SRGRule -> Doc
prRule (SRGRule String
cat [SRGAlt]
alts) = 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]
alts)
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 = 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
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 -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> String
"<0->"
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 -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
x Bool -> Bool -> Bool
|| Char
'}' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
x -> String
"{!{" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
x Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"}!}"
| Bool
otherwise -> String
"{" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
x Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"}"
where x :: String
x = SISRTag -> String
prSISR SISRTag
ts
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
"-_.;.,?!"
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
meta :: String -> String -> Doc
meta :: String -> String -> Doc
meta String
n String
v = String
"meta" String -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String -> String
forall a. Show a => a -> String
show String
n Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"is" Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String -> String
forall a. Show a => a -> String
show String
v Doc -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<> Char
';'
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