GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

move GF.Formalism.FCFG types to GF.GFCC.DataGFCC

Browse Source
This commit is contained in:
krasimir
2008-05-29 12:08:45 +00:00
parent 363ddd7b91
commit 9a759a66dc
11 changed files with 176 additions and 269 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
GF.cabal
View File

@@ -46,7 +46,6 @@ library
GF.Data.Assoc GF.Data.Assoc
GF.Infra.PrintClass GF.Infra.PrintClass
GF.Formalism.Utilities GF.Formalism.Utilities
GF.Formalism.FCFG
GF.Parsing.FCFG.PInfo GF.Parsing.FCFG.PInfo
GF.Parsing.FCFG.Active GF.Parsing.FCFG.Active
GF.GFCC.Raw.ConvertGFCC GF.GFCC.Raw.ConvertGFCC
@@ -100,7 +99,6 @@ executable gf3
GF.GFCC.Raw.ParGFCCRaw GF.GFCC.Raw.ParGFCCRaw
GF.GFCC.Raw.PrintGFCCRaw GF.GFCC.Raw.PrintGFCCRaw
GF.Formalism.Utilities GF.Formalism.Utilities
GF.Formalism.FCFG
GF.Parsing.FCFG.PInfo GF.Parsing.FCFG.PInfo
GF.GFCC.DataGFCC GF.GFCC.DataGFCC
GF.Parsing.FCFG.Active GF.Parsing.FCFG.Active

14
src-3.0/GF/Compile/GenerateFCFG.hs
View File

@@ -20,7 +20,6 @@ import GF.Infra.PrintClass
import Control.Monad import Control.Monad
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Formalism.FCFG
import GF.GFCC.Macros --hiding (prt) import GF.GFCC.Macros --hiding (prt)
import GF.GFCC.DataGFCC import GF.GFCC.DataGFCC
@@ -76,7 +75,7 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
-- lincat for the _Var category -- lincat for the _Var category
varLincat = Map.singleton varCat (R [S []]) varLincat = Map.singleton varCat (R [S []])
lincatOf c = fromMaybe (error $ "No lincat for " ++ prt c) $ Map.lookup c lincats lincatOf c = fromMaybe (error $ "No lincat for " ++ prCId c) $ Map.lookup c lincats
modifyRec :: ([Term] -> [Term]) -> Term -> Term modifyRec :: ([Term] -> [Term]) -> Term -> Term
modifyRec f (R xs) = R (f xs) modifyRec f (R xs) = R (f xs)
@@ -86,13 +85,13 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
catName :: (Int,CId) -> CId catName :: (Int,CId) -> CId
catName (0,c) = c catName (0,c) = c
catName (n,c) = mkCId ("_" ++ show n ++ prt c) catName (n,c) = mkCId ("_" ++ show n ++ prCId c)
funName :: (Int,CId) -> CId funName :: (Int,CId) -> CId
funName (n,c) = mkCId ("__" ++ show n ++ prt c) funName (n,c) = mkCId ("__" ++ show n ++ prCId c)
varFunName :: CId -> CId varFunName :: CId -> CId
varFunName c = mkCId ("_Var_" ++ prt c) varFunName c = mkCId ("_Var_" ++ prCId c)
-- replaces __NCat with _B and _Var_Cat with _. -- replaces __NCat with _B and _Var_Cat with _.
-- the temporary names are just there to avoid name collisions. -- the temporary names are just there to avoid name collisions.
@@ -176,6 +175,7 @@ translateLin idxArgs lbl' ((lbl,syms) : lins)
type CnvMonad a = BacktrackM Env a type CnvMonad a = BacktrackM Env a
type FPath = [FIndex]
type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term]) type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term])
type LinRec = [(FPath, [Either (FPath, FIndex, Int) FToken])] type LinRec = [(FPath, [Either (FPath, FIndex, Int) FToken])]
@@ -369,7 +369,7 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs t
addConstraint path0 index0 cs = (path0,index0) : cs addConstraint path0 index0 cs = (path0,index0) : cs
gen_tcs (F id) path acc = case Map.lookup id cnc_defs of gen_tcs (F id) path acc = case Map.lookup id cnc_defs of
Just term -> gen_tcs term path acc Just term -> gen_tcs term path acc
Nothing -> error ("unknown identifier: "++prt id) Nothing -> error ("unknown identifier: "++prCId id)
@@ -427,7 +427,7 @@ mkSingletonSelectors cnc_defs term = sels0
loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss) loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss)
loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of
Just term -> loop path (sels,tcss) term Just term -> loop path (sels,tcss) term
Nothing -> error ("unknown identifier: "++prt id) Nothing -> error ("unknown identifier: "++prCId id)
mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector
mkSelector rcs tcss = mkSelector rcs tcss =

99
src-3.0/GF/Formalism/FCFG.hs
View File

@@ -1,99 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-- Definitions of fast multiple context-free grammars
-----------------------------------------------------------------------------
module GF.Formalism.FCFG
(
-- * Token
FToken
-- * Category
, FPath
, FCat
, fcatString, fcatInt, fcatFloat, fcatVar
-- * Symbol
, FIndex
, FSymbol(..)
-- * Grammar
, Profile
, FPointPos
, FGrammar
, FRule(..)
) where
import Control.Monad (liftM)
import Data.List (groupBy)
import Data.Array
import qualified Data.Map as Map
import GF.Formalism.Utilities
import GF.GFCC.CId
import GF.Infra.PrintClass
------------------------------------------------------------
-- Token
type FToken = String
------------------------------------------------------------
-- Category
type FPath = [FIndex]
type FCat = Int
fcatString, fcatInt, fcatFloat, fcatVar :: Int
fcatString = (-1)
fcatInt = (-2)
fcatFloat = (-3)
fcatVar = (-4)
------------------------------------------------------------
-- Symbol
type FIndex = Int
data FSymbol
= FSymCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int
| FSymTok FToken
------------------------------------------------------------
-- Grammar
type Profile = [Int]
type FPointPos = Int
type FGrammar = ([FRule], Map.Map CId [FCat])
data FRule = FRule CId [Profile] [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
------------------------------------------------------------
-- pretty-printing
instance Print CId where
prt = prCId
instance Print FSymbol where
prt (FSymCat l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")"
prt (FSymTok t) = simpleShow (prt t)
where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\""
mkEsc '\\' = "\\\\"
mkEsc '\"' = "\\\""
mkEsc '\n' = "\\n"
mkEsc '\t' = "\\t"
mkEsc chr = [chr]
prtList = prtSep " "
instance Print FRule where
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"

100
src-3.0/GF/GFCC/DataGFCC.hs
View File

@@ -4,37 +4,37 @@ import GF.GFCC.CId
import GF.Infra.PrintClass(prt) import GF.Infra.PrintClass(prt)
import GF.Infra.CompactPrint import GF.Infra.CompactPrint
import GF.Text.UTF8 import GF.Text.UTF8
import GF.Formalism.FCFG import GF.Data.Assoc
import GF.Parsing.FCFG.PInfo
import Data.Map import qualified Data.Map as Map
import Data.List import Data.List
import Data.Array
-- internal datatypes for GFCC -- internal datatypes for GFCC
data GFCC = GFCC { data GFCC = GFCC {
absname :: CId , absname :: CId ,
cncnames :: [CId] , cncnames :: [CId] ,
gflags :: Map CId String, -- value of a global flag gflags :: Map.Map CId String, -- value of a global flag
abstract :: Abstr , abstract :: Abstr ,
concretes :: Map CId Concr concretes :: Map.Map CId Concr
} }
data Abstr = Abstr { data Abstr = Abstr {
aflags :: Map CId String, -- value of a flag aflags :: Map.Map CId String, -- value of a flag
funs :: Map CId (Type,Exp), -- type and def of a fun funs :: Map.Map CId (Type,Exp), -- type and def of a fun
cats :: Map CId [Hypo], -- context of a cat cats :: Map.Map CId [Hypo], -- context of a cat
catfuns :: Map CId [CId] -- funs to a cat (redundant, for fast lookup) catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
} }
data Concr = Concr { data Concr = Concr {
cflags :: Map CId String, -- value of a flag cflags :: Map.Map CId String, -- value of a flag
lins :: Map CId Term, -- lin of a fun lins :: Map.Map CId Term, -- lin of a fun
opers :: Map CId Term, -- oper generated by subex elim opers :: Map.Map CId Term, -- oper generated by subex elim
lincats :: Map CId Term, -- lin type of a cat lincats :: Map.Map CId Term, -- lin type of a cat
lindefs :: Map CId Term, -- lin default of a cat lindefs :: Map.Map CId Term, -- lin default of a cat
printnames :: Map CId Term, -- printname of a cat or a fun printnames :: Map.Map CId Term, -- printname of a cat or a fun
paramlincats :: Map CId Term, -- lin type of cat, with printable param names paramlincats :: Map.Map CId Term, -- lin type of cat, with printable param names
parser :: Maybe FCFPInfo -- parser parser :: Maybe FCFPInfo -- parser
} }
@@ -86,13 +86,50 @@ data Equation =
Equ [Exp] Exp Equ [Exp] Exp
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
type FToken = String
type FCat = Int
type FIndex = Int
data FSymbol
= FSymCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int
| FSymTok FToken
type Profile = [Int]
type FPointPos = Int
type FGrammar = ([FRule], Map.Map CId [FCat])
data FRule = FRule CId [Profile] [FCat] FCat (Array FIndex (Array FPointPos FSymbol))
type RuleId = Int
data FCFPInfo
= FCFPInfo { allRules :: Array RuleId FRule
, topdownRules :: Assoc FCat [RuleId]
-- ^ used in 'GF.Parsing.MCFG.Active' (Earley):
-- , emptyRules :: [RuleId]
, epsilonRules :: [RuleId]
-- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
, leftcornerCats :: Assoc FCat [RuleId]
, leftcornerTokens :: Assoc FToken [RuleId]
-- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
, grammarCats :: [FCat]
, grammarToks :: [FToken]
, startupCats :: Map.Map CId [FCat]
}
fcatString, fcatInt, fcatFloat, fcatVar :: Int
fcatString = (-1)
fcatInt = (-2)
fcatFloat = (-3)
fcatVar = (-4)
-- print statistics -- print statistics
statGFCC :: GFCC -> String statGFCC :: GFCC -> String
statGFCC gfcc = unlines [ statGFCC gfcc = unlines [
"Abstract\t" ++ prt (absname gfcc), "Abstract\t" ++ prCId (absname gfcc),
"Concretes\t" ++ unwords (lmap prt (cncnames gfcc)), "Concretes\t" ++ unwords (map prCId (cncnames gfcc)),
"Categories\t" ++ unwords (lmap prt (keys (cats (abstract gfcc)))) "Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract gfcc))))
] ]
-- merge two GFCCs; fails is differens absnames; priority to second arg -- merge two GFCCs; fails is differens absnames; priority to second arg
@@ -101,8 +138,8 @@ unionGFCC :: GFCC -> GFCC -> GFCC
unionGFCC one two = case absname one of unionGFCC one two = case absname one of
n | n == wildCId -> two -- extending empty grammar n | n == wildCId -> two -- extending empty grammar
| n == absname two -> one { -- extending grammar with same abstract | n == absname two -> one { -- extending grammar with same abstract
concretes = Data.Map.union (concretes two) (concretes one), concretes = Map.union (concretes two) (concretes one),
cncnames = Data.List.union (cncnames two) (cncnames one) cncnames = union (cncnames two) (cncnames one)
} }
_ -> one -- abstracts don't match ---- print error msg _ -> one -- abstracts don't match ---- print error msg
@@ -110,26 +147,21 @@ emptyGFCC :: GFCC
emptyGFCC = GFCC { emptyGFCC = GFCC {
absname = wildCId, absname = wildCId,
cncnames = [] , cncnames = [] ,
gflags = empty, gflags = Map.empty,
abstract = error "empty grammar, no abstract", abstract = error "empty grammar, no abstract",
concretes = empty concretes = Map.empty
} }
-- default map and filter are for Map here
lmap = Prelude.map
lfilter = Prelude.filter
mmap = Data.Map.map
-- encode idenfifiers and strings in UTF8 -- encode idenfifiers and strings in UTF8
utf8GFCC :: GFCC -> GFCC utf8GFCC :: GFCC -> GFCC
utf8GFCC gfcc = gfcc { utf8GFCC gfcc = gfcc {
concretes = mmap u8concr (concretes gfcc) concretes = Map.map u8concr (concretes gfcc)
} }
where where
u8concr cnc = cnc { u8concr cnc = cnc {
lins = mmap u8term (lins cnc), lins = Map.map u8term (lins cnc),
opers = mmap u8term (opers cnc) opers = Map.map u8term (opers cnc)
} }
u8term = convertStringsInTerm encodeUTF8 u8term = convertStringsInTerm encodeUTF8
@@ -138,9 +170,9 @@ utf8GFCC gfcc = gfcc {
convertStringsInTerm conv t = case t of convertStringsInTerm conv t = case t of
K (KS s) -> K (KS (conv s)) K (KS s) -> K (KS (conv s))
W s r -> W (conv s) (convs r) W s r -> W (conv s) (convs r)
R ts -> R $ lmap convs ts R ts -> R $ map convs ts
S ts -> S $ lmap convs ts S ts -> S $ map convs ts
FV ts -> FV $ lmap convs ts FV ts -> FV $ map convs ts
P u v -> P (convs u) (convs v) P u v -> P (convs u) (convs v)
_ -> t _ -> t
where where

61
src-3.0/GF/GFCC/GFCCtoJS.hs
View File

@@ -1,14 +1,11 @@
module GF.GFCC.GFCCtoJS (gfcc2js) where module GF.GFCC.GFCCtoJS (gfcc2js) where
import qualified GF.GFCC.Macros as M import qualified GF.GFCC.Macros as M
import qualified GF.GFCC.DataGFCC as D
import GF.GFCC.CId import GF.GFCC.CId
import GF.GFCC.DataGFCC
import qualified GF.JavaScript.AbsJS as JS import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS import qualified GF.JavaScript.PrintJS as JS
import GF.Formalism.FCFG
import GF.Parsing.FCFG.PInfo
import GF.Text.UTF8 import GF.Text.UTF8
import GF.Data.ErrM import GF.Data.ErrM
import GF.Infra.Option import GF.Infra.Option
@@ -19,60 +16,60 @@ import qualified Data.Array as Array
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Map as Map import qualified Data.Map as Map
gfcc2js :: D.GFCC -> String gfcc2js :: GFCC -> String
gfcc2js gfcc = gfcc2js gfcc =
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where where
n = prCId $ D.absname gfcc n = prCId $ absname gfcc
as = D.abstract gfcc as = abstract gfcc
cs = Map.assocs (D.concretes gfcc) cs = Map.assocs (concretes gfcc)
start = M.lookStartCat gfcc start = M.lookStartCat gfcc
grammar = new "GFGrammar" [abstract, concrete] grammar = new "GFGrammar" [js_abstract, js_concrete]
abstract = abstract2js start as js_abstract = abstract2js start as
concrete = JS.EObj $ map (concrete2js start n) cs js_concrete = JS.EObj $ map (concrete2js start n) cs
abstract2js :: String -> D.Abstr -> JS.Expr abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))] abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property absdef2js :: (CId,(Type,Exp)) -> JS.Property
absdef2js (f,(typ,_)) = absdef2js (f,(typ,_)) =
let (args,cat) = M.catSkeleton typ in let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)]) JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])
concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property concrete2js :: String -> String -> (CId,Concr) -> JS.Property
concrete2js start n (c, cnc) = concrete2js start n (c, cnc) =
JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++ JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++
maybe [] (parser2js start) (D.parser cnc))) maybe [] (parser2js start) (parser cnc)))
where where
l = JS.IdentPropName (JS.Ident (prCId c)) l = JS.IdentPropName (JS.Ident (prCId c))
ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc] ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc]
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
cncdef2js :: String -> String -> (CId,D.Term) -> JS.Property cncdef2js :: String -> String -> (CId,Term) -> JS.Property
cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
term2js :: String -> String -> D.Term -> JS.Expr term2js :: String -> String -> Term -> JS.Expr
term2js n l t = f t term2js n l t = f t
where where
f t = f t =
case t of case t of
D.R xs -> new "Arr" (map f xs) R xs -> new "Arr" (map f xs)
D.P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
D.S xs -> mkSeq (map f xs) S xs -> mkSeq (map f xs)
D.K t -> tokn2js t K t -> tokn2js t
D.V i -> JS.EIndex (JS.EVar children) (JS.EInt i) V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
D.C i -> new "Int" [JS.EInt i] C i -> new "Int" [JS.EInt i]
D.F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId f), JS.EVar children] F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId f), JS.EVar children]
D.FV xs -> new "Variants" (map f xs) FV xs -> new "Variants" (map f xs)
D.W str x -> new "Suffix" [JS.EStr str, f x] W str x -> new "Suffix" [JS.EStr str, f x]
D.TM _ -> new "Meta" [] TM _ -> new "Meta" []
tokn2js :: D.Tokn -> JS.Expr tokn2js :: Tokn -> JS.Expr
tokn2js (D.KS s) = mkStr s tokn2js (KS s) = mkStr s
tokn2js (D.KP ss vs) = mkSeq (map mkStr ss) -- FIXME tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME
mkStr :: String -> JS.Expr mkStr :: String -> JS.Expr
mkStr s = new "Str" [JS.EStr s] mkStr s = new "Str" [JS.EStr s]

24
src-3.0/GF/GFCC/Linearize.hs
View File

@@ -4,7 +4,7 @@ import GF.GFCC.Macros
import GF.GFCC.DataGFCC import GF.GFCC.DataGFCC
import GF.GFCC.CId import GF.GFCC.CId
import GF.Infra.PrintClass import GF.Infra.PrintClass
import Data.Map import qualified Data.Map as Map
import Data.List import Data.List
import Debug.Trace import Debug.Trace
@@ -17,7 +17,7 @@ linearize mcfg lang = realize . linExp mcfg lang
realize :: Term -> String realize :: Term -> String
realize trm = case trm of realize trm = case trm of
R ts -> realize (ts !! 0) R ts -> realize (ts !! 0)
S ss -> unwords $ lmap realize ss S ss -> unwords $ map realize ss
K t -> case t of K t -> case t of
KS s -> s KS s -> s
KP s _ -> unwords s ---- prefix choice TODO KP s _ -> unwords s ---- prefix choice TODO
@@ -29,13 +29,13 @@ realize trm = case trm of
linExp :: GFCC -> CId -> Exp -> Term linExp :: GFCC -> CId -> Exp -> Term
linExp mcfg lang tree@(DTr xs at trees) = linExp mcfg lang tree@(DTr xs at trees) =
addB $ case at of addB $ case at of
AC fun -> comp (lmap lin trees) $ look fun AC fun -> comp (map lin trees) $ look fun
AS s -> R [kks (show s)] -- quoted AS s -> R [kks (show s)] -- quoted
AI i -> R [kks (show i)] AI i -> R [kks (show i)]
--- [C lst, kks (show i), C size] where --- [C lst, kks (show i), C size] where
--- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1 --- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1
AF d -> R [kks (show d)] AF d -> R [kks (show d)]
AV x -> TM (prt x) AV x -> TM (prCId x)
AM i -> TM (show i) AM i -> TM (show i)
where where
lin = linExp mcfg lang lin = linExp mcfg lang
@@ -44,31 +44,31 @@ linExp mcfg lang tree@(DTr xs at trees) =
addB t addB t
| Data.List.null xs = t | Data.List.null xs = t
| otherwise = case t of | otherwise = case t of
R ts -> R $ ts ++ (Data.List.map (kks . prt) xs) R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ t : (Data.List.map (kks . prt) xs) TM s -> R $ t : (Data.List.map (kks . prCId) xs)
compute :: GFCC -> CId -> [Term] -> Term -> Term compute :: GFCC -> CId -> [Term] -> Term -> Term
compute mcfg lang args = comp where compute mcfg lang args = comp where
comp trm = case trm of comp trm = case trm of
P r p -> proj (comp r) (comp p) P r p -> proj (comp r) (comp p)
W s t -> W s (comp t) W s t -> W s (comp t)
R ts -> R $ lmap comp ts R ts -> R $ map comp ts
V i -> idx args i -- already computed V i -> idx args i -- already computed
F c -> comp $ look c -- not computed (if contains argvar) F c -> comp $ look c -- not computed (if contains argvar)
FV ts -> FV $ lmap comp ts FV ts -> FV $ map comp ts
S ts -> S $ lfilter (/= S []) $ lmap comp ts S ts -> S $ filter (/= S []) $ map comp ts
_ -> trm _ -> trm
look = lookOper mcfg lang look = lookOper mcfg lang
idx xs i = if i > length xs - 1 idx xs i = if i > length xs - 1
then trace then trace
("too large " ++ show i ++ " for\n" ++ unlines (lmap show xs) ++ "\n") tm0 ("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0
else xs !! i else xs !! i
proj r p = case (r,p) of proj r p = case (r,p) of
(_, FV ts) -> FV $ lmap (proj r) ts (_, FV ts) -> FV $ map (proj r) ts
(FV ts, _ ) -> FV $ lmap (\t -> proj t p) ts (FV ts, _ ) -> FV $ map (\t -> proj t p) ts
(W s t, _) -> kks (s ++ getString (proj t p)) (W s t, _) -> kks (s ++ getString (proj t p))
_ -> comp $ getField r (getIndex p) _ -> comp $ getField r (getIndex p)

17
src-3.0/GF/GFCC/Macros.hs
View File

@@ -2,11 +2,10 @@ module GF.GFCC.Macros where
import GF.GFCC.CId import GF.GFCC.CId
import GF.GFCC.DataGFCC import GF.GFCC.DataGFCC
import GF.Formalism.FCFG (FGrammar) import GF.Parsing.FCFG.PInfo (fcfPInfoToFGrammar)
import GF.Parsing.FCFG.PInfo (FCFPInfo, fcfPInfoToFGrammar)
import GF.Infra.PrintClass import GF.Infra.PrintClass
import Control.Monad import Control.Monad
import Data.Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import Data.List import Data.List
@@ -39,7 +38,7 @@ lookFCFG :: GFCC -> CId -> Maybe FGrammar
lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang
lookStartCat :: GFCC -> String lookStartCat :: GFCC -> String
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (mkCId "startcat")) lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
[gflags gfcc, aflags (abstract gfcc)] [gflags gfcc, aflags (abstract gfcc)]
lookGlobalFlag :: GFCC -> CId -> String lookGlobalFlag :: GFCC -> CId -> String
@@ -56,14 +55,14 @@ lookCncFlag gfcc lang f =
functionsToCat :: GFCC -> CId -> [(CId,Type)] functionsToCat :: GFCC -> CId -> [(CId,Type)]
functionsToCat gfcc cat = functionsToCat gfcc cat =
[(f,ty) | f <- fs, Just (ty,_) <- [Data.Map.lookup f $ funs $ abstract gfcc]] [(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract gfcc]]
where where
fs = lookMap [] cat $ catfuns $ abstract gfcc fs = lookMap [] cat $ catfuns $ abstract gfcc
depth :: Exp -> Int depth :: Exp -> Int
depth tr = case tr of depth tr = case tr of
DTr _ _ [] -> 1 DTr _ _ [] -> 1
DTr _ _ ts -> maximum (lmap depth ts) + 1 DTr _ _ ts -> maximum (map depth ts) + 1
tree :: Atom -> [Exp] -> Exp tree :: Atom -> [Exp] -> Exp
tree = DTr [] tree = DTr []
@@ -94,7 +93,7 @@ primNotion :: Exp
primNotion = EEq [] primNotion = EEq []
term0 :: CId -> Term term0 :: CId -> Term
term0 = TM . prt term0 = TM . prCId
tm0 :: Term tm0 :: Term
tm0 = TM "?" tm0 = TM "?"
@@ -103,8 +102,8 @@ kks :: String -> Term
kks = K . KS kks = K . KS
-- lookup with default value -- lookup with default value
lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a
lookMap d c m = maybe d id $ Data.Map.lookup c m lookMap d c m = maybe d id $ Map.lookup c m
--- from Operations --- from Operations
combinations :: [[a]] -> [[a]] combinations :: [[a]] -> [[a]]

105
src-3.0/GF/GFCC/Raw/ConvertGFCC.hs
View File

@@ -5,12 +5,11 @@ import GF.GFCC.DataGFCC
import GF.GFCC.Raw.AbsGFCCRaw import GF.GFCC.Raw.AbsGFCCRaw
import GF.Infra.PrintClass import GF.Infra.PrintClass
import GF.Formalism.FCFG
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo) import GF.Parsing.FCFG.PInfo (buildFCFPInfo)
import qualified Data.Array as Array import qualified Data.Array as Array
import Data.Map import qualified Data.Map as Map
pgfMajorVersion, pgfMinorVersion :: Integer pgfMajorVersion, pgfMinorVersion :: Integer
(pgfMajorVersion, pgfMinorVersion) = (1,0) (pgfMajorVersion, pgfMinorVersion) = (1,0)
@@ -30,35 +29,35 @@ toGFCC (Grm [
]) = GFCC { ]) = GFCC {
absname = mkCId a, absname = mkCId a,
cncnames = [mkCId c | App c [] <- cs], cncnames = [mkCId c | App c [] <- cs],
gflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs], gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
abstract = abstract =
let let
aflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs] aflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
lfuns = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs] lfuns = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs]
funs = fromAscList lfuns funs = Map.fromAscList lfuns
lcats = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts] lcats = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts]
cats = fromAscList lcats cats = Map.fromAscList lcats
catfuns = fromAscList catfuns = Map.fromAscList
[(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
in Abstr aflags funs cats catfuns, in Abstr aflags funs cats catfuns,
concretes = fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs] concretes = Map.fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs]
} }
where where
toConcr :: [RExp] -> Concr toConcr :: [RExp] -> Concr
toConcr = foldl add (Concr { toConcr = foldl add (Concr {
cflags = empty, cflags = Map.empty,
lins = empty, lins = Map.empty,
opers = empty, opers = Map.empty,
lincats = empty, lincats = Map.empty,
lindefs = empty, lindefs = Map.empty,
printnames = empty, printnames = Map.empty,
paramlincats = empty, paramlincats = Map.empty,
parser = Nothing parser = Nothing
}) })
where where
add :: Concr -> RExp -> Concr add :: Concr -> RExp -> Concr
add cnc (App "flags" ts) = cnc { cflags = fromAscList [(mkCId f,v) | App f [AStr v] <- ts] } add cnc (App "flags" ts) = cnc { cflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
add cnc (App "lin" ts) = cnc { lins = mkTermMap ts } add cnc (App "lin" ts) = cnc { lins = mkTermMap ts }
add cnc (App "oper" ts) = cnc { opers = mkTermMap ts } add cnc (App "oper" ts) = cnc { opers = mkTermMap ts }
add cnc (App "lincat" ts) = cnc { lincats = mkTermMap ts } add cnc (App "lincat" ts) = cnc { lincats = mkTermMap ts }
@@ -70,8 +69,8 @@ toConcr = foldl add (Concr {
toPInfo :: [RExp] -> FCFPInfo toPInfo :: [RExp] -> FCFPInfo
toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats) toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
where where
rules = lmap toFRule rs rules = map toFRule rs
cats = fromList [(mkCId c, lmap expToInt fs) | App c fs <- cs] cats = Map.fromList [(mkCId c, map expToInt fs) | App c fs <- cs]
toFRule :: RExp -> FRule toFRule :: RExp -> FRule
toFRule (App "rule" toFRule (App "rule"
@@ -80,13 +79,13 @@ toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
App "R" ls]) = FRule fun prof args res lins App "R" ls]) = FRule fun prof args res lins
where where
(fun,prof) = toFName n (fun,prof) = toFName n
args = lmap expToInt at args = map expToInt at
res = expToInt rt res = expToInt rt
lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls] lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
toFName :: RExp -> (CId,[Profile]) toFName :: RExp -> (CId,[Profile])
toFName (App "_A" [x]) = (wildCId, [[expToInt x]]) toFName (App "_A" [x]) = (wildCId, [[expToInt x]])
toFName (App f ts) = (mkCId f, lmap toProfile ts) toFName (App f ts) = (mkCId f, map toProfile ts)
where where
toProfile :: RExp -> Profile toProfile :: RExp -> Profile
toProfile AMet = [] toProfile AMet = []
@@ -100,7 +99,7 @@ toSymbol (AStr t) = FSymTok t
toType :: RExp -> Type toType :: RExp -> Type
toType e = case e of toType e = case e of
App cat [App "H" hypos, App "X" exps] -> App cat [App "H" hypos, App "X" exps] ->
DTyp (lmap toHypo hypos) (mkCId cat) (lmap toExp exps) DTyp (map toHypo hypos) (mkCId cat) (map toExp exps)
_ -> error $ "type " ++ show e _ -> error $ "type " ++ show e
toHypo :: RExp -> Hypo toHypo :: RExp -> Hypo
@@ -111,9 +110,9 @@ toHypo e = case e of
toExp :: RExp -> Exp toExp :: RExp -> Exp
toExp e = case e of toExp e = case e of
App "App" [App fun [], App "B" xs, App "X" exps] -> App "App" [App fun [], App "B" xs, App "X" exps] ->
DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (lmap toExp exps) DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (map toExp exps)
App "Eq" eqs -> App "Eq" eqs ->
EEq [Equ (lmap toExp ps) (toExp v) | App "E" (v:ps) <- eqs] EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
App "Var" [App i []] -> DTr [] (AV (mkCId i)) [] App "Var" [App i []] -> DTr [] (AV (mkCId i)) []
AMet -> DTr [] (AM 0) [] AMet -> DTr [] (AM 0) []
AInt i -> DTr [] (AI i) [] AInt i -> DTr [] (AI i) []
@@ -123,9 +122,9 @@ toExp e = case e of
toTerm :: RExp -> Term toTerm :: RExp -> Term
toTerm e = case e of toTerm e = case e of
App "R" es -> R (lmap toTerm es) App "R" es -> R (map toTerm es)
App "S" es -> S (lmap toTerm es) App "S" es -> S (map toTerm es)
App "FV" es -> FV (lmap toTerm es) App "FV" es -> FV (map toTerm es)
App "P" [e,v] -> P (toTerm e) (toTerm v) App "P" [e,v] -> P (toTerm e) (toTerm v)
App "W" [AStr s,v] -> W s (toTerm v) App "W" [AStr s,v] -> W s (toTerm v)
App "A" [AInt i] -> V (fromInteger i) App "A" [AInt i] -> V (fromInteger i)
@@ -142,33 +141,33 @@ toTerm e = case e of
fromGFCC :: GFCC -> Grammar fromGFCC :: GFCC -> Grammar
fromGFCC gfcc0 = Grm [ fromGFCC gfcc0 = Grm [
App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
: App (prCId (absname gfcc)) [] : lmap (flip App [] . prCId) (cncnames gfcc)), : App (prCId (absname gfcc)) [] : map (flip App [] . prCId) (cncnames gfcc)),
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)], App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags gfcc `Map.union` aflags agfcc)],
App "abstract" [ App "abstract" [
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)], App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs agfcc)],
App "cat" [App (prCId f) (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)] App "cat" [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats agfcc)]
], ],
App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- toList (concretes gfcc)] App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- Map.toList (concretes gfcc)]
] ]
where where
gfcc = utf8GFCC gfcc0 gfcc = utf8GFCC gfcc0
agfcc = abstract gfcc agfcc = abstract gfcc
fromConcrete cnc = [ fromConcrete cnc = [
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (cflags cnc)], App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (cflags cnc)],
App "lin" [App (prCId f) [fromTerm v] | (f,v) <- toList (lins cnc)], App "lin" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)],
App "oper" [App (prCId f) [fromTerm v] | (f,v) <- toList (opers cnc)], App "oper" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (opers cnc)],
App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- toList (lincats cnc)], App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lincats cnc)],
App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- toList (lindefs cnc)], App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lindefs cnc)],
App "printname" [App (prCId f) [fromTerm v] | (f,v) <- toList (printnames cnc)], App "printname" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (printnames cnc)],
App "param" [App (prCId f) [fromTerm v] | (f,v) <- toList (paramlincats cnc)] App "param" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (paramlincats cnc)]
] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc) ] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
fromType :: Type -> RExp fromType :: Type -> RExp
fromType e = case e of fromType e = case e of
DTyp hypos cat exps -> DTyp hypos cat exps ->
App (prCId cat) [ App (prCId cat) [
App "H" (lmap fromHypo hypos), App "H" (map fromHypo hypos),
App "X" (lmap fromExp exps)] App "X" (map fromExp exps)]
fromHypo :: Hypo -> RExp fromHypo :: Hypo -> RExp
fromHypo e = case e of fromHypo e = case e of
@@ -177,21 +176,21 @@ fromHypo e = case e of
fromExp :: Exp -> RExp fromExp :: Exp -> RExp
fromExp e = case e of fromExp e = case e of
DTr xs (AC fun) exps -> DTr xs (AC fun) exps ->
App "App" [App (prCId fun) [], App "B" (lmap (flip App [] . prCId) xs), App "X" (lmap fromExp exps)] App "App" [App (prCId fun) [], App "B" (map (flip App [] . prCId) xs), App "X" (map fromExp exps)]
DTr [] (AV x) [] -> App "Var" [App (prCId x) []] DTr [] (AV x) [] -> App "Var" [App (prCId x) []]
DTr [] (AS s) [] -> AStr s DTr [] (AS s) [] -> AStr s
DTr [] (AF d) [] -> AFlt d DTr [] (AF d) [] -> AFlt d
DTr [] (AI i) [] -> AInt (toInteger i) DTr [] (AI i) [] -> AInt (toInteger i)
DTr [] (AM _) [] -> AMet ---- DTr [] (AM _) [] -> AMet ----
EEq eqs -> EEq eqs ->
App "Eq" [App "E" (lmap fromExp (v:ps)) | Equ ps v <- eqs] App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs]
_ -> error $ "exp " ++ show e _ -> error $ "exp " ++ show e
fromTerm :: Term -> RExp fromTerm :: Term -> RExp
fromTerm e = case e of fromTerm e = case e of
R es -> App "R" (lmap fromTerm es) R es -> App "R" (map fromTerm es)
S es -> App "S" (lmap fromTerm es) S es -> App "S" (map fromTerm es)
FV es -> App "FV" (lmap fromTerm es) FV es -> App "FV" (map fromTerm es)
P e v -> App "P" [fromTerm e, fromTerm v] P e v -> App "P" [fromTerm e, fromTerm v]
W s v -> App "W" [AStr s, fromTerm v] W s v -> App "W" [AStr s, fromTerm v]
C i -> AInt (toInteger i) C i -> AInt (toInteger i)
@@ -201,31 +200,31 @@ fromTerm e = case e of
K (KS s) -> AStr s ---- K (KS s) -> AStr s ----
K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ---- K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ----
where where
str v = App "S" (lmap AStr v) str v = App "S" (map AStr v)
-- ** Parsing info -- ** Parsing info
fromPInfo :: FCFPInfo -> RExp fromPInfo :: FCFPInfo -> RExp
fromPInfo p = App "parser" [ fromPInfo p = App "parser" [
App "rules" [fromFRule rule | rule <- Array.elems (allRules p)], App "rules" [fromFRule rule | rule <- Array.elems (allRules p)],
App "startupcats" [App (prCId f) (lmap intToExp cs) | (f,cs) <- toList (startupCats p)] App "startupcats" [App (prCId f) (map intToExp cs) | (f,cs) <- Map.toList (startupCats p)]
] ]
fromFRule :: FRule -> RExp fromFRule :: FRule -> RExp
fromFRule (FRule fun prof args res lins) = fromFRule (FRule fun prof args res lins) =
App "rule" [fromFName (fun,prof), App "rule" [fromFName (fun,prof),
App "cats" (intToExp res:lmap intToExp args), App "cats" (intToExp res:map intToExp args),
App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins] App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
] ]
fromFName :: (CId,[Profile]) -> RExp fromFName :: (CId,[Profile]) -> RExp
fromFName (f,ps) | f == wildCId = fromProfile (head ps) fromFName (f,ps) | f == wildCId = fromProfile (head ps)
| otherwise = App (prCId f) (lmap fromProfile ps) | otherwise = App (prCId f) (map fromProfile ps)
where where
fromProfile :: Profile -> RExp fromProfile :: Profile -> RExp
fromProfile [] = AMet fromProfile [] = AMet
fromProfile [x] = daughter x fromProfile [x] = daughter x
fromProfile args = App "_U" (lmap daughter args) fromProfile args = App "_U" (map daughter args)
daughter n = App "_A" [intToExp n] daughter n = App "_A" [intToExp n]
@@ -235,8 +234,8 @@ fromSymbol (FSymTok t) = AStr t
-- ** Utilities -- ** Utilities
mkTermMap :: [RExp] -> Map CId Term mkTermMap :: [RExp] -> Map.Map CId Term
mkTermMap ts = fromAscList [(mkCId f,toTerm v) | App f [v] <- ts] mkTermMap ts = Map.fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
mkArray :: [a] -> Array.Array Int a mkArray :: [a] -> Array.Array Int a
mkArray xs = Array.listArray (0, length xs - 1) xs mkArray xs = Array.listArray (0, length xs - 1) xs

1
src-3.0/GF/Parsing/FCFG.hs
View File

@@ -15,7 +15,6 @@ import GF.Data.Assoc
import GF.Infra.PrintClass import GF.Infra.PrintClass
import GF.Formalism.FCFG
import GF.Formalism.Utilities import GF.Formalism.Utilities
import qualified GF.Parsing.FCFG.Active as Active import qualified GF.Parsing.FCFG.Active as Active

2
src-3.0/GF/Parsing/FCFG/Active.hs
View File

@@ -15,7 +15,7 @@ import GF.Data.SortedList
import GF.Data.Utilities import GF.Data.Utilities
import GF.GFCC.CId import GF.GFCC.CId
import GF.Formalism.FCFG import GF.GFCC.DataGFCC
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Infra.PrintClass import GF.Infra.PrintClass

20
src-3.0/GF/Parsing/FCFG/PInfo.hs
View File

@@ -11,10 +11,10 @@ module GF.Parsing.FCFG.PInfo where
import GF.Infra.PrintClass import GF.Infra.PrintClass
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Formalism.FCFG
import GF.Data.SortedList import GF.Data.SortedList
import GF.Data.Assoc import GF.Data.Assoc
import GF.GFCC.CId import GF.GFCC.CId
import GF.GFCC.DataGFCC
import Data.Array import Data.Array
import Data.Maybe import Data.Maybe
@@ -37,24 +37,6 @@ makeFinalEdge cat i j = (cat, [makeRange i j])
------------------------------------------------------------ ------------------------------------------------------------
-- parser information -- parser information
type RuleId = Int
data FCFPInfo
= FCFPInfo { allRules :: Array RuleId FRule
, topdownRules :: Assoc FCat (SList RuleId)
-- ^ used in 'GF.Parsing.MCFG.Active' (Earley):
-- , emptyRules :: [RuleId]
, epsilonRules :: [RuleId]
-- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
, leftcornerCats :: Assoc FCat (SList RuleId)
, leftcornerTokens :: Assoc FToken (SList RuleId)
-- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
, grammarCats :: SList FCat
, grammarToks :: SList FToken
, startupCats :: Map.Map CId [FCat]
}
getLeftCornerTok (FRule _ _ _ _ lins) getLeftCornerTok (FRule _ _ _ _ lins)
| inRange (bounds syms) 0 = case syms ! 0 of | inRange (bounds syms) 0 = case syms ! 0 of
FSymTok tok -> [tok] FSymTok tok -> [tok]