diff --git a/src/GF/Conversion/SimpleToFCFG.hs b/src/GF/Conversion/SimpleToFCFG.hs index 7570f2d65..b1093e9f2 100644 --- a/src/GF/Conversion/SimpleToFCFG.hs +++ b/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) = diff --git a/src/GF/Conversion/Types.hs b/src/GF/Conversion/Types.hs index ef2097acf..ab0b6a6e8 100644 --- a/src/GF/Conversion/Types.hs +++ b/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.Canon.AbsGFC as AbsGFC (CIdent(..)) +import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent) +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 diff --git a/src/GF/Formalism/Utilities.hs b/src/GF/Formalism/Utilities.hs index 3948980e1..f89bbe4a9 100644 --- a/src/GF/Formalism/Utilities.hs +++ b/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] - deriving (Eq, Ord, Show) +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,8 +260,10 @@ chart2forests chart isMeta = es2fs forest2trees :: SyntaxForest n -> SList (SyntaxTree n) forest2trees (FNode n forests) = map (TNode n) $ forests >>= mapM forest2trees -forest2trees (FMeta) = [TMeta] - +forest2trees (FString s) = [TString s] +forest2trees (FInt n) = [TInt n] +forest2trees (FFloat f) = [TFloat f] +forest2trees (FMeta) = [TMeta] ---------------------------------------------------------------------- -- * profiles @@ -326,7 +353,10 @@ instance (Print s) => Print (SyntaxTree s) where prt (TNode s trees) | null trees = prt s | otherwise = "(" ++ prt s ++ prtBefore " " trees ++ ")" - prt (TMeta) = "?" + prt (TString s) = show s + prt (TInt n) = show n + prt (TFloat f) = show f + prt (TMeta) = "?" prtList = prtAfter "\n" instance (Print s) => Print (SyntaxForest s) where @@ -335,7 +365,10 @@ 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 (FMeta) = "?" + prt (FString s) = show s + prt (FInt n) = show n + prt (FFloat f) = show f + prt (FMeta) = "?" prtList = prtAfter "\n" instance Print a => Print (Profile a) where diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index 8261f7f36..e7d073382 100644 --- a/src/GF/Grammar/Macros.hs +++ b/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 -ccC :: Term -> Term -> Term -ccK = K -ccC = C +int2term :: Integer -> Term +int2term = EInt + +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 diff --git a/src/GF/Parsing/FCFG/Active.hs b/src/GF/Parsing/FCFG/Active.hs index caae91573..d780951ad 100644 --- a/src/GF/Parsing/FCFG/Active.hs +++ b/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 = - [ Abs (cat, found) (zip rhs rrecs) fun | - Final ruleid found rrecs <- listXChartFinal chart, - let FRule (Abs cat rhs fun) _ = allRules pinfo ! ruleid ] +parse strategy pinfo starts toks = xchart2forests chart pinfo starts toks where chart = process strategy pinfo toks axioms emptyXChart - axioms | isBU strategy = initialBU pinfo toks - | isTD strategy = initialTD pinfo starts toks + axioms | isBU strategy = terminal pinfo toks ++ initialScan pinfo 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 @@ -130,7 +148,12 @@ insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _) c = Nothing -> Nothing Just actives -> Just (XChart actives finals) -insertXChart (XChart actives finals) item@(Final _ _ _) c = +insertXChart (XChart actives finals) item@(Final _ _ _) c = + case chartInsert finals item c of + 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) @@ -138,16 +161,35 @@ insertXChart (XChart actives finals) item@(Final _ _ _) c = lookupXChartAct (XChart actives finals) c = chartLookup actives c lookupXChartFinal (XChart actives finals) c = chartLookup finals c -listXChartAct (XChart actives finals) = chartList actives -listXChartFinal (XChart actives finals) = chartList finals +xchart2forests :: (Ord c, Ord n, Ord t) => XChart c -> FCFParser c n t +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 -initialTD :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> [c] -> Input t -> [Item] -initialTD pinfo starts toks = +-- anropas med alla startkategorier +initial :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> [c] -> Input t -> [Item] +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 pinfo toks = $ --- tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $ --- do ruleid <- emptyRules pinfo --- let FRule abs lins = allRules pinfo ! ruleid --- rrec <- mapM (rangeRestSyms toks EmptyRange . elems) (elems lins) --- return $ Final ruleid rrec [] --- where --- rangeRestSyms toks rng [] = return rng --- rangeRestSyms toks rng (FSymTok tok:syms) = do (i,j) <- inputToken toks ? tok --- rng' <- concatRange rng (makeRange i j) --- rangeRestSyms toks rng' syms +terminal :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item] +terminal pinfo toks = + tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $ + do ruleid <- emptyRules pinfo + let FRule abs lins = allRules pinfo ! ruleid + rrec <- mapM (rangeRestSyms toks EmptyRange . elems) (elems lins) + return $ Final ruleid rrec [] + where + rangeRestSyms toks rng [] = return rng + rangeRestSyms toks rng (FSymTok tok:syms) = do (i,j) <- inputToken toks ? tok + rng' <- concatRange rng (makeRange i j) + rangeRestSyms toks rng' syms -initialBU :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item] -initialBU pinfo toks = +initialScan :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item] +initialScan pinfo toks = + tracePrt "MCFG.Active (Kilbury) - initial scanned rules" (prt . length) $ do tok <- aElems (inputToken toks) ruleid <- leftcornerTokens pinfo ? tok ++ epsilonRules pinfo diff --git a/src/GF/Parsing/FCFG/PInfo.hs b/src/GF/Parsing/FCFG/PInfo.hs index e1126301a..43e729e31 100644 --- a/src/GF/Parsing/FCFG/PInfo.hs +++ b/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 - -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]) - + -> [SyntaxForest n] ------------------------------------------------------------ -- 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 grammar = +buildFCFPInfo :: (Ord c, Ord n, Ord t) => (t -> (c,SyntaxTree RuleId)) -> FCFGrammar c n t -> FCFPInfo c n t +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 diff --git a/src/GF/Parsing/GFC.hs b/src/GF/Parsing/GFC.hs index e87b45590..0a0b3892c 100644 --- a/src/GF/Parsing/GFC.hs +++ b/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 - chart = G.abstract2chart fcfChart - (begin,end) = inputBounds inTokens - finalEdges = [ PF.makeFinalEdge cat begin end | - cat@(FCat _ _ [lbl] _) <- startCats ] - return $ chart2forests chart (const False) finalEdges + return $ fcfParser fcfpi startCats inTokens -- 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