----------------------------------------------------------------------
-- |
-- Module      : PrJSRGS_ABNF
-- 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.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) 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.SISR as SISR
import GF.Speech.SRG
import GF.Speech.RegExp
import PGF (PGF, CId)

--import Data.Char
import Data.List
import Data.Maybe
import GF.Text.Pretty
--import Debug.Trace

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  -- 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
      -- grr, silly SRGS ABNF does not have an escaping mechanism
      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
"-_.;.,?!"
{-
comment :: String -> Doc
comment s = "//" <+> 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

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
';'

-- 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