summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Speech
diff options
context:
space:
mode:
authorJohn J. Camilleri <john@digitalgrammars.com>2021-07-07 09:40:41 +0200
committerJohn J. Camilleri <john@digitalgrammars.com>2021-07-07 09:40:41 +0200
commitf2e52d6f2c2bc90febceebdea0268b40ea37476c (patch)
tree710619761319d65c5d997ec008f57f9253eae5dd /src/compiler/GF/Speech
parenta2b23d5897b4c04b50cd222ce8f215e45a3b6e40 (diff)
Replace tabs for whitespace in source code
Diffstat (limited to 'src/compiler/GF/Speech')
-rw-r--r--src/compiler/GF/Speech/FiniteState.hs110
-rw-r--r--src/compiler/GF/Speech/GSL.hs6
-rw-r--r--src/compiler/GF/Speech/JSGF.hs7
-rw-r--r--src/compiler/GF/Speech/PGFToCFG.hs16
-rw-r--r--src/compiler/GF/Speech/SRG.hs50
-rw-r--r--src/compiler/GF/Speech/SRGS_ABNF.hs11
-rw-r--r--src/compiler/GF/Speech/SRGS_XML.hs24
7 files changed, 111 insertions, 113 deletions
diff --git a/src/compiler/GF/Speech/FiniteState.hs b/src/compiler/GF/Speech/FiniteState.hs
index cb5247755..95acd35c5 100644
--- a/src/compiler/GF/Speech/FiniteState.hs
+++ b/src/compiler/GF/Speech/FiniteState.hs
@@ -5,37 +5,37 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/10 16:43:44 $
+-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
-- A simple finite state network module.
-----------------------------------------------------------------------------
module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
- startState, finalStates,
- states, transitions,
+ startState, finalStates,
+ states, transitions,
isInternal,
- newFA, newFA_,
- addFinalState,
- newState, newStates,
+ newFA, newFA_,
+ addFinalState,
+ newState, newStates,
newTransition, newTransitions,
insertTransitionWith, insertTransitionsWith,
- mapStates, mapTransitions,
+ mapStates, mapTransitions,
modifyTransitions,
- nonLoopTransitionsTo, nonLoopTransitionsFrom,
+ nonLoopTransitionsTo, nonLoopTransitionsFrom,
loops,
removeState,
oneFinalState,
insertNFA,
onGraph,
- moveLabelsToNodes, removeTrivialEmptyNodes,
+ moveLabelsToNodes, removeTrivialEmptyNodes,
minimize,
dfa2nfa,
unusedNames, renameStates,
- prFAGraphviz, faToGraphviz) where
+ prFAGraphviz, faToGraphviz) where
import Data.List
-import Data.Maybe
+import Data.Maybe
--import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l))
newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
newTransitions es = onGraph (newEdges es)
-insertTransitionWith :: Eq n =>
+insertTransitionWith :: Eq n =>
(b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
insertTransitionWith f t = onGraph (insertEdgeWith f t)
-insertTransitionsWith :: Eq n =>
+insertTransitionsWith :: Eq n =>
(b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
-insertTransitionsWith f ts fa =
+insertTransitionsWith f ts fa =
foldl' (flip (insertTransitionWith f)) fa ts
mapStates :: (a -> c) -> FA n a b -> FA n c b
@@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names
-- | Gets all incoming transitions to a given state, excluding
-- transtions from the state itself.
nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsTo s fa =
+nonLoopTransitionsTo s fa =
[(f,l) | (f,t,l) <- transitions fa, t == s && f /= s]
nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsFrom s fa =
+nonLoopTransitionsFrom s fa =
[(t,l) | (f,t,l) <- transitions fa, f == s && t /= s]
loops :: Eq n => n -> FA n a b -> [b]
@@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names
renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
where (ns,rest) = splitAt (length (nodes g)) supply
newNodes = Map.fromList (zip (map fst (nodes g)) ns)
- newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
+ newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
s' = newName s
fs' = map newName fs
@@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into
-> (State, State) -- ^ States to insert between
-> NFA a -- ^ NFA to insert.
-> NFA a
-insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
+insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
= FA (newEdges es g') s1 fs1
- where
+ where
es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
(g',ren) = mergeGraphs g1 g2
@@ -182,9 +182,9 @@ oneFinalState nl el fa =
moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
moveLabelsToNodes = onGraph f
where f g@(Graph c _ _) = Graph c' ns (concat ess)
- where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
- (c',is') = mapAccumL fixIncoming c is
- (ns,ess) = unzip (concat is')
+ where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
+ (c',is') = mapAccumL fixIncoming c is
+ (ns,ess) = unzip (concat is')
-- | Remove empty nodes which are not start or final, and have
@@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
-- This is not done if the pointed-to node is a final node.
skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
skipSimpleEmptyNodes fa = onGraph og fa
- where
+ where
og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es')
where
es' = concatMap changeEdge es
info = nodeInfo g
- changeEdge e@(f,t,())
+ changeEdge e@(f,t,())
| isNothing (getNodeLabel info t)
-- && (i * o <= i + o)
&& not (isFinal fa t)
@@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa
where
f g = if Set.null rns then g else f (removeNodes rns g)
where info = nodeInfo g
- rns = Set.fromList [ n | (n,_) <- nodes g,
+ rns = Set.fromList [ n | (n,_) <- nodes g,
isInternal fa n,
- inDegree info n == 0
+ inDegree info n == 0
|| outDegree info n == 0]
-fixIncoming :: (Ord n, Eq a) => [n]
+fixIncoming :: (Ord n, Eq a) => [n]
-> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
-> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
-- incoming edges.
fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
where ls = nub $ map edgeLabel es
- (cs',cs'') = splitAt (length ls) cs
- newNodes = zip cs' ls
- es' = [ (x,n,()) | x <- map fst newNodes ]
- -- separate cyclic and non-cyclic edges
- (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
- -- keep all incoming non-cyclic edges with the right label
- to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
- -- for each cyclic edge with the right label,
- -- add an edge from each of the new nodes (including this one)
- ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
- newContexts = [ (v, to v) | v <- newNodes ]
+ (cs',cs'') = splitAt (length ls) cs
+ newNodes = zip cs' ls
+ es' = [ (x,n,()) | x <- map fst newNodes ]
+ -- separate cyclic and non-cyclic edges
+ (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
+ -- keep all incoming non-cyclic edges with the right label
+ to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
+ -- for each cyclic edge with the right label,
+ -- add an edge from each of the new nodes (including this one)
+ ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
+ newContexts = [ (v, to v) | v <- newNodes ]
--alphabet :: Eq b => Graph n a (Maybe b) -> [b]
--alphabet = nub . catMaybes . map edgeLabel . edges
@@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
(ns',es') = (Set.toList ns, Set.toList es)
final = filter isDFAFinal ns'
fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
- in renameStates [0..] fa
+ in renameStates [0..] fa
where info = nodeInfo g
-- reach = nodesReachable out
- start = closure info $ Set.singleton s
+ start = closure info $ Set.singleton s
isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
- h currentStates oldStates es
- | Set.null currentStates = (oldStates,es)
- | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
- where
- allOldStates = oldStates `Set.union` currentStates
+ h currentStates oldStates es
+ | Set.null currentStates = (oldStates,es)
+ | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
+ where
+ allOldStates = oldStates `Set.union` currentStates
(newStates,es') = new (Set.toList currentStates) Set.empty es
- uniqueNewStates = newStates Set.\\ allOldStates
- -- Get the sets of states reachable from the given states
+ uniqueNewStates = newStates Set.\\ allOldStates
+ -- Get the sets of states reachable from the given states
-- by consuming one symbol, and the associated edges.
new [] rs es = (rs,es)
new (n:ns) rs es = new ns rs' es'
@@ -281,7 +281,7 @@ closure info x = closure_ x x
where closure_ acc check | Set.null check = acc
| otherwise = closure_ acc' check'
where
- reach = Set.fromList [y | x <- Set.toList check,
+ reach = Set.fromList [y | x <- Set.toList check,
(_,y,Nothing) <- getOutgoing info x]
acc' = acc `Set.union` reach
check' = reach Set.\\ acc
@@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,
reverseNFA :: NFA a -> NFA a
reverseNFA (FA g s fs) = FA g''' s' [s]
where g' = reverseGraph g
- (g'',s') = newNode () g'
- g''' = newEdges [(s',f,Nothing) | f <- fs] g''
+ (g'',s') = newNode () g'
+ g''' = newEdges [(s',f,Nothing) | f <- fs] g''
dfa2nfa :: DFA a -> NFA a
dfa2nfa = mapTransitions Just
@@ -313,13 +313,13 @@ prFAGraphviz = Dot.prGraphviz . faToGraphviz
--prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show
faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
-faToGraphviz (FA (Graph _ ns es) s f)
+faToGraphviz (FA (Graph _ ns es) s f)
= Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
where mkNode (n,l) = Dot.Node (show n) attrs
- where attrs = [("label",l)]
- ++ if n == s then [("shape","box")] else []
- ++ if n `elem` f then [("style","bold")] else []
- mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
+ where attrs = [("label",l)]
+ ++ if n == s then [("shape","box")] else []
+ ++ if n `elem` f then [("style","bold")] else []
+ mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
--
-- * Utilities
diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs
index a898a4bb5..ceaf86ae0 100644
--- a/src/compiler/GF/Speech/GSL.hs
+++ b/src/compiler/GF/Speech/GSL.hs
@@ -26,14 +26,14 @@ width = 75
gslPrinter :: Options -> PGF -> CId -> String
gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
- where st = style { lineLength = width }
+ where st = style { lineLength = width }
prGSL :: SRG -> Doc
prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
where
header = ";GSL2.0" $$
- comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
- comment ("Generated by GF")
+ comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
+ comment ("Generated by GF")
mainCat = ".MAIN" <+> prCat (srgStartCat srg)
prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs)
-- FIXME: use the probability
diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs
index 15f5ff69d..b12fb0ace 100644
--- a/src/compiler/GF/Speech/JSGF.hs
+++ b/src/compiler/GF/Speech/JSGF.hs
@@ -31,7 +31,7 @@ width :: Int
width = 75
jsgfPrinter :: Options
- -> PGF
+ -> PGF
-> CId -> String
jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where st = style { lineLength = width }
@@ -44,7 +44,7 @@ prJSGF sisr srg
header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$
comment ("JSGF speech recognition grammar for " ++ srgName srg) $$
comment "Generated by GF" $$
- ("grammar " ++ srgName srg ++ ";")
+ ("grammar " ++ srgName srg ++ ";")
lang = maybe empty pp (srgLanguage srg)
mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs)
@@ -62,7 +62,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0
where
f _ (REUnion []) = pp "<VOID>"
- f p (REUnion xs)
+ f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs
@@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y
-
diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs
index a8ecec27d..fdd8a6c84 100644
--- a/src/compiler/GF/Speech/PGFToCFG.hs
+++ b/src/compiler/GF/Speech/PGFToCFG.hs
@@ -28,7 +28,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
type Profile = [Int]
-pgfToCFG :: PGF
+pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name
-> CFG
pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules)
@@ -40,8 +40,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
, prod <- Set.toList set]
fcatCats :: Map FId Cat
- fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
- | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
+ fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
+ | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
(fc,i) <- zip (range (s,e)) [1..]]
fcatCat :: FId -> Cat
@@ -58,7 +58,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
topdownRules cat = f cat []
where
f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc))
-
+
g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
g (PCoerce cat) rules = f cat rules
@@ -67,13 +67,13 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
extCats = Set.fromList $ map ruleLhs startRules
startRules :: [CFRule]
- startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
- | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
+ startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
+ | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
fc <- range (s,e), not (isPredefFId fc),
r <- [0..catLinArity fc-1]]
ruleToCFRule :: (FId,Production) -> [CFRule]
- ruleToCFRule (c,PApply funid args) =
+ ruleToCFRule (c,PApply funid args) =
[Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
| (l,seqid) <- Array.assocs rhs
, let row = sequences cnc ! seqid
@@ -106,7 +106,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
fixProfile row i = [k | (k,j) <- nts, j == i]
where
nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
-
+
getPos (SymCat j _) = [j]
getPos (SymLit j _) = [j]
getPos _ = []
diff --git a/src/compiler/GF/Speech/SRG.hs b/src/compiler/GF/Speech/SRG.hs
index 9d51e52e9..b761c45cd 100644
--- a/src/compiler/GF/Speech/SRG.hs
+++ b/src/compiler/GF/Speech/SRG.hs
@@ -2,8 +2,8 @@
-- |
-- Module : SRG
--
--- Representation of, conversion to, and utilities for
--- printing of a general Speech Recognition Grammar.
+-- 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
@@ -40,20 +40,20 @@ import qualified Data.Set as Set
--import Debug.Trace
data SRG = SRG { srgName :: String -- ^ grammar name
- , srgStartCat :: Cat -- ^ start category name
- , srgExternalCats :: Set Cat
- , srgLanguage :: Maybe String -- ^ The language for which the grammar
- -- is intended, e.g. en-UK
- , srgRules :: [SRGRule]
- }
- deriving (Eq,Show)
+ , srgStartCat :: Cat -- ^ start category name
+ , srgExternalCats :: Set Cat
+ , srgLanguage :: Maybe String -- ^ The language for which the grammar
+ -- is intended, e.g. en-UK
+ , srgRules :: [SRGRule]
+ }
+ deriving (Eq,Show)
data SRGRule = SRGRule Cat [SRGAlt]
- deriving (Eq,Show)
+ deriving (Eq,Show)
-- | maybe a probability, a rule name and an EBNF right-hand side
data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem
- deriving (Eq,Show)
+ deriving (Eq,Show)
type SRGItem = RE SRGSymbol
@@ -65,7 +65,7 @@ type SRGNT = (Cat, Int)
ebnfPrinter :: Options -> PGF -> CId -> String
ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
--- | Create a compact filtered non-left-recursive SRG.
+-- | Create a compact filtered non-left-recursive SRG.
makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG opts = makeSRG opts'
where
@@ -76,11 +76,11 @@ makeSRG opts = mkSRG cfgToSRG preprocess
where
cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
preprocess = maybeTransform opts CFGMergeIdentical mergeIdentical
- . maybeTransform opts CFGNoLR removeLeftRecursion
+ . maybeTransform opts CFGNoLR removeLeftRecursion
. maybeTransform opts CFGRegular makeRegular
. maybeTransform opts CFGTopDownFilter topDownFilter
. maybeTransform opts CFGBottomUpFilter bottomUpFilter
- . maybeTransform opts CFGRemoveCycles removeCycles
+ . maybeTransform opts CFGRemoveCycles removeCycles
. maybeTransform opts CFGStartCatOnly purgeExternalCats
setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
@@ -95,7 +95,7 @@ stats g = "Categories: " ++ show (countCats g)
++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
++ ", Rules: " ++ show (countRules g)
-}
-makeNonRecursiveSRG :: Options
+makeNonRecursiveSRG :: Options
-> PGF
-> CId -- ^ Concrete syntax name.
-> SRG
@@ -111,26 +111,26 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG mkRules preprocess pgf cnc =
SRG { srgName = showCId cnc,
- srgStartCat = cfgStartCat cfg,
+ srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg,
srgLanguage = languageCode pgf cnc,
- srgRules = mkRules cfg }
+ srgRules = mkRules cfg }
where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
--- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
+-- | 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 prefix cfg = mapCFGCats renameCat cfg
where renameCat c | isExternal c = c ++ "_cat"
| otherwise = Map.findWithDefault (badCat c) c names
- isExternal c = c `Set.member` cfgExternalCats cfg
+ isExternal c = c `Set.member` cfgExternalCats cfg
catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)]
names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]]
badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg)
cfRulesToSRGRule :: [CFRule] -> SRGRule
cfRulesToSRGRule rs@(r:_) = SRGRule (ruleLhs r) rhs
- where
+ where
alts = [((n,Nothing),mkSRGSymbols 0 ss) | Rule c ss n <- rs]
rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ]
@@ -153,7 +153,7 @@ srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats)
-- non-optimizing version:
--srgItem = unionRE . map seqRE
--- | Merges a list of right-hand sides which all have the same
+-- | Merges a list of right-hand sides which all have the same
-- sequence of non-terminals.
mergeItems :: [[SRGSymbol]] -> SRGItem
mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens
@@ -174,16 +174,16 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map
prSRG :: Options -> SRG -> String
prSRG opts srg = prProductions $ map prRule $ ext ++ int
- where
+ where
sisr = flag optSISR opts
(ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg)
prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts)))
- prAlt (SRGAlt _ t rhs) =
- -- FIXME: hack: we high-jack the --sisr flag to add
+ prAlt (SRGAlt _ t 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 sisr of
- Just _ ->
+ Just _ ->
-- copy tags to each part of a top-level union,
-- to get simpler output
case rhs of
diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs
index dc5c7bbd3..3db8fe7c2 100644
--- a/src/compiler/GF/Speech/SRGS_ABNF.hs
+++ b/src/compiler/GF/Speech/SRGS_ABNF.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/01 20:09:04 $
+-- > CVS $Date: 2005/11/01 20:09:04 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
@@ -38,7 +38,7 @@ width :: Int
width = 75
srgsAbnfPrinter :: Options
- -> PGF -> CId -> String
+ -> PGF -> CId -> String
srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where sisr = flag optSISR opts
@@ -72,7 +72,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0
where
f _ (REUnion []) = pp "$VOID"
- f p (REUnion xs)
+ f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs
@@ -84,13 +84,13 @@ prItem sisr t = f 0
prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
-prSymbol _ cn (Terminal t)
+prSymbol _ cn (Terminal t)
| all isPunct t = empty -- removes punctuation
| otherwise = pp t -- FIXME: quote if there is whitespace or odd chars
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Nothing _ = empty
-tag (Just fmt) t =
+tag (Just fmt) t =
case t fmt of
[] -> empty
-- grr, silly SRGS ABNF does not have an escaping mechanism
@@ -125,4 +125,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y
-
diff --git a/src/compiler/GF/Speech/SRGS_XML.hs b/src/compiler/GF/Speech/SRGS_XML.hs
index 397bfb739..17d8eec5c 100644
--- a/src/compiler/GF/Speech/SRGS_XML.hs
+++ b/src/compiler/GF/Speech/SRGS_XML.hs
@@ -34,13 +34,13 @@ prSrgsXml :: Maybe SISRFormat -> SRG -> String
prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
where
xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
- [meta "description"
+ [meta "description"
("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
meta "generator" "Grammatical Framework"]
- ++ map ruleToXML (srgRules srg)
+ ++ map ruleToXML (srgRules srg)
ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
where pub = if isExternalCat srg cat then [("scope","public")] else []
- prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
+ prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
@@ -50,9 +50,9 @@ mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem sisr cn = f
- where
+ where
f (REUnion []) = ETag "ruleref" [("special","VOID")]
- f (REUnion xs)
+ f (REUnion xs)
| not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
| otherwise = oneOf (map f xs)
where (es,nes) = partition isEpsilon xs
@@ -62,7 +62,7 @@ mkItem sisr cn = f
f (RESymbol s) = symItem sisr cn s
symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
-symItem sisr cn (NonTerminal n@(c,_)) =
+symItem sisr cn (NonTerminal n@(c,_)) =
Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]
@@ -81,12 +81,12 @@ oneOf = Tag "one-of" []
grammar :: Maybe SISRFormat
-> String -- ^ root
-> Maybe String -- ^language
- -> [XML] -> XML
-grammar sisr root ml =
+ -> [XML] -> XML
+grammar sisr root ml =
Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
- ("version","1.0"),
- ("mode","voice"),
- ("root",root)]
+ ("version","1.0"),
+ ("mode","voice"),
+ ("root",root)]
++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
++ maybe [] (\l -> [("xml:lang", l)]) ml
@@ -94,7 +94,7 @@ meta :: String -> String -> XML
meta n c = ETag "meta" [("name",n),("content",c)]
optimizeSRGS :: XML -> XML
-optimizeSRGS = bottomUpXML f
+optimizeSRGS = bottomUpXML f
where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs