module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
, SRGNT, CFTerm
, ebnfPrinter
, makeNonLeftRecursiveSRG
, makeNonRecursiveSRG
, isExternalCat
, lookupFM_
) where
import GF.Data.Utilities
import GF.Infra.Option
import GF.Grammar.CFG
import GF.Speech.PGFToCFG
import GF.Speech.RegExp
import GF.Speech.CFGToFA
import PGF
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
data SRG = SRG { SRG -> String
srgName :: String
, SRG -> String
srgStartCat :: Cat
, SRG -> Set String
srgExternalCats :: Set Cat
, SRG -> Maybe String
srgLanguage :: Maybe String
, 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)
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
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
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
makeNonRecursiveSRG :: Options
-> PGF
-> CId
-> 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
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
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)
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)))
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) =
case Maybe SISRFormat
sisr of
Just SISRFormat
_ ->
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)