----------------------------------------------------------------------
-- |
-- Module      : SRG
--
-- Representation of, conversion to, and utilities for
-- printing of a general Speech Recognition Grammar.
--
-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
-- categories in the grammar
----------------------------------------------------------------------
module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
                     , SRGNT, CFTerm
                     , ebnfPrinter
                     , makeNonLeftRecursiveSRG
                     , makeNonRecursiveSRG
                     , isExternalCat
                     , lookupFM_
                     ) where

--import GF.Data.Operations
import GF.Data.Utilities
--import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.CFG
import GF.Speech.PGFToCFG
--import GF.Data.Relation
--import GF.Speech.FiniteState
import GF.Speech.RegExp
import GF.Speech.CFGToFA
--import GF.Infra.Option
import PGF

import Data.List
--import Data.Maybe (fromMaybe, maybeToList)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

--import Debug.Trace

data SRG = SRG { SRG -> String
srgName :: String    -- ^ grammar name
               , SRG -> String
srgStartCat :: Cat     -- ^ start category name
               , SRG -> Set String
srgExternalCats :: Set Cat
               , SRG -> Maybe String
srgLanguage :: Maybe String -- ^ The language for which the grammar
                                             --   is intended, e.g. en-UK
               , SRG -> [SRGRule]
srgRules :: [SRGRule]
               }
        deriving (SRG -> SRG -> Bool
(SRG -> SRG -> Bool) -> (SRG -> SRG -> Bool) -> Eq SRG
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SRG -> SRG -> Bool
$c/= :: SRG -> SRG -> Bool
== :: SRG -> SRG -> Bool
$c== :: SRG -> SRG -> Bool
Eq,Int -> SRG -> ShowS
[SRG] -> ShowS
SRG -> String
(Int -> SRG -> ShowS)
-> (SRG -> String) -> ([SRG] -> ShowS) -> Show SRG
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SRG] -> ShowS
$cshowList :: [SRG] -> ShowS
show :: SRG -> String
$cshow :: SRG -> String
showsPrec :: Int -> SRG -> ShowS
$cshowsPrec :: Int -> SRG -> ShowS
Show)

data SRGRule = SRGRule Cat [SRGAlt]
        deriving (SRGRule -> SRGRule -> Bool
(SRGRule -> SRGRule -> Bool)
-> (SRGRule -> SRGRule -> Bool) -> Eq SRGRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SRGRule -> SRGRule -> Bool
$c/= :: SRGRule -> SRGRule -> Bool
== :: SRGRule -> SRGRule -> Bool
$c== :: SRGRule -> SRGRule -> Bool
Eq,Int -> SRGRule -> ShowS
[SRGRule] -> ShowS
SRGRule -> String
(Int -> SRGRule -> ShowS)
-> (SRGRule -> String) -> ([SRGRule] -> ShowS) -> Show SRGRule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SRGRule] -> ShowS
$cshowList :: [SRGRule] -> ShowS
show :: SRGRule -> String
$cshow :: SRGRule -> String
showsPrec :: Int -> SRGRule -> ShowS
$cshowsPrec :: Int -> SRGRule -> ShowS
Show)

-- | maybe a probability, a rule name and an EBNF right-hand side
data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem
        deriving (SRGAlt -> SRGAlt -> Bool
(SRGAlt -> SRGAlt -> Bool)
-> (SRGAlt -> SRGAlt -> Bool) -> Eq SRGAlt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SRGAlt -> SRGAlt -> Bool
$c/= :: SRGAlt -> SRGAlt -> Bool
== :: SRGAlt -> SRGAlt -> Bool
$c== :: SRGAlt -> SRGAlt -> Bool
Eq,Int -> SRGAlt -> ShowS
[SRGAlt] -> ShowS
SRGAlt -> String
(Int -> SRGAlt -> ShowS)
-> (SRGAlt -> String) -> ([SRGAlt] -> ShowS) -> Show SRGAlt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SRGAlt] -> ShowS
$cshowList :: [SRGAlt] -> ShowS
show :: SRGAlt -> String
$cshow :: SRGAlt -> String
showsPrec :: Int -> SRGAlt -> ShowS
$cshowsPrec :: Int -> SRGAlt -> ShowS
Show)

type SRGItem = RE SRGSymbol

type SRGSymbol = Symbol SRGNT Token

-- | An SRG non-terminal. Category name and its number in the profile.
type SRGNT = (Cat, Int)

ebnfPrinter :: Options -> PGF -> CId -> String
ebnfPrinter :: Options -> PGF -> CId -> String
ebnfPrinter Options
opts PGF
pgf CId
cnc = Options -> SRG -> String
prSRG Options
opts (SRG -> String) -> SRG -> String
forall a b. (a -> b) -> a -> b
$ Options -> PGF -> CId -> SRG
makeSRG Options
opts PGF
pgf CId
cnc

-- | Create a compact filtered non-left-recursive SRG.
makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG Options
opts = Options -> PGF -> CId -> SRG
makeSRG Options
opts'
    where
      opts' :: Options
opts' = Options -> CFGTransform -> Bool -> Options
setDefaultCFGTransform Options
opts CFGTransform
CFGNoLR Bool
True

makeSRG :: Options -> PGF -> CId -> SRG
makeSRG :: Options -> PGF -> CId -> SRG
makeSRG Options
opts = (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG CFG -> [SRGRule]
cfgToSRG CFG -> CFG
preprocess
    where
      cfgToSRG :: CFG -> [SRGRule]
cfgToSRG CFG
cfg = [[CFRule] -> SRGRule
cfRulesToSRGRule [CFRule]
rs | (String
_,[CFRule]
rs) <- CFG -> [(String, [CFRule])]
forall c t. Grammar c t -> [(c, [Rule c t])]
allRulesGrouped CFG
cfg]
      preprocess :: CFG -> CFG
preprocess =   Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
CFGMergeIdentical CFG -> CFG
mergeIdentical
                   (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
CFGNoLR CFG -> CFG
removeLeftRecursion
                   (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
CFGRegular CFG -> CFG
makeRegular
                   (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
CFGTopDownFilter CFG -> CFG
forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t
topDownFilter
                   (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
CFGBottomUpFilter CFG -> CFG
forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t
bottomUpFilter
                   (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
CFGRemoveCycles CFG -> CFG
forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t
removeCycles
                   (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
CFGStartCatOnly CFG -> CFG
forall c t. Grammar c t -> Grammar c t
purgeExternalCats

setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
setDefaultCFGTransform Options
opts CFGTransform
t Bool
b = CFGTransform -> Bool -> Options
setCFGTransform CFGTransform
t Bool
b Options -> Options -> Options
`addOptions` Options
opts

maybeTransform :: Options -> CFGTransform -> (CFG -> CFG) -> (CFG -> CFG)
maybeTransform :: Options -> CFGTransform -> (CFG -> CFG) -> CFG -> CFG
maybeTransform Options
opts CFGTransform
t CFG -> CFG
f = if Options -> CFGTransform -> Bool
cfgTransform Options
opts CFGTransform
t then CFG -> CFG
f else CFG -> CFG
forall a. a -> a
id
{-
traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g

stats g = "Categories: " ++ show (countCats g)
          ++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
          ++ ", Rules: " ++ show (countRules g)
-}
makeNonRecursiveSRG :: Options
                    -> PGF
                    -> CId -- ^ Concrete syntax name.
                    -> SRG
makeNonRecursiveSRG :: Options -> PGF -> CId -> SRG
makeNonRecursiveSRG Options
opts = (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG CFG -> [SRGRule]
cfgToSRG CFG -> CFG
forall a. a -> a
id
    where
      cfgToSRG :: CFG -> [SRGRule]
cfgToSRG CFG
cfg = [String -> [SRGAlt] -> SRGRule
SRGRule String
l [Maybe Double -> CFTerm -> SRGItem -> SRGAlt
SRGAlt Maybe Double
forall a. Maybe a
Nothing CFTerm
dummyCFTerm (DFA (Symbol String String) -> SRGItem
dfaToSRGItem DFA (Symbol String String)
dfa)] | (String
l,DFA (Symbol String String)
dfa) <- [(String, DFA (Symbol String String))]
dfas]
          where
            MFA String
_ [(String, DFA (Symbol String String))]
dfas = CFG -> MFA
cfgToMFA CFG
cfg
            dfaToSRGItem :: DFA (Symbol String String) -> SRGItem
dfaToSRGItem = (Symbol String String -> Symbol (String, Int) String)
-> RE (Symbol String String) -> SRGItem
forall a b. (a -> b) -> RE a -> RE b
mapRE Symbol String String -> Symbol (String, Int) String
forall a t'. Symbol a t' -> Symbol (a, Int) t'
dummySRGNT (RE (Symbol String String) -> SRGItem)
-> (DFA (Symbol String String) -> RE (Symbol String String))
-> DFA (Symbol String String)
-> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RE (Symbol String String) -> RE (Symbol String String)
forall a. Ord a => RE a -> RE a
minimizeRE (RE (Symbol String String) -> RE (Symbol String String))
-> (DFA (Symbol String String) -> RE (Symbol String String))
-> DFA (Symbol String String)
-> RE (Symbol String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DFA (Symbol String String) -> RE (Symbol String String)
forall a. Ord a => DFA a -> RE a
dfa2re
            dummyCFTerm :: CFTerm
dummyCFTerm = CId -> CFTerm
CFMeta (String -> CId
mkCId String
"dummy")
            dummySRGNT :: Symbol a t' -> Symbol (a, Int) t'
dummySRGNT = (a -> (a, Int)) -> (t' -> t') -> Symbol a t' -> Symbol (a, Int) t'
forall c c' t t'.
(c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t'
mapSymbol (\a
c -> (a
c,Int
0)) t' -> t'
forall a. a -> a
id

mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG CFG -> [SRGRule]
mkRules CFG -> CFG
preprocess PGF
pgf CId
cnc =
    SRG :: String -> String -> Set String -> Maybe String -> [SRGRule] -> SRG
SRG { srgName :: String
srgName = CId -> String
showCId CId
cnc,
          srgStartCat :: String
srgStartCat = CFG -> String
forall c t. Grammar c t -> c
cfgStartCat CFG
cfg,
          srgExternalCats :: Set String
srgExternalCats = CFG -> Set String
forall c t. Grammar c t -> Set c
cfgExternalCats CFG
cfg,
          srgLanguage :: Maybe String
srgLanguage = PGF -> CId -> Maybe String
languageCode PGF
pgf CId
cnc,
          srgRules :: [SRGRule]
srgRules = CFG -> [SRGRule]
mkRules CFG
cfg }
    where cfg :: CFG
cfg = String -> CFG -> CFG
renameCats (CId -> String
showCId CId
cnc) (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ CFG -> CFG
preprocess (CFG -> CFG) -> CFG -> CFG
forall a b. (a -> b) -> a -> b
$ PGF -> CId -> CFG
pgfToCFG PGF
pgf CId
cnc

-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
--   to C_N where N is an integer.
renameCats :: String -> CFG -> CFG
renameCats :: String -> CFG -> CFG
renameCats String
prefix CFG
cfg = ShowS -> CFG -> CFG
forall c c' t.
(Ord c, Ord c', Ord t) =>
(c -> c') -> Grammar c t -> Grammar c' t
mapCFGCats ShowS
renameCat CFG
cfg
  where renameCat :: ShowS
renameCat String
c | String -> Bool
isExternal String
c = String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_cat"
                    | Bool
otherwise = String -> String -> Map String String -> String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (ShowS
forall a. String -> a
badCat String
c) String
c Map String String
names
        isExternal :: String -> Bool
isExternal String
c = String
c String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` CFG -> Set String
forall c t. Grammar c t -> Set c
cfgExternalCats CFG
cfg
        catsByPrefix :: [(String, [String])]
catsByPrefix = [(String, String)] -> [(String, [String])]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
buildMultiMap [((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'_') String
cat, String
cat) | String
cat <- CFG -> [String]
forall c t. (Ord c, Ord t) => Grammar c t -> [c]
allCats' CFG
cfg, Bool -> Bool
not (String -> Bool
isExternal String
cat)]
        names :: Map String String
names = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
c,String
prefString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"_"String -> ShowS
forall a. [a] -> [a] -> [a]
++Integer -> String
forall a. Show a => a -> String
show Integer
i) | (String
pref,[String]
cs) <- [(String, [String])]
catsByPrefix, (String
c,Integer
i) <- [String] -> [Integer] -> [(String, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
cs [Integer
1..]]
        badCat :: String -> a
badCat String
c = String -> a
forall a. HasCallStack => String -> a
error (String
"GF.Speech.SRG.renameCats: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CFG -> String
prCFG CFG
cfg)

cfRulesToSRGRule :: [CFRule] -> SRGRule
cfRulesToSRGRule :: [CFRule] -> SRGRule
cfRulesToSRGRule rs :: [CFRule]
rs@(CFRule
r:[CFRule]
_) = String -> [SRGAlt] -> SRGRule
SRGRule (CFRule -> String
forall c t. Rule c t -> c
ruleLhs CFRule
r) [SRGAlt]
rhs
    where
      alts :: [((CFTerm, Maybe a), [Symbol (String, Int) String])]
alts = [((CFTerm
n,Maybe a
forall a. Maybe a
Nothing),Int -> [Symbol String String] -> [Symbol (String, Int) String]
forall t a t. Num t => t -> [Symbol a t] -> [Symbol (a, t) t]
mkSRGSymbols Int
0 [Symbol String String]
ss) | Rule String
c [Symbol String String]
ss CFTerm
n <- [CFRule]
rs]
      rhs :: [SRGAlt]
rhs = [Maybe Double -> CFTerm -> SRGItem -> SRGAlt
SRGAlt Maybe Double
p CFTerm
n ([[Symbol (String, Int) String]] -> SRGItem
srgItem [[Symbol (String, Int) String]]
sss) | ((CFTerm
n,Maybe Double
p),[[Symbol (String, Int) String]]
sss) <- [((CFTerm, Maybe Double), [Symbol (String, Int) String])]
-> [((CFTerm, Maybe Double), [[Symbol (String, Int) String]])]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
buildMultiMap [((CFTerm, Maybe Double), [Symbol (String, Int) String])]
forall a. [((CFTerm, Maybe a), [Symbol (String, Int) String])]
alts ]

      mkSRGSymbols :: t -> [Symbol a t] -> [Symbol (a, t) t]
mkSRGSymbols t
_ [] = []
      mkSRGSymbols t
i (NonTerminal a
c:[Symbol a t]
ss) = (a, t) -> Symbol (a, t) t
forall c t. c -> Symbol c t
NonTerminal (a
c,t
i) Symbol (a, t) t -> [Symbol (a, t) t] -> [Symbol (a, t) t]
forall a. a -> [a] -> [a]
: t -> [Symbol a t] -> [Symbol (a, t) t]
mkSRGSymbols (t
it -> t -> t
forall a. Num a => a -> a -> a
+t
1) [Symbol a t]
ss
      mkSRGSymbols t
i (Terminal t
t:[Symbol a t]
ss)    = t -> Symbol (a, t) t
forall c t. t -> Symbol c t
Terminal t
t Symbol (a, t) t -> [Symbol (a, t) t] -> [Symbol (a, t) t]
forall a. a -> [a] -> [a]
: t -> [Symbol a t] -> [Symbol (a, t) t]
mkSRGSymbols t
i [Symbol a t]
ss

srgLHSCat :: SRGRule -> Cat
srgLHSCat :: SRGRule -> String
srgLHSCat (SRGRule String
c [SRGAlt]
_) = String
c

isExternalCat :: SRG -> Cat -> Bool
isExternalCat :: SRG -> String -> Bool
isExternalCat SRG
srg String
c = String
c String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` SRG -> Set String
srgExternalCats SRG
srg

--
-- * Size-optimized EBNF SRGs
--

srgItem :: [[SRGSymbol]] -> SRGItem
srgItem :: [[Symbol (String, Int) String]] -> SRGItem
srgItem = [SRGItem] -> SRGItem
forall a. Ord a => [RE a] -> RE a
unionRE ([SRGItem] -> SRGItem)
-> ([[Symbol (String, Int) String]] -> [SRGItem])
-> [[Symbol (String, Int) String]]
-> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Symbol (String, Int) String]] -> SRGItem)
-> [[[Symbol (String, Int) String]]] -> [SRGItem]
forall a b. (a -> b) -> [a] -> [b]
map [[Symbol (String, Int) String]] -> SRGItem
mergeItems ([[[Symbol (String, Int) String]]] -> [SRGItem])
-> ([[Symbol (String, Int) String]]
    -> [[[Symbol (String, Int) String]]])
-> [[Symbol (String, Int) String]]
-> [SRGItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Symbol (String, Int) String]
 -> [Symbol (String, Int) String] -> Ordering)
-> [[Symbol (String, Int) String]]
-> [[[Symbol (String, Int) String]]]
forall a. (a -> a -> Ordering) -> [a] -> [[a]]
sortGroupBy (([Symbol (String, Int) String] -> [(String, Int)])
-> [Symbol (String, Int) String]
-> [Symbol (String, Int) String]
-> Ordering
forall b a. Ord b => (a -> b) -> a -> a -> Ordering
compareBy [Symbol (String, Int) String] -> [(String, Int)]
forall c t. [Symbol c t] -> [c]
filterCats)
-- non-optimizing version:
--srgItem = unionRE . map seqRE

-- | Merges a list of right-hand sides which all have the same
-- sequence of non-terminals.
mergeItems :: [[SRGSymbol]] -> SRGItem
mergeItems :: [[Symbol (String, Int) String]] -> SRGItem
mergeItems = SRGItem -> SRGItem
forall a. Ord a => RE a -> RE a
minimizeRE (SRGItem -> SRGItem)
-> ([[Symbol (String, Int) String]] -> SRGItem)
-> [[Symbol (String, Int) String]]
-> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RE (Symbol (String, Int) [String]) -> SRGItem
ungroupTokens (RE (Symbol (String, Int) [String]) -> SRGItem)
-> ([[Symbol (String, Int) String]]
    -> RE (Symbol (String, Int) [String]))
-> [[Symbol (String, Int) String]]
-> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RE (Symbol (String, Int) [String])
-> RE (Symbol (String, Int) [String])
forall a. Ord a => RE a -> RE a
minimizeRE (RE (Symbol (String, Int) [String])
 -> RE (Symbol (String, Int) [String]))
-> ([[Symbol (String, Int) String]]
    -> RE (Symbol (String, Int) [String]))
-> [[Symbol (String, Int) String]]
-> RE (Symbol (String, Int) [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RE (Symbol (String, Int) [String])]
-> RE (Symbol (String, Int) [String])
forall a. Ord a => [RE a] -> RE a
unionRE ([RE (Symbol (String, Int) [String])]
 -> RE (Symbol (String, Int) [String]))
-> ([[Symbol (String, Int) String]]
    -> [RE (Symbol (String, Int) [String])])
-> [[Symbol (String, Int) String]]
-> RE (Symbol (String, Int) [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Symbol (String, Int) [String]]
 -> RE (Symbol (String, Int) [String]))
-> [[Symbol (String, Int) [String]]]
-> [RE (Symbol (String, Int) [String])]
forall a b. (a -> b) -> [a] -> [b]
map [Symbol (String, Int) [String]]
-> RE (Symbol (String, Int) [String])
forall a. [a] -> RE a
seqRE ([[Symbol (String, Int) [String]]]
 -> [RE (Symbol (String, Int) [String])])
-> ([[Symbol (String, Int) String]]
    -> [[Symbol (String, Int) [String]]])
-> [[Symbol (String, Int) String]]
-> [RE (Symbol (String, Int) [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Symbol (String, Int) String] -> [Symbol (String, Int) [String]])
-> [[Symbol (String, Int) String]]
-> [[Symbol (String, Int) [String]]]
forall a b. (a -> b) -> [a] -> [b]
map [Symbol (String, Int) String] -> [Symbol (String, Int) [String]]
groupTokens

groupTokens :: [SRGSymbol] -> [Symbol SRGNT [Token]]
groupTokens :: [Symbol (String, Int) String] -> [Symbol (String, Int) [String]]
groupTokens [] = []
groupTokens (Terminal String
t:[Symbol (String, Int) String]
ss) = case [Symbol (String, Int) String] -> [Symbol (String, Int) [String]]
groupTokens [Symbol (String, Int) String]
ss of
                                Terminal [String]
ts:[Symbol (String, Int) [String]]
ss' -> [String] -> Symbol (String, Int) [String]
forall c t. t -> Symbol c t
Terminal (String
tString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ts)Symbol (String, Int) [String]
-> [Symbol (String, Int) [String]]
-> [Symbol (String, Int) [String]]
forall a. a -> [a] -> [a]
:[Symbol (String, Int) [String]]
ss'
                                [Symbol (String, Int) [String]]
ss'             -> [String] -> Symbol (String, Int) [String]
forall c t. t -> Symbol c t
Terminal [String
t]Symbol (String, Int) [String]
-> [Symbol (String, Int) [String]]
-> [Symbol (String, Int) [String]]
forall a. a -> [a] -> [a]
:[Symbol (String, Int) [String]]
ss'
groupTokens (NonTerminal (String, Int)
c:[Symbol (String, Int) String]
ss) = (String, Int) -> Symbol (String, Int) [String]
forall c t. c -> Symbol c t
NonTerminal (String, Int)
c Symbol (String, Int) [String]
-> [Symbol (String, Int) [String]]
-> [Symbol (String, Int) [String]]
forall a. a -> [a] -> [a]
: [Symbol (String, Int) String] -> [Symbol (String, Int) [String]]
groupTokens [Symbol (String, Int) String]
ss

ungroupTokens :: RE (Symbol SRGNT [Token]) -> RE SRGSymbol
ungroupTokens :: RE (Symbol (String, Int) [String]) -> SRGItem
ungroupTokens = RE SRGItem -> SRGItem
forall a. RE (RE a) -> RE a
joinRE (RE SRGItem -> SRGItem)
-> (RE (Symbol (String, Int) [String]) -> RE SRGItem)
-> RE (Symbol (String, Int) [String])
-> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol (String, Int) [String] -> SRGItem)
-> RE (Symbol (String, Int) [String]) -> RE SRGItem
forall a b. (a -> b) -> RE a -> RE b
mapRE (((String, Int) -> SRGItem)
-> ([String] -> SRGItem)
-> Symbol (String, Int) [String]
-> SRGItem
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (Symbol (String, Int) String -> SRGItem
forall a. a -> RE a
RESymbol (Symbol (String, Int) String -> SRGItem)
-> ((String, Int) -> Symbol (String, Int) String)
-> (String, Int)
-> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Int) -> Symbol (String, Int) String
forall c t. c -> Symbol c t
NonTerminal) ([SRGItem] -> SRGItem
forall a. [RE a] -> RE a
REConcat ([SRGItem] -> SRGItem)
-> ([String] -> [SRGItem]) -> [String] -> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SRGItem) -> [String] -> [SRGItem]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol (String, Int) String -> SRGItem
forall a. a -> RE a
RESymbol (Symbol (String, Int) String -> SRGItem)
-> (String -> Symbol (String, Int) String) -> String -> SRGItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Symbol (String, Int) String
forall c t. t -> Symbol c t
Terminal)))

--
-- * Utilities for building and printing SRGs
--

prSRG :: Options -> SRG -> String
prSRG :: Options -> SRG -> String
prSRG Options
opts SRG
srg = [(String, String)] -> String
prProductions ([(String, String)] -> String) -> [(String, String)] -> String
forall a b. (a -> b) -> a -> b
$ (SRGRule -> (String, String)) -> [SRGRule] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map SRGRule -> (String, String)
prRule ([SRGRule] -> [(String, String)])
-> [SRGRule] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ [SRGRule]
ext [SRGRule] -> [SRGRule] -> [SRGRule]
forall a. [a] -> [a] -> [a]
++ [SRGRule]
int
    where
      sisr :: Maybe SISRFormat
sisr = (Flags -> Maybe SISRFormat) -> Options -> Maybe SISRFormat
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe SISRFormat
optSISR Options
opts
      ([SRGRule]
ext,[SRGRule]
int) = (SRGRule -> Bool) -> [SRGRule] -> ([SRGRule], [SRGRule])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (SRG -> String -> Bool
isExternalCat SRG
srg (String -> Bool) -> (SRGRule -> String) -> SRGRule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRGRule -> String
srgLHSCat) (SRG -> [SRGRule]
srgRules SRG
srg)
      prRule :: SRGRule -> (String, String)
prRule (SRGRule String
c [SRGAlt]
alts) = (String
c,[String] -> String
unwords (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"|" ((SRGAlt -> [String]) -> [SRGAlt] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SRGAlt -> [String]
prAlt [SRGAlt]
alts)))
      prAlt :: SRGAlt -> [String]
prAlt (SRGAlt Maybe Double
_ CFTerm
t SRGItem
rhs) =
          -- FIXME: hack: we high-jack the --sisr flag to add
          -- a simple lambda calculus format for semantic interpretation
          -- Maybe the --sisr flag should be renamed.
          case Maybe SISRFormat
sisr of
            Just SISRFormat
_  ->
                -- copy tags to each part of a top-level union,
                -- to get simpler output
                case SRGItem
rhs of
                  REUnion [SRGItem]
xs -> (SRGItem -> String) -> [SRGItem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SRGItem -> String
forall b. RE (Symbol (String, b) String) -> String
prOneAlt [SRGItem]
xs
                  SRGItem
_          -> [SRGItem -> String
forall b. RE (Symbol (String, b) String) -> String
prOneAlt SRGItem
rhs]
                where prOneAlt :: RE (Symbol (String, b) String) -> String
prOneAlt RE (Symbol (String, b) String)
a = (Symbol (String, b) String -> String)
-> RE (Symbol (String, b) String) -> String
forall a. (a -> String) -> RE a -> String
prRE Symbol (String, b) String -> String
forall b. Symbol (String, b) String -> String
prSym RE (Symbol (String, b) String)
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" { " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CFTerm -> String
prCFTerm CFTerm
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"
            Maybe SISRFormat
Nothing -> [(Symbol (String, Int) String -> String) -> SRGItem -> String
forall a. (a -> String) -> RE a -> String
prRE Symbol (String, Int) String -> String
forall b. Symbol (String, b) String -> String
prSym SRGItem
rhs]
      prSym :: Symbol (String, b) String -> String
prSym = ((String, b) -> String)
-> ShowS -> Symbol (String, b) String -> String
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (String, b) -> String
forall a b. (a, b) -> a
fst (\String
t -> String
"\""String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\"")

lookupFM_ :: (Ord key, Show key) => Map key elt -> key -> elt
lookupFM_ :: Map key elt -> key -> elt
lookupFM_ Map key elt
fm key
k = elt -> key -> Map key elt -> elt
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault elt
forall a. a
err key
k Map key elt
fm
  where err :: a
err = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Key not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ key -> String
forall a. Show a => a -> String
show key
k
                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\namong " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [key] -> String
forall a. Show a => a -> String
show (Map key elt -> [key]
forall k a. Map k a -> [k]
Map.keys Map key elt
fm)