From f2e52d6f2c2bc90febceebdea0268b40ea37476c Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 7 Jul 2021 09:40:41 +0200 Subject: Replace tabs for whitespace in source code --- src/compiler/GF/Speech/FiniteState.hs | 110 +++++++++++++++++----------------- src/compiler/GF/Speech/GSL.hs | 6 +- src/compiler/GF/Speech/JSGF.hs | 7 +-- src/compiler/GF/Speech/PGFToCFG.hs | 16 ++--- src/compiler/GF/Speech/SRG.hs | 50 ++++++++-------- src/compiler/GF/Speech/SRGS_ABNF.hs | 11 ++-- src/compiler/GF/Speech/SRGS_XML.hs | 24 ++++---- 7 files changed, 111 insertions(+), 113 deletions(-) (limited to 'src/compiler/GF/Speech') 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 "" - 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 -- cgit v1.2.3