----------------------------------------------------------------------
-- |
-- Module      : GF.Speech.JSGF
--
-- 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.JSGF (jsgfPrinter) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint

--import GF.Data.Utilities
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 Data.Maybe
import GF.Text.Pretty
--import Debug.Trace

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  -- removes punctuation
                           | Bool
otherwise = String -> Doc
forall a. Pretty a => a -> Doc
pp String
t -- FIXME: quote if there is whitespace or odd chars

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
comment :: String -> Doc
comment 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

-- Pretty-printing utilities

emptyLine :: Doc
emptyLine :: Doc
emptyLine = String -> Doc
forall a. Pretty a => a -> Doc
pp String
""

--prepunctuate :: Doc -> [Doc] -> [Doc]
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