From 426bc49a52b4efa0ef0129d713842d8c9abdf0ff Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Fri, 27 Sep 2013 15:09:48 +0000 Subject: a major refactoring in the C and the Haskell runtimes. Note incompatible change in the PGF format!!! The following are the outcomes: - Predef.nonExist is fully supported by both the Haskell and the C runtimes - Predef.BIND is now an internal compiler defined token. For now it behaves just as usual for the Haskell runtime, i.e. it generates &+. However, the special treatment will let us to handle it properly in the C runtime. - This required a major change in the PGF format since both nonExist and BIND may appear inside 'pre' and this was not supported before. --- src/compiler/GF/Compile/Compute/AppPredefined.hs | 2 + src/compiler/GF/Compile/Compute/Predef.hs | 3 +- src/compiler/GF/Compile/Compute/Value.hs | 2 +- src/compiler/GF/Compile/GeneratePMCFG.hs | 48 ++++++++---------------- src/compiler/GF/Compile/PGFtoJS.hs | 8 ++-- src/compiler/GF/Compile/PGFtoProlog.hs | 6 +-- src/compiler/GF/Compile/PGFtoPython.hs | 6 +-- 7 files changed, 32 insertions(+), 43 deletions(-) (limited to 'src/compiler/GF/Compile') diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index 869052e0a..861a74a89 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -84,6 +84,8 @@ primitives = Map.fromList [(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []))) Nothing) , (cNonExist , ResOper (Just (noLoc (mkProd -- Str [] typeStr []))) Nothing) + , (cBIND , ResOper (Just (noLoc (mkProd -- Str + [] typeStr []))) Nothing) ] where fun from to = oper (mkFunType from to) diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs index 11c4002b8..b8b7f7c77 100644 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -78,7 +78,7 @@ predefList = (cError,Error), -- Canonical values: (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int), - (cInts,Ints),(cNonExist,NonExist)] + (cInts,Ints),(cNonExist,NonExist),(cBIND,BIND)] --- add more functions!!! delta f vs = @@ -106,6 +106,7 @@ delta f vs = PFalse -> canonical PTrue -> canonical NonExist-> canonical + BIND -> canonical where canonical = delay delay = return (VApp f vs) -- wrong number of arguments diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs index 7dbaaa193..e72b06778 100644 --- a/src/compiler/GF/Compile/Compute/Value.hs +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -51,5 +51,5 @@ data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper {- | Show | Read | ToStr | MapStr | EqVal -} | Error -- Canonical values below: - | PBool | PFalse | PTrue | Int | Ints | NonExist + | PBool | PFalse | PTrue | Int | Ints | NonExist | BIND deriving (Show,Eq,Ord,Ix,Bounded,Enum) 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 diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index b7b3d5545..5cb01fac4 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -85,10 +85,12 @@ sym2js :: Symbol -> JS.Expr sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l] sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l] sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l] -sym2js (SymKS ts) = new "SymKS" (map JS.EStr ts) -sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)] +sym2js (SymKS t) = new "SymKS" [JS.EStr t] +sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map sym2js ts), JS.EArray (map alt2js alts)] +sym2js SymNE = new "SymNE" [] +sym2js SymBIND = new "SymKS" [JS.EStr "&+"] -alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)] +alt2js (ps,ts) = new "Alt" [JS.EArray (map sym2js ps), JS.EArray (map JS.EStr ts)] new :: String -> [JS.Expr] -> JS.Expr new f xs = JS.ENew (JS.Ident f) xs diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs index de50d86d1..02993ac65 100644 --- a/src/compiler/GF/Compile/PGFtoProlog.hs +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -136,9 +136,9 @@ instance PLPrint Symbol where plp (SymCat n l) = plOper ":" (show n) (show l) plp (SymLit n l) = plTerm "lit" [show n, show l] plp (SymVar n l) = plTerm "var" [show n, show l] - plp (SymKS ts) = prTList "," (map plAtom ts) - plp (SymKP ts alts) = plTerm "pre" [plList (map plAtom ts), plList (map plAlt alts)] - where plAlt (Alt ps ts) = plOper "/" (plList (map plAtom ps)) (plList (map plAtom ts)) + plp (SymKS t) = plAtom t + plp (SymKP ts alts) = plTerm "pre" [plList (map plp ts), plList (map plAlt alts)] + where plAlt (ps,ts) = plOper "/" (plList (map plp ps)) (plList (map plAtom ts)) class PLPrint a where plp :: a -> String diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs index a4268b714..1877f8d70 100644 --- a/src/compiler/GF/Compile/PGFtoPython.hs +++ b/src/compiler/GF/Compile/PGFtoPython.hs @@ -75,9 +75,9 @@ pySymbol :: Symbol -> String pySymbol (SymCat n l) = pyTuple 0 show [n, l] pySymbol (SymLit n l) = pyDict 0 pyStr id [("lit", pyTuple 0 show [n, l])] pySymbol (SymVar n l) = pyDict 0 pyStr id [("var", pyTuple 0 show [n, l])] -pySymbol (SymKS ts) = prTList "," (map pyStr ts) -pySymbol (SymKP ts alts) = pyDict 0 pyStr id [("pre", pyList 0 pyStr ts), ("alts", pyList 0 alt2py alts)] - where alt2py (Alt ps ts) = pyTuple 0 (pyList 0 pyStr) [ps, ts] +pySymbol (SymKS t) = pyStr t +pySymbol (SymKP ts alts) = pyDict 0 pyStr id [("pre", pyList 0 pySymbol ts), ("alts", pyList 0 alt2py alts)] + where alt2py (ps,ts) = pyTuple 0 (pyList 0 pyStr) [map pySymbol ps, ts] ---------------------------------------------------------------------- -- python helpers -- cgit v1.2.3