Yay!! Direct generation of PMCFG from GF grammar

src/compiler/GF/Grammar/Grammar.hs

@@ -119,7 +119,7 @@ data Term =
  | Cn Ident                      -- ^ constant
  | Con Ident                     -- ^ constructor
  | Sort Ident                    -- ^ basic type
- | EInt Integer                  -- ^ integer literal
+ | EInt Int                      -- ^ integer literal
  | EFloat Double                 -- ^ floating point literal
  | K String                      -- ^ string literal or token: @\"foo\"@
  | Empty                         -- ^ the empty string @[]@
@@ -171,7 +171,7 @@ data Patt =
  | PW                     -- ^ wild card pattern: @_@
  | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@  -- only concrete
  | PString String         -- ^ string literal pattern: @\"foo\"@  -- only abstract
- | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
+ | PInt    Int            -- ^ integer literal pattern: @12@    -- only abstract
  | PFloat Double          -- ^ float literal pattern: @1.2@    -- only abstract
  | PT Type Patt           -- ^ type-annotated pattern
 

src/compiler/GF/Grammar/Lexer.x

@@ -112,7 +112,7 @@ data Token
  | T_where
  | T_with
  | T_String  String          -- string literals
- | T_Integer Integer         -- integer literals
+ | T_Integer Int             -- integer literals
  | T_Double  Double          -- double precision float literals
  | T_LString String
  | T_Ident   Ident

src/compiler/GF/Grammar/Macros.hs

@@ -166,6 +166,12 @@ unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
 mkAssign :: [(Label,Term)] -> [Assign]
 mkAssign lts = [assign l t | (l,t) <- lts]
 
+projectRec :: Label -> [Assign] -> Term
+projectRec l rs =
+  case lookup l rs of
+    Just (_,t) -> t
+    Nothing    -> error (render (text "no value for label" <+> ppLabel l))
+
 zipAssign :: [Label] -> [Term] -> [Assign]
 zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
 
@@ -199,7 +205,7 @@ typeTok   = Sort cTok
 typeStrs  = Sort cStrs
 
 typeString, typeFloat, typeInt :: Term
-typeInts :: Integer -> Term
+typeInts :: Int -> Term
 typePBool :: Term
 typeError :: Term
 
@@ -210,7 +216,7 @@ typeInts i = App (cnPredef cInts) (EInt i)
 typePBool = cnPredef cPBool
 typeError = cnPredef cErrorType
 
-isTypeInts :: Term -> Maybe Integer
+isTypeInts :: Term -> Maybe Int
 isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
 isTypeInts _                                      = Nothing
 
@@ -299,7 +305,7 @@ freshAsTerm s = Vr (varX (readIntArg s))
 string2term :: String -> Term
 string2term = K
 
-int2term :: Integer -> Term
+int2term :: Int -> Term
 int2term = EInt
 
 float2term :: Double -> Term

src/compiler/GF/Grammar/Predef.hs

@@ -19,6 +19,7 @@ module GF.Grammar.Predef
           , cInt
           , cFloat
           , cString
+          , cVar
           , cInts
           , cPBool
           , cErrorType
@@ -73,6 +74,9 @@ cFloat = identC (BS.pack "Float")
 cString :: Ident
 cString = identC (BS.pack "String")
 
+cVar :: Ident
+cVar = identC (BS.pack "__gfVar")
+
 cInts :: Ident
 cInts = identC (BS.pack "Ints")
 
@@ -89,7 +93,7 @@ cUndefinedType :: Ident
 cUndefinedType = identC (BS.pack "UndefinedType")
 
 isLiteralCat :: Ident -> Bool
-isLiteralCat c = elem c [cInt,cString,cFloat]
+isLiteralCat c = elem c [cInt,cString,cFloat,cVar]
 
 cPTrue :: Ident
 cPTrue  = identC (BS.pack "PTrue")

src/compiler/GF/Grammar/Printer.hs

@@ -171,7 +171,7 @@ ppTerm q d (Q  id)     = ppQIdent q id
 ppTerm q d (QC id)     = ppQIdent q id
 ppTerm q d (Sort id)   = ppIdent id
 ppTerm q d (K s)       = str s
-ppTerm q d (EInt n)    = integer n
+ppTerm q d (EInt n)    = int n
 ppTerm q d (EFloat f)  = double f
 ppTerm q d (Meta _)    = char '?'
 ppTerm q d (Empty)     = text "[]"
@@ -204,7 +204,7 @@ ppPatt q d (PMacro id)  = char '#' <> ppIdent id
 ppPatt q d (PM id)      = char '#' <> ppQIdent q id
 ppPatt q d PW           = char '_'
 ppPatt q d (PV id)      = ppIdent id
-ppPatt q d (PInt n)     = integer n
+ppPatt q d (PInt n)     = int n
 ppPatt q d (PFloat f)   = double f
 ppPatt q d (PString s)  = str s
 ppPatt q d (PR xs)      = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))