mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-20 10:19:32 -06:00
initial support for literal categories e.g. String,Int and Float
This commit is contained in:
kr.angelov
@@ -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) =
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user