diff options
Diffstat (limited to 'src/compiler/GF/Compile/GeneratePMCFG.hs')
| -rw-r--r-- | src/compiler/GF/Compile/GeneratePMCFG.hs | 48 |
1 files changed, 16 insertions, 32 deletions
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 0afa2bd49..9642110bc 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -14,7 +14,7 @@ module GF.Compile.GeneratePMCFG ) where import PGF.CId -import PGF.Data(Alternative(..),CncCat(..),Symbol(..),fidVar) +import PGF.Data(CncCat(..),Symbol(..),fidVar) import GF.Infra.Option import GF.Grammar hiding (Env, mkRecord, mkTable) @@ -376,30 +376,24 @@ convertTerm opts sel ctype (FV vars) = do term <- variants vars convertTerm opts sel ctype (C t1 t2) = do v1 <- convertTerm opts sel ctype t1 v2 <- convertTerm opts sel ctype t2 return (CStr (concat [s | CStr s <- [v1,v2]])) -convertTerm opts sel ctype (K t) = return (CStr [SymKS [t]]) +convertTerm opts sel ctype (K t) = return (CStr [SymKS t]) convertTerm opts sel ctype Empty = return (CStr []) -convertTerm opts sel ctype (Alts s alts) - = return (CStr [SymKP (strings s) [Alt (strings u) (strings v) | (u,v) <- alts]]) - where - strings (K s) = [s] - strings (C u v) = strings u ++ strings v - strings (Strs ss) = concatMap strings ss - strings (EPatt p) = getPatts p - strings Empty = [""] - strings t = bug $ "strings "++show t - - getPatts p = - case p of - PAlt a b -> getPatts a ++ getPatts b - PString s -> [s] - PSeq a b -> [s ++ t | s <- getPatts a, t <- getPatts b] - _ -> ppbug $ hang (text "not valid pattern in pre expression:") - 4 - (ppPatt Unqualified 0 p) +convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil ctype s + alts <- forM alts $ \(u,Strs ps) -> do + CStr u <- convertTerm opts CNil ctype u + ps <- mapM (convertTerm opts CNil ctype) ps + return (u,map unSym ps) + return (CStr [SymKP s alts]) + where + unSym (CStr []) = "" + unSym (CStr [SymKS t]) = t + unSym _ = ppbug $ hang (text "invalid prefix in pre expression:") 4 (ppU 0 (Alts s alts)) convertTerm opts sel ctype (Q (m,f)) | m == cPredef && f == cNonExist = return (CStr [SymNE]) + | m == cPredef && + f == cBIND = return (CStr [SymBIND]) convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2)) | l `elem` map fst rs2 = convertTerm opts sel ctype t2 @@ -492,7 +486,7 @@ addSequencesV seqs (CRec vs) = let !(seqs1,vs1) = mapAccumL' (\seqs (lbl,b) -> addSequencesV seqs (CTbl pt vs)=let !(seqs1,vs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b in (seqs',(trm,b'))) seqs vs in (seqs1,CTbl pt vs1) -addSequencesV seqs (CStr lin) = let !(seqs1,seqid) = addSequence seqs (optimizeLin lin) +addSequencesV seqs (CStr lin) = let !(seqs1,seqid) = addSequence seqs lin in (seqs1,CStr seqid) addSequencesV seqs (CPar i) = (seqs,CPar i) @@ -502,16 +496,6 @@ mapAccumL' f s (x:xs) = (s'',y:ys) where !(s', y ) = f s x !(s'',ys) = mapAccumL' f s' xs -optimizeLin [] = [] -optimizeLin lin@(SymKS _ : _) = - let (ts,lin') = getRest lin - in SymKS ts : optimizeLin lin' - where - getRest (SymKS ts : lin) = let (ts1,lin') = getRest lin - in (ts++ts1,lin') - getRest lin = ([],lin) -optimizeLin (sym : lin) = sym : optimizeLin lin - addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId) addSequence seqs lst = case Map.lookup seq seqs of @@ -629,4 +613,4 @@ mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] bug msg = ppbug (text msg) ppbug = error . render . hang (text "Internal error in GeneratePMCFG:") 4 -ppU = ppTerm Unqualified
\ No newline at end of file +ppU = ppTerm Unqualified |