mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
simplify the Profile type and remove the NameProfile type
This commit is contained in:
krasimir
@@ -97,9 +97,9 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
|
||||
-- replaces __NCat with _B and _Var_Cat with _.
|
||||
-- the temporary names are just there to avoid name collisions.
|
||||
fixHoasFuns :: FGrammar -> FGrammar
|
||||
fixHoasFuns (rs, cs) = ([FRule (fixName n) args cat lins | FRule n args cat lins <- rs], cs)
|
||||
where fixName (Name (CId n) p) | BS.pack "__" `BS.isPrefixOf` n = Name (mkCId "_B") p
|
||||
| BS.pack "_Var_" `BS.isPrefixOf` n = Name wildCId p
|
||||
fixHoasFuns (rs, cs) = ([FRule (fixName n) ps args cat lins | FRule n ps args cat lins <- rs], cs)
|
||||
where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B")
|
||||
| BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
|
||||
fixName n = n
|
||||
|
||||
convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
|
||||
@@ -148,11 +148,11 @@ convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) frulesEnv =
|
||||
|
||||
(_,newProfile) = List.mapAccumL accumProf 0 newArgs'
|
||||
where
|
||||
accumProf nr (PFCat _ [] _,_ ) = (nr, Unify [] )
|
||||
accumProf nr (_ ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt])
|
||||
accumProf nr (PFCat _ [] _,_ ) = (nr, [] )
|
||||
accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt])
|
||||
where cnt = length xpaths
|
||||
|
||||
rule = FRule (Name fun newProfile) newArgs newCat newLinRec
|
||||
rule = FRule fun newProfile newArgs newCat newLinRec
|
||||
in addFRule env2 rule
|
||||
|
||||
translateLin idxArgs lbl' [] = array (0,-1) []
|
||||
@@ -336,7 +336,7 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs t
|
||||
(either_fcat,last_id1,tmap1,rules1)
|
||||
= foldBM (\tcs st (either_fcat,last_id,tmap,rules) ->
|
||||
let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
|
||||
rule = FRule (Name wildCId [Unify [0]]) [fcat_arg] fcat
|
||||
rule = FRule wildCId [[0]] [fcat_arg] fcat
|
||||
(listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]])
|
||||
in if st
|
||||
then (Right fcat, last_id1,tmap1,rule:rules)
|
||||
|
||||
@@ -22,11 +22,8 @@ module GF.Formalism.FCFG
|
||||
, FIndex
|
||||
, FSymbol(..)
|
||||
|
||||
-- * Name
|
||||
, FName
|
||||
, isCoercionF
|
||||
|
||||
-- * Grammar
|
||||
, Profile
|
||||
, FPointPos
|
||||
, FGrammar
|
||||
, FRule(..)
|
||||
@@ -38,7 +35,7 @@ import Data.Array
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import qualified GF.GFCC.CId as AbsGFCC
|
||||
import GF.GFCC.CId
|
||||
import GF.Infra.PrintClass
|
||||
|
||||
------------------------------------------------------------
|
||||
@@ -66,27 +63,19 @@ data FSymbol
|
||||
| FSymTok FToken
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Name
|
||||
type FName = NameProfile AbsGFCC.CId
|
||||
|
||||
isCoercionF :: FName -> Bool
|
||||
isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.wildCId
|
||||
isCoercionF _ = False
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Grammar
|
||||
|
||||
type Profile = [Int]
|
||||
type FPointPos = Int
|
||||
type FGrammar = ([FRule], Map.Map AbsGFCC.CId [FCat])
|
||||
data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
|
||||
type FGrammar = ([FRule], Map.Map CId [FCat])
|
||||
data FRule = FRule CId [Profile] [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
|
||||
|
||||
------------------------------------------------------------
|
||||
-- pretty-printing
|
||||
|
||||
instance Print AbsGFCC.CId where
|
||||
prt = AbsGFCC.prCId
|
||||
instance Print CId where
|
||||
prt = prCId
|
||||
|
||||
instance Print FSymbol where
|
||||
prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")"
|
||||
@@ -100,6 +89,11 @@ instance Print FSymbol where
|
||||
prtList = prtSep " "
|
||||
|
||||
instance Print FRule where
|
||||
prt (FRule name args res lins) = prt name ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++
|
||||
" =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]"
|
||||
prt (FRule fun profile args res lins) =
|
||||
prt fun ++ prtProf profile ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++
|
||||
" =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]"
|
||||
where
|
||||
prtProf [] = "?"
|
||||
prtProf args = prtSep "=" args
|
||||
|
||||
prtList = prtSep "\n"
|
||||
|
||||
@@ -309,66 +309,6 @@ forest2trees (FMeta) = [TMeta]
|
||||
----------------------------------------------------------------------
|
||||
-- * profiles
|
||||
|
||||
-- | Pairing a rule name with a profile
|
||||
data NameProfile a = Name a [Profile (SyntaxForest a)]
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
name2fun :: NameProfile a -> a
|
||||
name2fun (Name fun _) = fun
|
||||
|
||||
-- | A profile is a simple representation of a function on a number of arguments.
|
||||
-- We only use lists of profiles
|
||||
data Profile a = Unify [Int] -- ^ The Int's are the argument positions.
|
||||
-- 'Unify []' will become a metavariable,
|
||||
-- 'Unify [a,b]' means that the arguments are equal,
|
||||
| Constant a
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor Profile where
|
||||
fmap f (Constant a) = Constant (f a)
|
||||
fmap f (Unify xs) = Unify xs
|
||||
|
||||
-- | a function name where the profile does not contain arguments
|
||||
-- (i.e. denoting a constant, not a function)
|
||||
constantNameToForest :: NameProfile a -> SyntaxForest a
|
||||
constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile]
|
||||
where unConstant (Constant a) = a
|
||||
unConstant (Unify []) = FMeta
|
||||
unConstant _ = error $ "constantNameToForest: the profile should not contain arguments"
|
||||
|
||||
-- | profile application; we need some way of unifying a list of arguments
|
||||
applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a]
|
||||
applyProfile unify profile args = map apply profile
|
||||
where apply (Unify xs) = unify $ map (args !!) xs
|
||||
apply (Constant a) = a
|
||||
|
||||
-- | monadic profile application
|
||||
applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a]
|
||||
applyProfileM unify profile args = mapM apply profile
|
||||
where apply (Unify xs) = unify $ map (args !!) xs
|
||||
apply (Constant a) = return a
|
||||
|
||||
-- | profile composition:
|
||||
--
|
||||
-- > applyProfile u z (ps `composeProfiles` qs) args
|
||||
-- > ==
|
||||
-- > applyProfile u z ps (applyProfile u z qs args)
|
||||
--
|
||||
-- compare with function composition
|
||||
--
|
||||
-- > (p . q) arg
|
||||
-- > ==
|
||||
-- > p (q arg)
|
||||
--
|
||||
-- Note that composing an 'Constant' with two or more arguments returns an error
|
||||
-- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need.
|
||||
composeProfiles :: [Profile a] -> [Profile a] -> [Profile a]
|
||||
composeProfiles ps qs = map compose ps
|
||||
where compose (Unify [x]) = qs !! x
|
||||
compose (Unify xs) = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ]
|
||||
compose constant = constant
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- pretty-printing
|
||||
@@ -411,13 +351,3 @@ instance (Print s) => Print (SyntaxForest s) where
|
||||
prt (FFloat f) = show f
|
||||
prt (FMeta) = "?"
|
||||
prtList = prtAfter "\n"
|
||||
|
||||
instance Print a => Print (Profile a) where
|
||||
prt (Unify []) = "?"
|
||||
prt (Unify args) = prtSep "=" args
|
||||
prt (Constant a) = prt a
|
||||
|
||||
instance Print a => Print (NameProfile a) where
|
||||
prt (Name fun profile) = prt fun ++ prt profile
|
||||
|
||||
|
||||
|
||||
@@ -8,7 +8,6 @@ import qualified GF.JavaScript.PrintJS as JS
|
||||
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Parsing.FCFG.PInfo
|
||||
import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..))
|
||||
|
||||
import GF.Text.UTF8
|
||||
import GF.Data.ErrM
|
||||
@@ -97,29 +96,19 @@ parser2js start p = [new "Parser" [JS.EStr start,
|
||||
cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is))
|
||||
|
||||
frule2js :: FRule -> JS.Expr
|
||||
frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins]
|
||||
frule2js (FRule f ps args res lins) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js lins]
|
||||
|
||||
name2js :: FName -> JS.Expr
|
||||
name2js n = case n of
|
||||
Name f [p] | f == wildCId -> fromProfile p
|
||||
Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
|
||||
name2js :: (CId,[Profile]) -> JS.Expr
|
||||
name2js (f,ps) | f == wildCId = fromProfile (head ps)
|
||||
| otherwise = new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
|
||||
where
|
||||
fromProfile :: Profile (SyntaxForest CId) -> JS.Expr
|
||||
fromProfile (Unify []) = new "MetaVar" []
|
||||
fromProfile (Unify [x]) = daughter x
|
||||
fromProfile (Unify args) = new "Unify" [JS.EArray (map daughter args)]
|
||||
fromProfile (Constant forest) = fromSyntaxForest forest
|
||||
fromProfile :: Profile -> JS.Expr
|
||||
fromProfile [] = new "MetaVar" []
|
||||
fromProfile [x] = daughter x
|
||||
fromProfile args = new "Unify" [JS.EArray (map daughter args)]
|
||||
|
||||
daughter i = new "Arg" [JS.EInt i]
|
||||
|
||||
fromSyntaxForest :: SyntaxForest CId -> JS.Expr
|
||||
fromSyntaxForest FMeta = new "MetaVar" []
|
||||
-- FIXME: is there always just one element here?
|
||||
fromSyntaxForest (FNode n [args]) = new "FunApp" $ [JS.EStr $ prCId n, JS.EArray (map fromSyntaxForest args)]
|
||||
fromSyntaxForest (FString s) = new "Lit" $ [JS.EStr s]
|
||||
fromSyntaxForest (FInt i) = new "Lit" $ [JS.EInt $ fromIntegral i]
|
||||
fromSyntaxForest (FFloat f) = new "Lit" $ [JS.EDbl f]
|
||||
|
||||
lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr
|
||||
lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls]
|
||||
|
||||
|
||||
@@ -7,7 +7,7 @@ import GF.GFCC.Raw.AbsGFCCRaw
|
||||
import GF.Infra.PrintClass
|
||||
import GF.Data.Assoc
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..))
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo)
|
||||
|
||||
import qualified Data.Array as Array
|
||||
@@ -78,29 +78,21 @@ toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
|
||||
toFRule (App "rule"
|
||||
[n,
|
||||
App "cats" (rt:at),
|
||||
App "R" ls]) = FRule name args res lins
|
||||
App "R" ls]) = FRule fun prof args res lins
|
||||
where
|
||||
name = toFName n
|
||||
(fun,prof) = toFName n
|
||||
args = lmap expToInt at
|
||||
res = expToInt rt
|
||||
lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
|
||||
|
||||
toFName :: RExp -> FName
|
||||
toFName (App "_A" [x]) = Name wildCId [Unify [expToInt x]]
|
||||
toFName (App f ts) = Name (mkCId f) (lmap toProfile ts)
|
||||
toFName :: RExp -> (CId,[Profile])
|
||||
toFName (App "_A" [x]) = (wildCId, [[expToInt x]])
|
||||
toFName (App f ts) = (mkCId f, lmap toProfile ts)
|
||||
where
|
||||
toProfile :: RExp -> Profile (SyntaxForest CId)
|
||||
toProfile AMet = Unify []
|
||||
toProfile (App "_A" [t]) = Unify [expToInt t]
|
||||
toProfile (App "_U" ts) = Unify [expToInt t | App "_A" [t] <- ts]
|
||||
toProfile t = Constant (toSyntaxForest t)
|
||||
|
||||
toSyntaxForest :: RExp -> SyntaxForest CId
|
||||
toSyntaxForest AMet = FMeta
|
||||
toSyntaxForest (App n ts) = FNode (mkCId n) [lmap toSyntaxForest ts]
|
||||
toSyntaxForest (AStr s) = FString s
|
||||
toSyntaxForest (AInt i) = FInt i
|
||||
toSyntaxForest (AFlt f) = FFloat f
|
||||
toProfile :: RExp -> Profile
|
||||
toProfile AMet = []
|
||||
toProfile (App "_A" [t]) = [expToInt t]
|
||||
toProfile (App "_U" ts) = [expToInt t | App "_A" [t] <- ts]
|
||||
|
||||
toSymbol :: RExp -> FSymbol
|
||||
toSymbol (App "P" [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
|
||||
@@ -221,33 +213,23 @@ fromPInfo p = App "parser" [
|
||||
]
|
||||
|
||||
fromFRule :: FRule -> RExp
|
||||
fromFRule (FRule n args res lins) =
|
||||
App "rule" [fromFName n,
|
||||
fromFRule (FRule fun prof args res lins) =
|
||||
App "rule" [fromFName (fun,prof),
|
||||
App "cats" (intToExp res:lmap intToExp args),
|
||||
App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
|
||||
]
|
||||
|
||||
fromFName :: FName -> RExp
|
||||
fromFName n = case n of
|
||||
Name f ps | f == wildCId -> fromProfile (head ps)
|
||||
| otherwise -> App (prCId f) (lmap fromProfile ps)
|
||||
fromFName :: (CId,[Profile]) -> RExp
|
||||
fromFName (f,ps) | f == wildCId = fromProfile (head ps)
|
||||
| otherwise = App (prCId f) (lmap fromProfile ps)
|
||||
where
|
||||
fromProfile :: Profile (SyntaxForest CId) -> RExp
|
||||
fromProfile (Unify []) = AMet
|
||||
fromProfile (Unify [x]) = daughter x
|
||||
fromProfile (Unify args) = App "_U" (lmap daughter args)
|
||||
fromProfile (Constant forest) = fromSyntaxForest forest
|
||||
fromProfile :: Profile -> RExp
|
||||
fromProfile [] = AMet
|
||||
fromProfile [x] = daughter x
|
||||
fromProfile args = App "_U" (lmap daughter args)
|
||||
|
||||
daughter n = App "_A" [intToExp n]
|
||||
|
||||
fromSyntaxForest :: SyntaxForest CId -> RExp
|
||||
fromSyntaxForest FMeta = AMet
|
||||
-- FIXME: is there always just one element here?
|
||||
fromSyntaxForest (FNode n [args]) = App (prCId n) (lmap fromSyntaxForest args)
|
||||
fromSyntaxForest (FString s) = AStr s
|
||||
fromSyntaxForest (FInt i) = AInt i
|
||||
fromSyntaxForest (FFloat f) = AFlt f
|
||||
|
||||
fromSymbol :: FSymbol -> RExp
|
||||
fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l]
|
||||
fromSymbol (FSymTok t) = AStr t
|
||||
|
||||
@@ -46,7 +46,7 @@ parseFCF strategy pinfo startCat inString =
|
||||
let chart = fcfParser pinfo startCats inTokens
|
||||
(i,j) = inputBounds inTokens
|
||||
finalEdges = [makeFinalEdge cat i j | cat <- startCats]
|
||||
forests = map cnv_forests $ chart2forests chart (const False) finalEdges
|
||||
forests = chart2forests chart (const False) finalEdges
|
||||
filteredForests = forests >>= applyProfileToForest
|
||||
trees = nubsort $ filteredForests >>= forest2trees
|
||||
return $ map tree2term trees
|
||||
@@ -56,22 +56,6 @@ parseFCF strategy pinfo startCat inString =
|
||||
parseFCF "topdown" = Ok $ Active.parse "t"
|
||||
parseFCF strat = Bad $ "FCFG parsing strategy not defined: " ++ strat
|
||||
|
||||
|
||||
cnv_forests FMeta = FMeta
|
||||
cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (CId n) (map cnv_profile p)) (map (map cnv_forests) fss)
|
||||
cnv_forests (FString x) = FString x
|
||||
cnv_forests (FInt x) = FInt x
|
||||
cnv_forests (FFloat x) = FFloat x
|
||||
|
||||
cnv_profile (Unify x) = Unify x
|
||||
cnv_profile (Constant x) = Constant (cnv_forests2 x)
|
||||
|
||||
cnv_forests2 FMeta = FMeta
|
||||
cnv_forests2 (FNode (CId n) fss) = FNode (CId n) (map (map cnv_forests2) fss)
|
||||
cnv_forests2 (FString x) = FString x
|
||||
cnv_forests2 (FInt x) = FInt x
|
||||
cnv_forests2 (FFloat x) = FFloat x
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- parse trees to GFCC terms
|
||||
|
||||
@@ -87,13 +71,13 @@ tree2term (TMeta) = exp0
|
||||
-- conversion and unification of forests
|
||||
|
||||
-- simplest implementation
|
||||
applyProfileToForest :: SyntaxForest FName -> [SyntaxForest CId]
|
||||
applyProfileToForest (FNode name@(Name fun profile) children)
|
||||
| isCoercionF name = concat chForests
|
||||
| otherwise = [ FNode fun chForests | not (null chForests) ]
|
||||
where chForests = concat [ applyProfileM unifyManyForests profile forests |
|
||||
forests0 <- children,
|
||||
forests <- mapM applyProfileToForest forests0 ]
|
||||
applyProfileToForest :: SyntaxForest (CId,[Profile]) -> [SyntaxForest CId]
|
||||
applyProfileToForest (FNode (fun,profiles) children)
|
||||
| fun == wildCId = concat chForests
|
||||
| otherwise = [ FNode fun chForests | not (null chForests) ]
|
||||
where chForests = concat [ mapM (unifyManyForests . map (forests !!)) profiles |
|
||||
forests0 <- children,
|
||||
forests <- mapM applyProfileToForest forests0 ]
|
||||
applyProfileToForest (FString s) = [FString s]
|
||||
applyProfileToForest (FInt n) = [FInt n]
|
||||
applyProfileToForest (FFloat f) = [FFloat f]
|
||||
|
||||
@@ -14,6 +14,7 @@ import GF.Data.Assoc
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Utilities
|
||||
|
||||
import GF.GFCC.CId
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Formalism.Utilities
|
||||
|
||||
@@ -45,7 +46,7 @@ isTD s = s=="t"
|
||||
emptyChildren :: RuleId -> FCFPInfo -> SyntaxNode RuleId RangeRec
|
||||
emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) [])
|
||||
where
|
||||
FRule _ rhs _ _ = allRules pinfo ! ruleid
|
||||
FRule _ _ rhs _ _ = allRules pinfo ! ruleid
|
||||
|
||||
process :: String -> FCFPInfo -> Input FToken -> [(FCat,Item)] -> XChart FCat -> XChart FCat
|
||||
process strategy pinfo toks [] chart = chart
|
||||
@@ -77,20 +78,20 @@ process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks
|
||||
then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart
|
||||
else univRule cat (Final (reverse (rng:found)) node) chart
|
||||
where
|
||||
(FRule fn _ cat lins) = allRules pinfo ! ruleid
|
||||
(FRule _ _ _ cat lins) = allRules pinfo ! ruleid
|
||||
lin = lins ! lbl
|
||||
univRule cat item@(Final found' node) chart =
|
||||
case insertXChart chart item cat of
|
||||
Nothing -> chart
|
||||
Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat
|
||||
let FRule _ _ _ lins = allRules pinfo ! ruleid
|
||||
let FRule _ _ _ _ lins = allRules pinfo ! ruleid
|
||||
FSymCat cat r d = lins ! l ! ppos
|
||||
rng <- concatRange rng (found' !! r)
|
||||
return (cat, Active found rng l (ppos+1) (updateChildren node d found'))
|
||||
++
|
||||
do guard (isBU strategy)
|
||||
ruleid <- leftcornerCats pinfo ? cat
|
||||
let FRule _ _ _ lins = allRules pinfo ! ruleid
|
||||
let FRule _ _ _ _ lins = allRules pinfo ! ruleid
|
||||
FSymCat cat r d = lins ! 0 ! 0
|
||||
return (cat, Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid pinfo) d found'))
|
||||
|
||||
@@ -128,12 +129,12 @@ insertXChart (XChart actives finals) item@(Final _ _) c =
|
||||
lookupXChartAct (XChart actives finals) c = chartLookup actives c
|
||||
lookupXChartFinal (XChart actives finals) c = chartLookup finals c
|
||||
|
||||
xchart2syntaxchart :: XChart FCat -> FCFPInfo -> SyntaxChart FName (FCat,RangeRec)
|
||||
xchart2syntaxchart :: XChart FCat -> FCFPInfo -> SyntaxChart (CId,[Profile]) (FCat,RangeRec)
|
||||
xchart2syntaxchart (XChart actives finals) pinfo =
|
||||
accumAssoc groupSyntaxNodes $
|
||||
[ case node of
|
||||
SNode ruleid rrecs -> let FRule fun rhs cat _ = allRules pinfo ! ruleid
|
||||
in ((cat,found), SNode fun (zip rhs rrecs))
|
||||
SNode ruleid rrecs -> let FRule fun prof rhs cat _ = allRules pinfo ! ruleid
|
||||
in ((cat,found), SNode (fun,prof) (zip rhs rrecs))
|
||||
SString s -> ((cat,found), SString s)
|
||||
SInt n -> ((cat,found), SInt n)
|
||||
SFloat f -> ((cat,found), SFloat f)
|
||||
@@ -170,10 +171,10 @@ initialBU :: FCFPInfo -> Input FToken -> [(FCat,Item)]
|
||||
initialBU pinfo toks =
|
||||
do (tok,rngs) <- aAssocs (inputToken toks)
|
||||
ruleid <- leftcornerTokens pinfo ? tok
|
||||
let FRule _ _ cat _ = allRules pinfo ! ruleid
|
||||
let FRule _ _ _ cat _ = allRules pinfo ! ruleid
|
||||
(i,j) <- rngs
|
||||
return (cat,Active [] (makeRange i j) 0 1 (emptyChildren ruleid pinfo))
|
||||
++
|
||||
do ruleid <- epsilonRules pinfo
|
||||
let FRule _ _ cat _ = allRules pinfo ! ruleid
|
||||
let FRule _ _ _ cat _ = allRules pinfo ! ruleid
|
||||
return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo))
|
||||
|
||||
@@ -15,7 +15,7 @@ import GF.Formalism.FCFG
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.Parsing.FCFG.Range
|
||||
import qualified GF.GFCC.CId as AbsGFCC
|
||||
import GF.GFCC.CId
|
||||
|
||||
import Data.Array
|
||||
import Data.Maybe
|
||||
@@ -30,7 +30,7 @@ import Debug.Trace
|
||||
type FCFParser = FCFPInfo
|
||||
-> [FCat]
|
||||
-> Input FToken
|
||||
-> SyntaxChart FName (FCat,RangeRec)
|
||||
-> SyntaxChart (CId,[Profile]) (FCat,RangeRec)
|
||||
|
||||
makeFinalEdge cat 0 0 = (cat, [EmptyRange])
|
||||
makeFinalEdge cat i j = (cat, [makeRange i j])
|
||||
@@ -52,7 +52,7 @@ data FCFPInfo
|
||||
-- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
|
||||
, grammarCats :: SList FCat
|
||||
, grammarToks :: SList FToken
|
||||
, startupCats :: Map.Map AbsGFCC.CId [FCat]
|
||||
, startupCats :: Map.Map CId [FCat]
|
||||
}
|
||||
|
||||
|
||||
@@ -86,18 +86,17 @@ buildFCFPInfo (grammar,startup) = -- trace (unlines [prt (x,Set.toList set) | (x
|
||||
}
|
||||
|
||||
where allrules = listArray (0,length grammar-1) grammar
|
||||
topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ cat _) <- assocs allrules]
|
||||
-- emptyrules = [ruleid | (ruleid, FRule _ [] _ _) <- assocs allrules]
|
||||
epsilonrules = [ ruleid | (ruleid, FRule _ _ _ lins) <- assocs allrules,
|
||||
topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ _ cat _) <- assocs allrules]
|
||||
epsilonrules = [ ruleid | (ruleid, FRule _ _ _ _ lins) <- assocs allrules,
|
||||
not (inRange (bounds (lins ! 0)) 0) ]
|
||||
leftcorncats = accumAssoc id
|
||||
[ (fromJust (getLeftCornerCat lins), ruleid) |
|
||||
(ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ]
|
||||
(ruleid, FRule _ _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ]
|
||||
leftcorntoks = accumAssoc id
|
||||
[ (fromJust (getLeftCornerTok lins), ruleid) |
|
||||
(ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ]
|
||||
(ruleid, FRule _ _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ]
|
||||
grammarcats = aElems topdownrules
|
||||
grammartoks = nubsort [t | (FRule _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin]
|
||||
grammartoks = nubsort [t | (FRule _ _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin]
|
||||
|
||||
fcfPInfoToFGrammar :: FCFPInfo -> FGrammar
|
||||
fcfPInfoToFGrammar pinfo = (elems (allRules pinfo), startupCats pinfo)
|
||||
|
||||
Reference in New Issue
Block a user