GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-19 17:59:32 -06:00
Code Issues Packages Projects Releases Wiki Activity

a major refactoring in the C and the Haskell runtimes. Note incompatible change in the PGF format!!!

Browse Source 
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.
This commit is contained in:
kr.angelov
2013-09-27 15:09:48 +00:00
parent 3f65253f0e
commit efa4bc4d62
30 changed files with 332 additions and 372 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

@@ -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)

3
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -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

2
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -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)

48
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -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
ppU = ppTerm Unqualified

8
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -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

6
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -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

6
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -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

1
src/compiler/GF/Grammar/Predef.hs
View File

@@ -30,6 +30,7 @@ cErrorType = identS "Error"
cOverload = identS "overload"
cUndefinedType = identS "UndefinedType"
cNonExist = identS "nonExist"
cBIND = identS "BIND"
isPredefCat :: Ident -> Bool
isPredefCat c = elem c [cInt,cString,cFloat]

4
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -91,8 +91,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
symbolToCFSymbol :: Symbol -> [CFSymbol]
symbolToCFSymbol (SymCat n l) = [let PArg _ fid = args!!n in NonTerminal (fcatToCat fid l)]
symbolToCFSymbol (SymKS ts) = map Terminal ts
symbolToCFSymbol (SymKP ts as) = map Terminal $ ts
symbolToCFSymbol (SymKS t) = [Terminal t]
symbolToCFSymbol (SymKP syms as) = concatMap symbolToCFSymbol syms
---- ++ [t | Alt ss _ <- as, t <- ss]
---- should be alternatives in [[CFSymbol]]
---- AR 3/6/2010