mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-18 07:32:51 -06:00
Merge branch 'master' into c-runtime
This commit is contained in:
krangelov
@@ -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
|
||||
|
||||
@@ -8,6 +8,7 @@
|
||||
|
||||
module GF.Speech.GSL (gslPrinter) where
|
||||
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Grammar.CFG
|
||||
import GF.Speech.SRG
|
||||
import GF.Speech.RegExp
|
||||
@@ -23,14 +24,14 @@ width = 75
|
||||
|
||||
gslPrinter :: Options -> PGF -> Concr -> 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
|
||||
|
||||
@@ -12,7 +12,7 @@
|
||||
|
||||
module GF.Speech.JSGF (jsgfPrinter) where
|
||||
|
||||
--import GF.Data.Utilities
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.CFG
|
||||
import GF.Speech.RegExp
|
||||
@@ -43,7 +43,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)
|
||||
@@ -61,7 +61,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
|
||||
@@ -109,4 +109,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
|
||||
|
||||
($++$) :: Doc -> Doc -> Doc
|
||||
x $++$ y = x $$ emptyLine $$ y
|
||||
|
||||
|
||||
@@ -67,7 +67,7 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
|
||||
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) <- zip [0..] rhs
|
||||
, let row = concrSequence cnc seqid
|
||||
@@ -100,7 +100,7 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
|
||||
fixProfile row i = [k | (k,j) <- nts, j == i]
|
||||
where
|
||||
nts = zip [0..] [j | nt <- row, j <- getPos nt]
|
||||
|
||||
|
||||
getPos (SymCat j _) = [j]
|
||||
getPos (SymLit j _) = [j]
|
||||
getPos _ = []
|
||||
|
||||
@@ -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
|
||||
@@ -34,20 +34,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
|
||||
|
||||
@@ -70,11 +70,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
|
||||
@@ -89,7 +89,7 @@ stats g = "Categories: " ++ show (countCats g)
|
||||
++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
|
||||
++ ", Rules: " ++ show (countRules g)
|
||||
-}
|
||||
makeNonRecursiveSRG :: Options
|
||||
makeNonRecursiveSRG :: Options
|
||||
-> PGF
|
||||
-> Concr
|
||||
-> SRG
|
||||
@@ -111,20 +111,20 @@ mkSRG mkRules preprocess pgf cnc =
|
||||
srgRules = mkRules cfg }
|
||||
where cfg = renameCats (concreteName 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 ]
|
||||
|
||||
@@ -147,7 +147,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
|
||||
@@ -168,16 +168,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
|
||||
|
||||
@@ -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 $
|
||||
--
|
||||
@@ -19,7 +19,7 @@
|
||||
|
||||
module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
|
||||
|
||||
--import GF.Data.Utilities
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar.CFG
|
||||
import GF.Speech.SISR as SISR
|
||||
@@ -34,8 +34,7 @@ import GF.Text.Pretty
|
||||
width :: Int
|
||||
width = 75
|
||||
|
||||
srgsAbnfPrinter :: Options
|
||||
-> PGF -> Concr -> String
|
||||
srgsAbnfPrinter :: Options -> PGF -> Concr -> String
|
||||
srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
|
||||
where sisr = flag optSISR opts
|
||||
|
||||
@@ -69,7 +68,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
|
||||
@@ -81,13 +80,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
|
||||
@@ -122,4 +121,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
|
||||
|
||||
($++$) :: Doc -> Doc -> Doc
|
||||
x $++$ y = x $$ emptyLine $$ y
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user