mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
move GF.Formalism.FCFG types to GF.GFCC.DataGFCC
This commit is contained in:
krasimir
2
GF.cabal
2
GF.cabal
@@ -46,7 +46,6 @@ library
|
||||
GF.Data.Assoc
|
||||
GF.Infra.PrintClass
|
||||
GF.Formalism.Utilities
|
||||
GF.Formalism.FCFG
|
||||
GF.Parsing.FCFG.PInfo
|
||||
GF.Parsing.FCFG.Active
|
||||
GF.GFCC.Raw.ConvertGFCC
|
||||
@@ -100,7 +99,6 @@ executable gf3
|
||||
GF.GFCC.Raw.ParGFCCRaw
|
||||
GF.GFCC.Raw.PrintGFCCRaw
|
||||
GF.Formalism.Utilities
|
||||
GF.Formalism.FCFG
|
||||
GF.Parsing.FCFG.PInfo
|
||||
GF.GFCC.DataGFCC
|
||||
GF.Parsing.FCFG.Active
|
||||
|
||||
@@ -20,7 +20,6 @@ import GF.Infra.PrintClass
|
||||
import Control.Monad
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.FCFG
|
||||
|
||||
import GF.GFCC.Macros --hiding (prt)
|
||||
import GF.GFCC.DataGFCC
|
||||
@@ -76,7 +75,7 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
|
||||
-- lincat for the _Var category
|
||||
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 f (R xs) = R (f xs)
|
||||
@@ -86,13 +85,13 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
|
||||
|
||||
catName :: (Int,CId) -> CId
|
||||
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 (n,c) = mkCId ("__" ++ show n ++ prt c)
|
||||
funName (n,c) = mkCId ("__" ++ show n ++ prCId c)
|
||||
|
||||
varFunName :: CId -> CId
|
||||
varFunName c = mkCId ("_Var_" ++ prt c)
|
||||
varFunName c = mkCId ("_Var_" ++ prCId c)
|
||||
|
||||
-- replaces __NCat with _B and _Var_Cat with _.
|
||||
-- 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 FPath = [FIndex]
|
||||
type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term])
|
||||
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
|
||||
gen_tcs (F id) path acc = case Map.lookup id cnc_defs of
|
||||
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) (F id) = case Map.lookup id cnc_defs of
|
||||
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 rcs tcss =
|
||||
|
||||
@@ -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"
|
||||
@@ -4,37 +4,37 @@ import GF.GFCC.CId
|
||||
import GF.Infra.PrintClass(prt)
|
||||
import GF.Infra.CompactPrint
|
||||
import GF.Text.UTF8
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Parsing.FCFG.PInfo
|
||||
import GF.Data.Assoc
|
||||
|
||||
import Data.Map
|
||||
import qualified Data.Map as Map
|
||||
import Data.List
|
||||
import Data.Array
|
||||
|
||||
-- internal datatypes for GFCC
|
||||
|
||||
data GFCC = GFCC {
|
||||
absname :: CId ,
|
||||
cncnames :: [CId] ,
|
||||
gflags :: Map CId String, -- value of a global flag
|
||||
gflags :: Map.Map CId String, -- value of a global flag
|
||||
abstract :: Abstr ,
|
||||
concretes :: Map CId Concr
|
||||
concretes :: Map.Map CId Concr
|
||||
}
|
||||
|
||||
data Abstr = Abstr {
|
||||
aflags :: Map CId String, -- value of a flag
|
||||
funs :: Map CId (Type,Exp), -- type and def of a fun
|
||||
cats :: Map CId [Hypo], -- context of a cat
|
||||
catfuns :: Map CId [CId] -- funs to a cat (redundant, for fast lookup)
|
||||
aflags :: Map.Map CId String, -- value of a flag
|
||||
funs :: Map.Map CId (Type,Exp), -- type and def of a fun
|
||||
cats :: Map.Map CId [Hypo], -- context of a cat
|
||||
catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
|
||||
}
|
||||
|
||||
data Concr = Concr {
|
||||
cflags :: Map CId String, -- value of a flag
|
||||
lins :: Map CId Term, -- lin of a fun
|
||||
opers :: Map CId Term, -- oper generated by subex elim
|
||||
lincats :: Map CId Term, -- lin type of a cat
|
||||
lindefs :: Map CId Term, -- lin default of a cat
|
||||
printnames :: Map CId Term, -- printname of a cat or a fun
|
||||
paramlincats :: Map CId Term, -- lin type of cat, with printable param names
|
||||
cflags :: Map.Map CId String, -- value of a flag
|
||||
lins :: Map.Map CId Term, -- lin of a fun
|
||||
opers :: Map.Map CId Term, -- oper generated by subex elim
|
||||
lincats :: Map.Map CId Term, -- lin type of a cat
|
||||
lindefs :: Map.Map CId Term, -- lin default of a cat
|
||||
printnames :: Map.Map CId Term, -- printname of a cat or a fun
|
||||
paramlincats :: Map.Map CId Term, -- lin type of cat, with printable param names
|
||||
parser :: Maybe FCFPInfo -- parser
|
||||
}
|
||||
|
||||
@@ -86,13 +86,50 @@ data Equation =
|
||||
Equ [Exp] Exp
|
||||
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
|
||||
|
||||
statGFCC :: GFCC -> String
|
||||
statGFCC gfcc = unlines [
|
||||
"Abstract\t" ++ prt (absname gfcc),
|
||||
"Concretes\t" ++ unwords (lmap prt (cncnames gfcc)),
|
||||
"Categories\t" ++ unwords (lmap prt (keys (cats (abstract gfcc))))
|
||||
"Abstract\t" ++ prCId (absname gfcc),
|
||||
"Concretes\t" ++ unwords (map prCId (cncnames gfcc)),
|
||||
"Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract gfcc))))
|
||||
]
|
||||
|
||||
-- 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
|
||||
n | n == wildCId -> two -- extending empty grammar
|
||||
| n == absname two -> one { -- extending grammar with same abstract
|
||||
concretes = Data.Map.union (concretes two) (concretes one),
|
||||
cncnames = Data.List.union (cncnames two) (cncnames one)
|
||||
concretes = Map.union (concretes two) (concretes one),
|
||||
cncnames = union (cncnames two) (cncnames one)
|
||||
}
|
||||
_ -> one -- abstracts don't match ---- print error msg
|
||||
|
||||
@@ -110,26 +147,21 @@ emptyGFCC :: GFCC
|
||||
emptyGFCC = GFCC {
|
||||
absname = wildCId,
|
||||
cncnames = [] ,
|
||||
gflags = empty,
|
||||
gflags = Map.empty,
|
||||
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
|
||||
|
||||
utf8GFCC :: GFCC -> GFCC
|
||||
utf8GFCC gfcc = gfcc {
|
||||
concretes = mmap u8concr (concretes gfcc)
|
||||
concretes = Map.map u8concr (concretes gfcc)
|
||||
}
|
||||
where
|
||||
u8concr cnc = cnc {
|
||||
lins = mmap u8term (lins cnc),
|
||||
opers = mmap u8term (opers cnc)
|
||||
lins = Map.map u8term (lins cnc),
|
||||
opers = Map.map u8term (opers cnc)
|
||||
}
|
||||
u8term = convertStringsInTerm encodeUTF8
|
||||
|
||||
@@ -138,9 +170,9 @@ utf8GFCC gfcc = gfcc {
|
||||
convertStringsInTerm conv t = case t of
|
||||
K (KS s) -> K (KS (conv s))
|
||||
W s r -> W (conv s) (convs r)
|
||||
R ts -> R $ lmap convs ts
|
||||
S ts -> S $ lmap convs ts
|
||||
FV ts -> FV $ lmap convs ts
|
||||
R ts -> R $ map convs ts
|
||||
S ts -> S $ map convs ts
|
||||
FV ts -> FV $ map convs ts
|
||||
P u v -> P (convs u) (convs v)
|
||||
_ -> t
|
||||
where
|
||||
|
||||
@@ -1,14 +1,11 @@
|
||||
module GF.GFCC.GFCCtoJS (gfcc2js) where
|
||||
|
||||
import qualified GF.GFCC.Macros as M
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import GF.GFCC.CId
|
||||
import GF.GFCC.DataGFCC
|
||||
import qualified GF.JavaScript.AbsJS as JS
|
||||
import qualified GF.JavaScript.PrintJS as JS
|
||||
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Parsing.FCFG.PInfo
|
||||
|
||||
import GF.Text.UTF8
|
||||
import GF.Data.ErrM
|
||||
import GF.Infra.Option
|
||||
@@ -19,60 +16,60 @@ import qualified Data.Array as Array
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
gfcc2js :: D.GFCC -> String
|
||||
gfcc2js :: GFCC -> String
|
||||
gfcc2js gfcc =
|
||||
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
|
||||
where
|
||||
n = prCId $ D.absname gfcc
|
||||
as = D.abstract gfcc
|
||||
cs = Map.assocs (D.concretes gfcc)
|
||||
n = prCId $ absname gfcc
|
||||
as = abstract gfcc
|
||||
cs = Map.assocs (concretes gfcc)
|
||||
start = M.lookStartCat gfcc
|
||||
grammar = new "GFGrammar" [abstract, concrete]
|
||||
abstract = abstract2js start as
|
||||
concrete = JS.EObj $ map (concrete2js start n) cs
|
||||
grammar = new "GFGrammar" [js_abstract, js_concrete]
|
||||
js_abstract = abstract2js start as
|
||||
js_concrete = JS.EObj $ map (concrete2js start n) cs
|
||||
|
||||
abstract2js :: String -> D.Abstr -> JS.Expr
|
||||
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))]
|
||||
abstract2js :: String -> Abstr -> JS.Expr
|
||||
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,_)) =
|
||||
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)])
|
||||
|
||||
concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property
|
||||
concrete2js :: String -> String -> (CId,Concr) -> JS.Property
|
||||
concrete2js start n (c, cnc) =
|
||||
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
|
||||
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)]]),
|
||||
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)]])]
|
||||
|
||||
|
||||
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)])
|
||||
|
||||
term2js :: String -> String -> D.Term -> JS.Expr
|
||||
term2js :: String -> String -> Term -> JS.Expr
|
||||
term2js n l t = f t
|
||||
where
|
||||
f t =
|
||||
case t of
|
||||
D.R xs -> new "Arr" (map f xs)
|
||||
D.P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
|
||||
D.S xs -> mkSeq (map f xs)
|
||||
D.K t -> tokn2js t
|
||||
D.V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
|
||||
D.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]
|
||||
D.FV xs -> new "Variants" (map f xs)
|
||||
D.W str x -> new "Suffix" [JS.EStr str, f x]
|
||||
D.TM _ -> new "Meta" []
|
||||
R xs -> new "Arr" (map f xs)
|
||||
P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
|
||||
S xs -> mkSeq (map f xs)
|
||||
K t -> tokn2js t
|
||||
V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
|
||||
C i -> new "Int" [JS.EInt i]
|
||||
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]
|
||||
FV xs -> new "Variants" (map f xs)
|
||||
W str x -> new "Suffix" [JS.EStr str, f x]
|
||||
TM _ -> new "Meta" []
|
||||
|
||||
tokn2js :: D.Tokn -> JS.Expr
|
||||
tokn2js (D.KS s) = mkStr s
|
||||
tokn2js (D.KP ss vs) = mkSeq (map mkStr ss) -- FIXME
|
||||
tokn2js :: Tokn -> JS.Expr
|
||||
tokn2js (KS s) = mkStr s
|
||||
tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME
|
||||
|
||||
mkStr :: String -> JS.Expr
|
||||
mkStr s = new "Str" [JS.EStr s]
|
||||
|
||||
@@ -4,7 +4,7 @@ import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.CId
|
||||
import GF.Infra.PrintClass
|
||||
import Data.Map
|
||||
import qualified Data.Map as Map
|
||||
import Data.List
|
||||
|
||||
import Debug.Trace
|
||||
@@ -17,7 +17,7 @@ linearize mcfg lang = realize . linExp mcfg lang
|
||||
realize :: Term -> String
|
||||
realize trm = case trm of
|
||||
R ts -> realize (ts !! 0)
|
||||
S ss -> unwords $ lmap realize ss
|
||||
S ss -> unwords $ map realize ss
|
||||
K t -> case t of
|
||||
KS s -> s
|
||||
KP s _ -> unwords s ---- prefix choice TODO
|
||||
@@ -29,13 +29,13 @@ realize trm = case trm of
|
||||
linExp :: GFCC -> CId -> Exp -> Term
|
||||
linExp mcfg lang tree@(DTr xs at trees) =
|
||||
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
|
||||
AI i -> R [kks (show i)]
|
||||
--- [C lst, kks (show i), C size] where
|
||||
--- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1
|
||||
AF d -> R [kks (show d)]
|
||||
AV x -> TM (prt x)
|
||||
AV x -> TM (prCId x)
|
||||
AM i -> TM (show i)
|
||||
where
|
||||
lin = linExp mcfg lang
|
||||
@@ -44,31 +44,31 @@ linExp mcfg lang tree@(DTr xs at trees) =
|
||||
addB t
|
||||
| Data.List.null xs = t
|
||||
| otherwise = case t of
|
||||
R ts -> R $ ts ++ (Data.List.map (kks . prt) xs)
|
||||
TM s -> R $ t : (Data.List.map (kks . prt) xs)
|
||||
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
|
||||
TM s -> R $ t : (Data.List.map (kks . prCId) xs)
|
||||
|
||||
compute :: GFCC -> CId -> [Term] -> Term -> Term
|
||||
compute mcfg lang args = comp where
|
||||
comp trm = case trm of
|
||||
P r p -> proj (comp r) (comp p)
|
||||
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
|
||||
F c -> comp $ look c -- not computed (if contains argvar)
|
||||
FV ts -> FV $ lmap comp ts
|
||||
S ts -> S $ lfilter (/= S []) $ lmap comp ts
|
||||
FV ts -> FV $ map comp ts
|
||||
S ts -> S $ filter (/= S []) $ map comp ts
|
||||
_ -> trm
|
||||
|
||||
look = lookOper mcfg lang
|
||||
|
||||
idx xs i = if i > length xs - 1
|
||||
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
|
||||
|
||||
proj r p = case (r,p) of
|
||||
(_, FV ts) -> FV $ lmap (proj r) ts
|
||||
(FV ts, _ ) -> FV $ lmap (\t -> proj t p) ts
|
||||
(_, FV ts) -> FV $ map (proj r) ts
|
||||
(FV ts, _ ) -> FV $ map (\t -> proj t p) ts
|
||||
(W s t, _) -> kks (s ++ getString (proj t p))
|
||||
_ -> comp $ getField r (getIndex p)
|
||||
|
||||
|
||||
@@ -2,11 +2,10 @@ module GF.GFCC.Macros where
|
||||
|
||||
import GF.GFCC.CId
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.Formalism.FCFG (FGrammar)
|
||||
import GF.Parsing.FCFG.PInfo (FCFPInfo, fcfPInfoToFGrammar)
|
||||
import GF.Parsing.FCFG.PInfo (fcfPInfoToFGrammar)
|
||||
import GF.Infra.PrintClass
|
||||
import Control.Monad
|
||||
import Data.Map
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
|
||||
@@ -39,7 +38,7 @@ lookFCFG :: GFCC -> CId -> Maybe FGrammar
|
||||
lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang
|
||||
|
||||
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)]
|
||||
|
||||
lookGlobalFlag :: GFCC -> CId -> String
|
||||
@@ -56,14 +55,14 @@ lookCncFlag gfcc lang f =
|
||||
|
||||
functionsToCat :: GFCC -> CId -> [(CId,Type)]
|
||||
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
|
||||
fs = lookMap [] cat $ catfuns $ abstract gfcc
|
||||
|
||||
depth :: Exp -> Int
|
||||
depth tr = case tr of
|
||||
DTr _ _ [] -> 1
|
||||
DTr _ _ ts -> maximum (lmap depth ts) + 1
|
||||
DTr _ _ ts -> maximum (map depth ts) + 1
|
||||
|
||||
tree :: Atom -> [Exp] -> Exp
|
||||
tree = DTr []
|
||||
@@ -94,7 +93,7 @@ primNotion :: Exp
|
||||
primNotion = EEq []
|
||||
|
||||
term0 :: CId -> Term
|
||||
term0 = TM . prt
|
||||
term0 = TM . prCId
|
||||
|
||||
tm0 :: Term
|
||||
tm0 = TM "?"
|
||||
@@ -103,8 +102,8 @@ kks :: String -> Term
|
||||
kks = K . KS
|
||||
|
||||
-- lookup with default value
|
||||
lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a
|
||||
lookMap d c m = maybe d id $ Data.Map.lookup c m
|
||||
lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a
|
||||
lookMap d c m = maybe d id $ Map.lookup c m
|
||||
|
||||
--- from Operations
|
||||
combinations :: [[a]] -> [[a]]
|
||||
|
||||
@@ -5,12 +5,11 @@ import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw
|
||||
|
||||
import GF.Infra.PrintClass
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo)
|
||||
import GF.Parsing.FCFG.PInfo (buildFCFPInfo)
|
||||
|
||||
import qualified Data.Array as Array
|
||||
import Data.Map
|
||||
import qualified Data.Map as Map
|
||||
|
||||
pgfMajorVersion, pgfMinorVersion :: Integer
|
||||
(pgfMajorVersion, pgfMinorVersion) = (1,0)
|
||||
@@ -30,35 +29,35 @@ toGFCC (Grm [
|
||||
]) = GFCC {
|
||||
absname = mkCId a,
|
||||
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 =
|
||||
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]
|
||||
funs = fromAscList lfuns
|
||||
funs = Map.fromAscList lfuns
|
||||
lcats = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts]
|
||||
cats = fromAscList lcats
|
||||
catfuns = fromAscList
|
||||
cats = Map.fromAscList lcats
|
||||
catfuns = Map.fromAscList
|
||||
[(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
|
||||
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
|
||||
|
||||
toConcr :: [RExp] -> Concr
|
||||
toConcr = foldl add (Concr {
|
||||
cflags = empty,
|
||||
lins = empty,
|
||||
opers = empty,
|
||||
lincats = empty,
|
||||
lindefs = empty,
|
||||
printnames = empty,
|
||||
paramlincats = empty,
|
||||
cflags = Map.empty,
|
||||
lins = Map.empty,
|
||||
opers = Map.empty,
|
||||
lincats = Map.empty,
|
||||
lindefs = Map.empty,
|
||||
printnames = Map.empty,
|
||||
paramlincats = Map.empty,
|
||||
parser = Nothing
|
||||
})
|
||||
where
|
||||
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 "oper" ts) = cnc { opers = mkTermMap ts }
|
||||
add cnc (App "lincat" ts) = cnc { lincats = mkTermMap ts }
|
||||
@@ -70,8 +69,8 @@ toConcr = foldl add (Concr {
|
||||
toPInfo :: [RExp] -> FCFPInfo
|
||||
toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
|
||||
where
|
||||
rules = lmap toFRule rs
|
||||
cats = fromList [(mkCId c, lmap expToInt fs) | App c fs <- cs]
|
||||
rules = map toFRule rs
|
||||
cats = Map.fromList [(mkCId c, map expToInt fs) | App c fs <- cs]
|
||||
|
||||
toFRule :: RExp -> FRule
|
||||
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
|
||||
where
|
||||
(fun,prof) = toFName n
|
||||
args = lmap expToInt at
|
||||
args = map expToInt at
|
||||
res = expToInt rt
|
||||
lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
|
||||
|
||||
toFName :: RExp -> (CId,[Profile])
|
||||
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
|
||||
toProfile :: RExp -> Profile
|
||||
toProfile AMet = []
|
||||
@@ -100,7 +99,7 @@ toSymbol (AStr t) = FSymTok t
|
||||
toType :: RExp -> Type
|
||||
toType e = case e of
|
||||
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
|
||||
|
||||
toHypo :: RExp -> Hypo
|
||||
@@ -111,9 +110,9 @@ toHypo e = case e of
|
||||
toExp :: RExp -> Exp
|
||||
toExp e = case e of
|
||||
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 ->
|
||||
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)) []
|
||||
AMet -> DTr [] (AM 0) []
|
||||
AInt i -> DTr [] (AI i) []
|
||||
@@ -123,9 +122,9 @@ toExp e = case e of
|
||||
|
||||
toTerm :: RExp -> Term
|
||||
toTerm e = case e of
|
||||
App "R" es -> R (lmap toTerm es)
|
||||
App "S" es -> S (lmap toTerm es)
|
||||
App "FV" es -> FV (lmap toTerm es)
|
||||
App "R" es -> R (map toTerm es)
|
||||
App "S" es -> S (map toTerm es)
|
||||
App "FV" es -> FV (map toTerm es)
|
||||
App "P" [e,v] -> P (toTerm e) (toTerm v)
|
||||
App "W" [AStr s,v] -> W s (toTerm v)
|
||||
App "A" [AInt i] -> V (fromInteger i)
|
||||
@@ -142,33 +141,33 @@ toTerm e = case e of
|
||||
fromGFCC :: GFCC -> Grammar
|
||||
fromGFCC gfcc0 = Grm [
|
||||
App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
|
||||
: App (prCId (absname gfcc)) [] : lmap (flip App [] . prCId) (cncnames gfcc)),
|
||||
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
|
||||
: App (prCId (absname gfcc)) [] : map (flip App [] . prCId) (cncnames gfcc)),
|
||||
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags gfcc `Map.union` aflags agfcc)],
|
||||
App "abstract" [
|
||||
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
|
||||
App "cat" [App (prCId f) (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
|
||||
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs 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
|
||||
gfcc = utf8GFCC gfcc0
|
||||
agfcc = abstract gfcc
|
||||
fromConcrete cnc = [
|
||||
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (cflags cnc)],
|
||||
App "lin" [App (prCId f) [fromTerm v] | (f,v) <- toList (lins cnc)],
|
||||
App "oper" [App (prCId f) [fromTerm v] | (f,v) <- toList (opers cnc)],
|
||||
App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- toList (lincats cnc)],
|
||||
App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- toList (lindefs cnc)],
|
||||
App "printname" [App (prCId f) [fromTerm v] | (f,v) <- toList (printnames cnc)],
|
||||
App "param" [App (prCId f) [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
|
||||
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (cflags cnc)],
|
||||
App "lin" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)],
|
||||
App "oper" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (opers cnc)],
|
||||
App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lincats cnc)],
|
||||
App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lindefs cnc)],
|
||||
App "printname" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (printnames cnc)],
|
||||
App "param" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (paramlincats cnc)]
|
||||
] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
|
||||
|
||||
fromType :: Type -> RExp
|
||||
fromType e = case e of
|
||||
DTyp hypos cat exps ->
|
||||
App (prCId cat) [
|
||||
App "H" (lmap fromHypo hypos),
|
||||
App "X" (lmap fromExp exps)]
|
||||
App "H" (map fromHypo hypos),
|
||||
App "X" (map fromExp exps)]
|
||||
|
||||
fromHypo :: Hypo -> RExp
|
||||
fromHypo e = case e of
|
||||
@@ -177,21 +176,21 @@ fromHypo e = case e of
|
||||
fromExp :: Exp -> RExp
|
||||
fromExp e = case e of
|
||||
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 [] (AS s) [] -> AStr s
|
||||
DTr [] (AF d) [] -> AFlt d
|
||||
DTr [] (AI i) [] -> AInt (toInteger i)
|
||||
DTr [] (AM _) [] -> AMet ----
|
||||
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
|
||||
|
||||
fromTerm :: Term -> RExp
|
||||
fromTerm e = case e of
|
||||
R es -> App "R" (lmap fromTerm es)
|
||||
S es -> App "S" (lmap fromTerm es)
|
||||
FV es -> App "FV" (lmap fromTerm es)
|
||||
R es -> App "R" (map fromTerm es)
|
||||
S es -> App "S" (map fromTerm es)
|
||||
FV es -> App "FV" (map fromTerm es)
|
||||
P e v -> App "P" [fromTerm e, fromTerm v]
|
||||
W s v -> App "W" [AStr s, fromTerm v]
|
||||
C i -> AInt (toInteger i)
|
||||
@@ -201,31 +200,31 @@ fromTerm e = case e of
|
||||
K (KS s) -> AStr s ----
|
||||
K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ----
|
||||
where
|
||||
str v = App "S" (lmap AStr v)
|
||||
str v = App "S" (map AStr v)
|
||||
|
||||
-- ** Parsing info
|
||||
|
||||
fromPInfo :: FCFPInfo -> RExp
|
||||
fromPInfo p = App "parser" [
|
||||
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 fun prof args res lins) =
|
||||
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]
|
||||
]
|
||||
|
||||
fromFName :: (CId,[Profile]) -> RExp
|
||||
fromFName (f,ps) | f == wildCId = fromProfile (head ps)
|
||||
| otherwise = App (prCId f) (lmap fromProfile ps)
|
||||
| otherwise = App (prCId f) (map fromProfile ps)
|
||||
where
|
||||
fromProfile :: Profile -> RExp
|
||||
fromProfile [] = AMet
|
||||
fromProfile [x] = daughter x
|
||||
fromProfile args = App "_U" (lmap daughter args)
|
||||
fromProfile args = App "_U" (map daughter args)
|
||||
|
||||
daughter n = App "_A" [intToExp n]
|
||||
|
||||
@@ -235,8 +234,8 @@ fromSymbol (FSymTok t) = AStr t
|
||||
|
||||
-- ** Utilities
|
||||
|
||||
mkTermMap :: [RExp] -> Map CId Term
|
||||
mkTermMap ts = fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
|
||||
mkTermMap :: [RExp] -> Map.Map CId Term
|
||||
mkTermMap ts = Map.fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
|
||||
|
||||
mkArray :: [a] -> Array.Array Int a
|
||||
mkArray xs = Array.listArray (0, length xs - 1) xs
|
||||
|
||||
@@ -15,7 +15,6 @@ import GF.Data.Assoc
|
||||
|
||||
import GF.Infra.PrintClass
|
||||
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Formalism.Utilities
|
||||
|
||||
import qualified GF.Parsing.FCFG.Active as Active
|
||||
|
||||
@@ -15,7 +15,7 @@ import GF.Data.SortedList
|
||||
import GF.Data.Utilities
|
||||
|
||||
import GF.GFCC.CId
|
||||
import GF.Formalism.FCFG
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.Formalism.Utilities
|
||||
|
||||
import GF.Infra.PrintClass
|
||||
|
||||
@@ -11,10 +11,10 @@ module GF.Parsing.FCFG.PInfo where
|
||||
|
||||
import GF.Infra.PrintClass
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.GFCC.CId
|
||||
import GF.GFCC.DataGFCC
|
||||
|
||||
import Data.Array
|
||||
import Data.Maybe
|
||||
@@ -37,24 +37,6 @@ makeFinalEdge cat i j = (cat, [makeRange i j])
|
||||
------------------------------------------------------------
|
||||
-- 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)
|
||||
| inRange (bounds syms) 0 = case syms ! 0 of
|
||||
FSymTok tok -> [tok]
|
||||
|
||||
Reference in New Issue
Block a user