completely phrase based parser and support for pre {} in PMCFG

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