summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Compile/GFCCtoJS.hs2
-rw-r--r--src/GF/Compile/GenerateFCFG.hs5
-rw-r--r--src/GF/Compile/GeneratePMCFG.hs21
-rw-r--r--src/GF/Data/TrieMap.hs55
-rw-r--r--src/GF/Speech/PGFToCFG.hs10
5 files changed, 80 insertions, 13 deletions
diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs
index 8ca321eaa..6a82d02d9 100644
--- a/src/GF/Compile/GFCCtoJS.hs
+++ b/src/GF/Compile/GFCCtoJS.hs
@@ -129,7 +129,7 @@ lins2js p ls = JS.EArray [JS.EArray [sym2js s | s <- Array.elems (sequences p Ar
sym2js :: FSymbol -> JS.Expr
sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
sym2js (FSymLit n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
-sym2js (FSymTok (KS t)) = new "Terminal" [JS.EStr t]
+sym2js (FSymKS [t]) = new "Terminal" [JS.EStr t]
new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs
diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs
index 7597e71dd..096572659 100644
--- a/src/GF/Compile/GenerateFCFG.hs
+++ b/src/GF/Compile/GenerateFCFG.hs
@@ -158,7 +158,10 @@ translateLin idxArgs ((lbl,syms) : lins) grammarEnv lbl'
| lbl' == lbl = addFSeq grammarEnv (lbl,map instSym syms)
| otherwise = translateLin idxArgs lins grammarEnv lbl'
where
- instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok
+ instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs)
+ (\t -> case t of
+ KS s -> FSymKS [s]
+ KP strs vars -> FSymKP strs vars)
instCat lbl nr xnr nr' ((idx,xargs):idxArgs)
| nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr
in FSymCat (nr'+xnr) (index lbl rcs 0)
diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs
index 667b403b5..ab79f9b30 100644
--- a/src/GF/Compile/GeneratePMCFG.hs
+++ b/src/GF/Compile/GeneratePMCFG.hs
@@ -213,10 +213,22 @@ addSequences' env (Return v) = let (env1,v1) = addSequences env v
addSequences :: GrammarEnv -> Value [FSymbol] -> (GrammarEnv, Value SeqId)
addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs
in (env1,Rec vs1)
-addSequences env (Str lin) = let (env1,seqid) = addFSeq env lin
+addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
in (env1,Str seqid)
addSequences env (Con i) = (env,Con i)
+
+optimizeLin [] = []
+optimizeLin lin@(FSymKS _ : _) =
+ let (ts,lin') = getRest lin
+ in FSymKS ts : optimizeLin lin'
+ where
+ getRest (FSymKS ts : lin) = let (ts1,lin') = getRest lin
+ in (ts++ts1,lin')
+ getRest lin = ([],lin)
+optimizeLin (sym : lin) = sym : optimizeLin lin
+
+
convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [FSymbol])
convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel)
convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel)
@@ -227,11 +239,8 @@ convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars
convertTerm cnc_defs sel ctype term
convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts
return (Str (concat [s | Str s <- vs]))
---convertTerm cnc_defs sel ctype (K t) = return (Str [FSymTok t])
-convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymTok (KS t)])
-convertTerm cnc_defs sel ctype (K (KP strs vars)) =
- do toks <- variants (strs:[strs' | Alt strs' _ <- vars])
- return (Str (map (FSymTok . KS) toks))
+convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymKS [t]])
+convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v])
convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of
Just term -> convertTerm cnc_defs sel ctype term
Nothing -> error ("unknown id " ++ prCId id)
diff --git a/src/GF/Data/TrieMap.hs b/src/GF/Data/TrieMap.hs
new file mode 100644
index 000000000..37c56fc3a
--- /dev/null
+++ b/src/GF/Data/TrieMap.hs
@@ -0,0 +1,55 @@
+module GF.Data.TrieMap
+ ( TrieMap
+
+ , empty
+ , singleton
+
+ , lookup
+
+ , null
+ , decompose
+
+ , insertWith
+
+ , unionWith
+ ) where
+
+import Prelude hiding (lookup, null)
+import qualified Data.Map as Map
+
+data TrieMap k v = Tr (Maybe v) (Map.Map k (TrieMap k v))
+
+empty = Tr Nothing Map.empty
+
+singleton :: [k] -> a -> TrieMap k a
+singleton [] v = Tr (Just v) Map.empty
+singleton (k:ks) v = Tr Nothing (Map.singleton k (singleton ks v))
+
+lookup :: Ord k => [k] -> TrieMap k a -> Maybe a
+lookup [] (Tr mb_v m) = mb_v
+lookup (k:ks) (Tr mb_v m) = Map.lookup k m >>= lookup ks
+
+null :: TrieMap k v -> Bool
+null (Tr Nothing m) = Map.null m
+null _ = False
+
+decompose :: TrieMap k v -> (Maybe v, Map.Map k (TrieMap k v))
+decompose (Tr mb_v m) = (mb_v,m)
+
+insertWith :: Ord k => (v -> v -> v) -> [k] -> v -> TrieMap k v -> TrieMap k v
+insertWith f [] v0 (Tr mb_v m) = case mb_v of
+ Just v -> Tr (Just (f v0 v)) m
+ Nothing -> Tr (Just v0 ) m
+insertWith f (k:ks) v0 (Tr mb_v m) = case Map.lookup k m of
+ Nothing -> Tr mb_v (Map.insert k (singleton ks v0) m)
+ Just tr -> Tr mb_v (Map.insert k (insertWith f ks v0 tr) m)
+
+unionWith :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v
+unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) =
+ let mb_v = case (mb_v1,mb_v2) of
+ (Nothing,Nothing) -> Nothing
+ (Just v ,Nothing) -> Just v
+ (Nothing,Just v ) -> Just v
+ (Just v1,Just v2) -> Just (f v1 v2)
+ m = Map.unionWith (unionWith f) m1 m2
+ in Tr mb_v m
diff --git a/src/GF/Speech/PGFToCFG.hs b/src/GF/Speech/PGFToCFG.hs
index ef7f1f868..772ae90c1 100644
--- a/src/GF/Speech/PGFToCFG.hs
+++ b/src/GF/Speech/PGFToCFG.hs
@@ -82,17 +82,17 @@ pgfToCFG pgf lang = mkCFG (prCId (lookStartCat pgf)) extCats (startRules ++ conc
FFun f ps rhs = functions pinfo ! funid
mkRhs :: Array FPointPos FSymbol -> [CFSymbol]
- mkRhs = map fsymbolToSymbol . Array.elems
+ mkRhs = concatMap fsymbolToSymbol . Array.elems
containsLiterals :: Array FPointPos FSymbol -> Bool
containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] ||
not (null [n | FSymLit n _ <- Array.elems row]) -- only this is needed for PMCFG.
-- The first line is for backward compat.
- fsymbolToSymbol :: FSymbol -> CFSymbol
- fsymbolToSymbol (FSymCat n l) = NonTerminal (fcatToCat (args!!n) l)
- fsymbolToSymbol (FSymLit n l) = NonTerminal (fcatToCat (args!!n) l)
- fsymbolToSymbol (FSymTok (KS t)) = Terminal t
+ fsymbolToSymbol :: FSymbol -> [CFSymbol]
+ fsymbolToSymbol (FSymCat n l) = [NonTerminal (fcatToCat (args!!n) l)]
+ fsymbolToSymbol (FSymLit n l) = [NonTerminal (fcatToCat (args!!n) l)]
+ fsymbolToSymbol (FSymKS ts) = map Terminal ts
fixProfile :: Array FPointPos FSymbol -> Profile -> Profile
fixProfile row = concatMap positions
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 13:35:51 +0000