initial support for literal categories e.g. String,Int and Float

src/GF/Conversion/SimpleToFCFG.hs

@@ -244,7 +244,14 @@ type SRulesMap = Map.Map SCat [SRule]
 type FCatSet = Map.Map SCat (Map.Map [SPath] (Map.Map [(SPath,STerm)] (Either FCat FCat)))
 
 
-emptyFRulesEnv = FRulesEnv 0 Map.empty []
+emptyFRulesEnv = FRulesEnv 0 (ins fcatString (ins fcatInt (ins fcatFloat Map.empty))) []
+  where
+    ins fcat@(FCat _ cat rcs tcs) fcatSet =
+      Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs x_fcat) rcs tmap_s) cat rmap_s fcatSet
+      where
+        x_fcat = Right fcat
+        tmap_s = Map.singleton tcs x_fcat
+        rmap_s = Map.singleton rcs tmap_s
 
 genFCatHead :: FRulesEnv -> FCat -> (FRulesEnv, FCat)
 genFCatHead env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =

src/GF/Conversion/Types.hs

@@ -14,9 +14,10 @@
 
 module GF.Conversion.Types where
 
-import qualified GF.Infra.Ident as Ident (Ident, wildIdent, isWildIdent)
+import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
-import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..))
+import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
 import qualified GF.Grammar.Grammar as Grammar (Term)
+import qualified GF.Grammar.Values as Values (cString, cInt, cFloat)
 
 import GF.Formalism.GCFG
 import GF.Formalism.SimpleGFC
@@ -116,6 +117,10 @@ data FCat     = FCat  {-# UNPACK #-} !Int SCat [SPath] [(SPath,STerm)]
 initialFCat :: SCat -> FCat
 initialFCat cat = FCat 0 cat [] []
 
+fcatString = FCat (-1) Values.cString [Path [Left (AbsGFC.L (Ident.IC "s"))]] []
+fcatInt    = FCat (-2) Values.cInt    [Path [Left (AbsGFC.L (Ident.IC "s"))]] []
+fcatFloat  = FCat (-3) Values.cFloat  [Path [Left (AbsGFC.L (Ident.IC "s"))]] []
+
 fcat2scat :: FCat -> SCat
 fcat2scat (FCat _ c _ _) = c
 

src/GF/Formalism/Utilities.hs

@@ -128,15 +128,21 @@ data SyntaxForest n = FMeta
 		      -- of possible alternatives. Ie. the outer list 
 		      -- is a disjunctive node, and the inner lists 
 		      -- are (conjunctive) concatenative nodes
+		    | FString String
+		    | FInt    Integer
+		    | FFloat  Double
 		      deriving (Eq, Ord, Show)
 
 instance Functor SyntaxForest where
     fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests
-    fmap f (FMeta) = FMeta 
+    fmap _ (FString s) = FString s
+    fmap _ (FInt    n) = FInt    n
+    fmap _ (FFloat  f) = FFloat  f
+    fmap _ (FMeta)     = FMeta
 
 forestName :: SyntaxForest n -> Maybe n
 forestName (FNode n _) = Just n
-forestName (FMeta)     = Nothing
+forestName _           = Nothing
 
 unifyManyForests :: (Monad m, Eq n) => [SyntaxForest n] -> m (SyntaxForest n)
 unifyManyForests = foldM unifyForests FMeta
@@ -148,10 +154,16 @@ unifyForests FMeta  forest = return forest
 unifyForests forest FMeta  = return forest
 unifyForests (FNode name1 children1) (FNode name2 children2)
     | name1 == name2 && not (null children) = return $ FNode name1 children
-    | otherwise    = fail "forest unification failure"
     where children = [ forests | forests1 <- children1, forests2 <- children2,
 		       sameLength forests1 forests2,
 		       forests <- zipWithM unifyForests forests1 forests2 ]
+unifyForests (FString s1) (FString s2)
+    | s1 == s2  = return $ FString s1
+unifyForests (FInt n1) (FInt n2)
+    | n1 == n2  = return $ FInt n1
+unifyForests (FFloat f1) (FFloat f2)
+    | f1 == f2  = return $ FFloat f1
+unifyForests _ _ = fail "forest unification failure"
 
 {- måste tänka mer på detta:
 compactForests :: Ord n => [SyntaxForest n] -> SList (SyntaxForest n)
@@ -178,12 +190,19 @@ compactForests = map joinForests . groupBy eqNames . sortForests
 
 -- ** syntax trees
 
-data SyntaxTree n = TMeta | TNode n [SyntaxTree n] 
+data SyntaxTree n = TMeta
+                  | TNode n [SyntaxTree n]
+                  | TString  String
+                  | TInt     Integer
+                  | TFloat   Double
 		  deriving (Eq, Ord, Show)
 
 instance Functor SyntaxTree where
     fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees
-    fmap f (TMeta) = TMeta 
+    fmap _ (TString s)     = TString s
+    fmap _ (TInt    n)     = TInt    n
+    fmap _ (TFloat  f)     = TFloat  f
+    fmap _ (TMeta)         = TMeta 
 
 treeName :: SyntaxTree n -> Maybe n
 treeName (TNode n _) = Just n
@@ -200,7 +219,13 @@ unifyTrees tree TMeta = return tree
 unifyTrees (TNode name1 children1) (TNode name2 children2)
     | name1 == name2 && sameLength children1 children2 
 	= liftM (TNode name1) $ zipWithM unifyTrees children1 children2 
-    | otherwise = fail "tree unification failure"
+unifyTrees (TString s1) (TString s2)
+    | s1 == s2 = return (TString s1)
+unifyTrees (TInt n1) (TInt n2)
+    | n1 == n2 = return (TInt n1)
+unifyTrees (TFloat f1) (TFloat f2)
+    | f1 == f2 = return (TFloat f1)
+unifyTrees _ _ = fail "tree unification failure"
 
 -- ** conversions between representations
 
@@ -235,9 +260,11 @@ chart2forests chart isMeta = es2fs
 
 forest2trees :: SyntaxForest n -> SList (SyntaxTree n)
 forest2trees (FNode n forests) = map (TNode n) $ forests >>= mapM forest2trees
+forest2trees (FString s) = [TString s]
+forest2trees (FInt    n) = [TInt    n]
+forest2trees (FFloat  f) = [TFloat  f]
 forest2trees (FMeta)     = [TMeta]
 
-
 ----------------------------------------------------------------------
 -- * profiles
 
@@ -326,6 +353,9 @@ instance (Print s) => Print (SyntaxTree s) where
     prt (TNode s trees)
 	| null trees = prt s
 	| otherwise  = "(" ++ prt s ++ prtBefore " " trees ++ ")"
+    prt (TString  s) = show s
+    prt (TInt     n) = show n
+    prt (TFloat   f) = show f
     prt (TMeta)      = "?"
     prtList = prtAfter "\n"
 
@@ -335,6 +365,9 @@ instance (Print s) => Print (SyntaxForest s) where
     prt (FNode s [forests]) = "(" ++ prt s ++ prtBefore " " forests ++ ")"
     prt (FNode s children) = "{" ++ prtSep " | " [ prt s ++ prtBefore " " forests | 
 						   forests <- children ] ++ "}"
+    prt (FString s) = show s
+    prt (FInt    n) = show n
+    prt (FFloat  f) = show f
     prt (FMeta)     = "?"
     prtList = prtAfter "\n"
 

src/GF/Grammar/Macros.hs

@@ -398,16 +398,17 @@ freshAsTerm s = Vr (varX (readIntArg s))
 
 -- | create a terminal for concrete syntax
 string2term :: String -> Term
-string2term = ccK
+string2term = K
 
-ccK :: String -> Term
+int2term :: Integer -> Term
-ccC :: Term -> Term -> Term
+int2term = EInt
-ccK = K
+
-ccC = C
+float2term :: Double -> Term
+float2term = EFloat
 
 -- | create a terminal from identifier
 ident2terminal :: Ident -> Term
-ident2terminal = ccK . prIdent
+ident2terminal = K . prIdent
 
 -- | create a constant
 string2CnTrm :: String -> Term

src/GF/Parsing/FCFG/Active.hs

@@ -11,6 +11,7 @@ module GF.Parsing.FCFG.Active (parse) where
 
 import GF.Data.GeneralDeduction
 import GF.Data.Assoc
+import GF.Data.SortedList
 import GF.Data.Utilities
 
 import GF.Formalism.GCFG
@@ -34,14 +35,11 @@ import Data.Array
 -- * parsing
 
 parse :: (Ord c, Ord n, Ord t) => String -> FCFParser c n t
-parse strategy pinfo starts toks =
+parse strategy pinfo starts toks = xchart2forests chart pinfo starts toks
-    [ Abs (cat, found) (zip rhs rrecs) fun |
-      Final ruleid found rrecs <- listXChartFinal chart,
-      let FRule (Abs cat rhs fun) _ = allRules pinfo ! ruleid ]
     where chart = process strategy pinfo toks axioms emptyXChart
     
-          axioms | isBU  strategy = initialBU pinfo toks
+          axioms | isBU  strategy = terminal pinfo toks ++ initialScan pinfo toks
-		 | isTD  strategy = initialTD pinfo starts toks
+		 | isTD  strategy = initial pinfo starts toks
 
 isBU  s = s=="b"
 isTD  s = s=="t"
@@ -58,7 +56,7 @@ updateChildren recs i rec = updateNthM update i recs
 makeMaxRange (Range _ j) = Range j j
 makeMaxRange EmptyRange  = EmptyRange
 
-process :: (Ord c, Ord n, Ord t) => String -> FCFPInfo c n t -> Input t -> [Item] -> XChart c -> XChart c
+process :: (Ord c, Ord n, Ord t) => String -> FCFPInfo c n t -> Input t -> [Item c] -> XChart c -> XChart c
 process strategy pinfo toks []           chart = chart
 process strategy pinfo toks (item:items) chart = process strategy pinfo toks items $! univRule item chart
   where
@@ -67,7 +65,10 @@ process strategy pinfo toks (item:items) chart = process strategy pinfo toks ite
            case lin ! ppos of
              FSymCat c r d -> case insertXChart chart item c of
 	                        Nothing    -> chart
-	                        Just chart -> let items = do Final _ found' _ <- lookupXChartFinal chart c
+	                        Just chart -> let items = do item <- lookupXChartFinal chart c
+	                                                     let found' = case item of
+	                                                                    Final   _ found' _ -> found'
+	                                                                    Literal _ found' _ -> found'
 	         			                     rng'  <- concatRange rng (found' !! r)
 	         			                     recs' <- updateChildren recs d found'
 	     			                             return (Active ruleid found rng' lbl (ppos+1) recs')
@@ -105,12 +106,28 @@ process strategy pinfo toks (item:items) chart = process strategy pinfo toks ite
                                      return (Active ruleid [] (found' !! r) 0 1 (updateNth (const found') d (emptyChildren abs)))
                       in process strategy pinfo toks items chart
       where
-        (FRule (Abs cat _ fn) _) = allRules pinfo ! ruleid
+        (FRule (Abs cat _ _) _) = allRules pinfo ! ruleid
+    univRule item@(Literal cat found' t) chart =
+      case insertXChart chart item cat of
+        Nothing    -> chart
+        Just chart -> let items = do (Active ruleid found rng l ppos recs) <- lookupXChartAct chart cat
+                                     let FRule _ lins    = allRules pinfo ! ruleid
+                                         FSymCat cat r d = lins ! l ! ppos
+                                     rng'  <- concatRange rng (found' !! r)
+                                     recs' <- updateChildren recs d found'
+                                     return (Active ruleid found rng' l (ppos+1) recs')
+                                  ++
+    			          do guard (isBU strategy)
+			             ruleid <- leftcornerCats pinfo ? cat
+			             let FRule abs lins = allRules pinfo ! ruleid
+			                 FSymCat cat r d = lins ! 0 ! 0
+                                     return (Active ruleid [] (found' !! r) 0 1 (updateNth (const found') d (emptyChildren abs)))
+                      in process strategy pinfo toks items chart
 
 ----------------------------------------------------------------------
 -- * XChart
 
-data Item
+data Item c
   = Active {-# UNPACK #-} !RuleId
            RangeRec
            Range
@@ -118,9 +135,10 @@ data Item
            {-# UNPACK #-} !FPointPos
            [RangeRec]
   | Final {-# UNPACK #-} !RuleId RangeRec [RangeRec]
+  | Literal c RangeRec (SyntaxTree RuleId)
   deriving (Eq, Ord)
 
-data XChart c = XChart !(ParseChart Item c) !(ParseChart Item c)
+data XChart c = XChart !(ParseChart (Item c) c) !(ParseChart (Item c) c)
 
 emptyXChart :: Ord c => XChart c
 emptyXChart = XChart emptyChart emptyChart
@@ -135,19 +153,43 @@ insertXChart (XChart actives finals) item@(Final _ _ _)       c =
     Nothing     -> Nothing
     Just finals -> Just (XChart actives finals)
 
+insertXChart (XChart actives finals) item@(Literal _ _ _) c =
+  case chartInsert finals item c of
+    Nothing     -> Nothing
+    Just finals -> Just (XChart actives finals)
+
 lookupXChartAct   (XChart actives finals) c = chartLookup actives c
 lookupXChartFinal (XChart actives finals) c = chartLookup finals  c
 
-listXChartAct   (XChart actives finals) = chartList actives
+xchart2forests :: (Ord c, Ord n, Ord t) => XChart c -> FCFParser c n t
-listXChartFinal (XChart actives finals) = chartList finals
+xchart2forests (XChart actives finals) pinfo starts toks = concatMap (edge2forests . makeFinalEdge) starts
+  where
+    assocs = accumAssoc groupPairs $
+                [ case item of
+                    Final ruleid found rrecs      -> let FRule (Abs cat rhs fun) _ = allRules pinfo ! ruleid
+		                                     in ((cat,found), (FNode fun [], zip rhs rrecs))
+                    Literal cat found (TString s) ->    ((cat,found), (FString s,               []))
+                    Literal cat found (TInt    n) ->    ((cat,found), (FInt    n,               []))
+                    Literal cat found (TFloat  f) ->    ((cat,found), (FFloat  f,               []))
+		| item <- chartList finals
+		]
+    edge2forests edge@(cat,_) = map (item2forest cat) $ assocs ? edge
+    item2forest cat (FNode name _, children) = FNode name $ children >>= mapM edge2forests
+    item2forest cat (t           , children) = t
+
+    makeFinalEdge cat =
+      case inputBounds toks of
+        (0,0) -> (cat, [EmptyRange]   )
+        (i,j) -> (cat, [makeRange i j])
 
 
 ----------------------------------------------------------------------
 -- Earley --
 
--- called with all starting categories
+-- anropas med alla startkategorier
-initialTD :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> [c] -> Input t -> [Item]
+initial :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> [c] -> Input t -> [Item]
-initialTD pinfo starts toks = 
+initial pinfo starts toks = 
+    tracePrt "MCFG.Active (Earley) - initial rules" (prt . length) $
     do cat <- starts
        ruleid <- topdownRules pinfo ? cat
        let FRule abs lins = allRules pinfo ! ruleid
@@ -157,21 +199,22 @@ initialTD pinfo starts toks =
 ----------------------------------------------------------------------
 -- Kilbury --
 
--- terminal :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item]
+terminal :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item]
--- terminal pinfo toks = $
+terminal pinfo toks = 
---     tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $
+    tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $
---     do ruleid <- emptyRules pinfo
+    do ruleid <- emptyRules pinfo
---        let FRule abs lins = allRules pinfo ! ruleid
+       let FRule abs lins = allRules pinfo ! ruleid
---        rrec <- mapM (rangeRestSyms toks EmptyRange . elems) (elems lins)
+       rrec <- mapM (rangeRestSyms toks EmptyRange . elems) (elems lins)
---        return $ Final ruleid rrec []
+       return $ Final ruleid rrec []
---     where
+    where
---       rangeRestSyms toks rng []                 = return rng
+      rangeRestSyms toks rng []                 = return rng
---       rangeRestSyms toks rng (FSymTok tok:syms) = do (i,j) <- inputToken toks ? tok
+      rangeRestSyms toks rng (FSymTok tok:syms) = do (i,j) <- inputToken toks ? tok
---                                                      rng' <- concatRange rng (makeRange i j)
+                                                     rng' <- concatRange rng (makeRange i j)
---                                                      rangeRestSyms toks rng' syms
+                                                     rangeRestSyms toks rng' syms
 
-initialBU :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item]
+initialScan :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item]
-initialBU pinfo toks =
+initialScan pinfo toks =
+    tracePrt "MCFG.Active (Kilbury) - initial scanned rules" (prt . length) $
     do tok <- aElems (inputToken toks)
        ruleid <- leftcornerTokens pinfo ? tok ++
                  epsilonRules pinfo

src/GF/Parsing/FCFG/PInfo.hs

@@ -29,14 +29,7 @@ import Data.Maybe
 type FCFParser c n t = FCFPInfo c n t 
 		     -> [c]
 		     -> Input t
-		     -> FCFChart c n
+		     -> [SyntaxForest n]
-
-type FCFChart  c n   = [Abstract (c, RangeRec) n]
-
-makeFinalEdge :: c -> Int -> Int -> (c, RangeRec)
-makeFinalEdge cat 0 0 = (cat, [EmptyRange])
-makeFinalEdge cat i j = (cat, [makeRange i j])
-
 
 ------------------------------------------------------------
 -- parser information
@@ -54,6 +47,8 @@ data FCFPInfo c n t
 	       , leftcornerTokens   :: Assoc t (SList RuleId)
 		 -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
 	       , grammarCats        :: SList c
+	       , grammarToks        :: SList t
+	       , grammarLexer       :: t -> (c,SyntaxTree RuleId)
 	       }
 
 
@@ -73,8 +68,8 @@ getLeftCornerCat lins
   where
     syms = lins ! 0
 
-buildFCFPInfo :: (Ord c, Ord n, Ord t) => FCFGrammar c n t -> FCFPInfo c n t
+buildFCFPInfo :: (Ord c, Ord n, Ord t) => (t -> (c,SyntaxTree RuleId)) -> FCFGrammar c n t -> FCFPInfo c n t
-buildFCFPInfo grammar = 
+buildFCFPInfo lexer grammar = 
     traceCalcFirst grammar $
     tracePrt "MCFG.PInfo - parser info" (prt) $
     FCFPInfo { allRules = allrules
@@ -84,6 +79,8 @@ buildFCFPInfo grammar =
 	     , leftcornerCats = leftcorncats
 	     , leftcornerTokens = leftcorntoks
 	     , grammarCats = grammarcats
+	     , grammarToks = grammartoks
+	     , grammarLexer = lexer
 	     }
 
     where allrules = listArray (0,length grammar-1) grammar
@@ -98,6 +95,7 @@ buildFCFPInfo grammar =
 			  [ (fromJust (getLeftCornerTok lins), ruleid) | 
 			    (ruleid, FRule _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ]
 	  grammarcats   = aElems topdownrules
+	  grammartoks   = nubsort [t | (FRule _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin]
 
 ----------------------------------------------------------------------
 -- pretty-printing of statistics

src/GF/Parsing/GFC.hs

@@ -54,9 +54,17 @@ type CFPInfo  = PC.CFPInfo CCat Name Token
 
 buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo
 buildPInfo mcfg fcfg cfg = PInfo { mcfPInfo = PM.buildMCFPInfo mcfg
-                                 , fcfPInfo = PF.buildFCFPInfo fcfg
+                                 , fcfPInfo = PF.buildFCFPInfo grammarLexer fcfg
 			         , cfPInfo  = PC.buildCFPInfo  cfg
 			         }
+  where
+    grammarLexer s =
+      case reads s of
+        [(n::Integer,"")] -> (fcatInt, TInt n)
+        _                 -> case reads s of
+                               [(f::Double,"")] -> (fcatFloat, TFloat  f)
+                               _                -> (fcatString,TString s)
+
 
 instance Print PInfo where
     prt (PInfo m f c) = prt m ++ "\n" ++ prt c
@@ -126,12 +134,7 @@ selectParser "f" strategy pinfo startCat inTokens
 	     isStart cat = fcat2scat cat == cfCat2Ident startCat
 	     fcfpi = fcfPInfo pinfo
 	 fcfParser <- PF.parseFCF strategy
-	 let fcfChart = fcfParser fcfpi startCats inTokens
+	 return $ fcfParser fcfpi startCats inTokens
-	     chart = G.abstract2chart fcfChart
-	     (begin,end) = inputBounds inTokens
-	     finalEdges = [ PF.makeFinalEdge cat begin end | 
-			    cat@(FCat _ _ [lbl] _) <- startCats ]
-	 return $ chart2forests chart (const False) finalEdges
 
 -- error parser: 
 selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy 
@@ -142,6 +145,9 @@ selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with
 
 tree2term :: Ident.Ident -> SyntaxTree Fun -> Grammar.Term
 tree2term abs (TNode f ts) = Macros.mkApp (Macros.qq (abs,f)) (map (tree2term abs) ts)
+tree2term abs (TString  s) = Macros.string2term s
+tree2term abs (TInt     n) = Macros.int2term    n
+tree2term abs (TFloat   f) = Macros.float2term  f
 tree2term abs (TMeta)      = Macros.mkMeta 0
 
 
@@ -156,6 +162,10 @@ applyProfileToForest (FNode name@(Name fun profile) children)
     where chForests   = concat [ applyProfileM unifyManyForests profile forests |
 				 forests0 <- children,
 				 forests <- mapM applyProfileToForest forests0 ]
+applyProfileToForest (FString s) = [FString s]
+applyProfileToForest (FInt    n) = [FInt    n]
+applyProfileToForest (FFloat  f) = [FFloat  f]
+applyProfileToForest (FMeta)     = [FMeta]
 
 {-
 -- more intelligent(?) implementation