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

refactored FCFG parsing to fit in GFCC shell

Browse Source
This commit is contained in:
aarne
2007-09-20 09:10:37 +00:00
parent 7324597039
commit c58b4fe048
18 changed files with 197 additions and 161 deletions
Download Patch File Download Diff File Expand all files Collapse all files

74
src/GF/Canon/GFCC/FCFGParsing.hs
View File

@@ -1,8 +1,8 @@
module GF.Canon.GFCC.FCFGParsing where
module GF.Canon.GFCC.FCFGParsing (parserLang) where
import GF.Canon.GFCC.DataGFCC
import GF.Canon.GFCC.AbsGFCC
import GF.Conversion.SimpleToFCFG (convertGrammar)
import GF.Conversion.SimpleToFCFG (convertGrammarCId,FCat(..))
--import GF.System.Tracing
--import GF.Infra.Print
@@ -20,8 +20,9 @@ import GF.Conversion.SimpleToFCFG (convertGrammar)
import GF.Data.SortedList
import GF.Data.Assoc
import GF.Formalism.Utilities --(forest2trees)
import qualified GF.Data.Operations as Op
--import GF.Conversion.Types
import GF.Conversion.FTypes
import GF.Formalism.FCFG
--import qualified GF.Formalism.GCFG as G
@@ -32,16 +33,15 @@ import GF.Formalism.FCFG
import qualified GF.Parsing.FCFG as PF
--import qualified GF.Parsing.CFG as PC
import GF.Canon.GFCC.ErrM
import GF.Infra.PrintClass
--convertGrammarCId :: Grammar -> [(CId,FGrammar)]
--convertGrammar :: Grammar -> [(Ident,FGrammar)]
parserLang :: GFCC -> CId -> CFCat -> [CFTok] -> Err [Exp]
parserLang mgr lang = parse info where
fcfgs = convertGrammarCId mgr
info = buildPInfo $ maybe (error "no parser") id $ lookup lang fcfgs
--import qualified GF.Parsing.GFC as New
--checkErr $ New.parse algorithm strategy (pInfo sg) (absId sg) cat toks
-- algorithm "f"
-- strategy "bottomup"
type Token = String ----
type CFTok = String ----
type CFCat = CId ----
type Fun = CId ----
@@ -54,6 +54,16 @@ wordsCFTok = return ----
type FCFPInfo = PF.FCFPInfo FCat FName Token
buildPInfo :: FGrammar -> FCFPInfo
buildPInfo fcfg = PF.buildFCFPInfo grammarLexer fcfg where
grammarLexer s =
case reads s of
[(n,"")] -> (fcatInt, SInt (n::Integer))
_ -> case reads s of
[(f,"")] -> (fcatFloat, SFloat (f::Double))
_ -> (fcatString,SString s)
-- main parsing function
parse ::
@@ -65,7 +75,7 @@ parse ::
[CFTok] -> -- ^ input tokens
Err [Exp] -- ^ resulting GF terms
parse pinfo startCat inString =
parse pinfo startCat inString = e2e $
do let inTokens = inputMany (map wordsCFTok inString)
forests <- selectParser pinfo startCat inTokens
@@ -107,7 +117,7 @@ cnv_forests2 (FFloat x) = FFloat x
-- parse trees to GFCC terms
tree2term :: SyntaxTree Fun -> Exp
tree2term (TNode f ts) = Tr (AC (CId f)) (map tree2term ts)
tree2term (TNode f ts) = Tr (AC f) (map tree2term ts)
{- ----
tree2term (TString s) = Macros.string2term s
tree2term (TInt n) = Macros.int2term n
@@ -122,7 +132,7 @@ tree2term (TMeta) = Macros.mkMeta 0
-- simplest implementation
applyProfileToForest :: SyntaxForest Name -> [SyntaxForest Fun]
applyProfileToForest (FNode name@(Name fun profile) children)
| isCoercion name = concat chForests
| isCoercionF name = concat chForests
| otherwise = [ FNode fun chForests | not (null chForests) ]
where chForests = concat [ applyProfileM unifyManyForests profile forests |
forests0 <- children,
@@ -132,40 +142,10 @@ applyProfileToForest (FInt n) = [FInt n]
applyProfileToForest (FFloat f) = [FFloat f]
applyProfileToForest (FMeta) = [FMeta]
--------------------- From parsing types ------------------------------
-- * fast nonerasing MCFG
type FIndex = Int
type FPath = [FIndex]
type FName = NameProfile CId
type FGrammar = FCFGrammar FCat FName Token
type FRule = FCFRule FCat FName Token
data FCat = FCat {-# UNPACK #-} !Int CId [FPath] [(FPath,FIndex)]
initialFCat :: CId -> FCat
initialFCat cat = FCat 0 cat [] []
fcatString = FCat (-1) (CId "String") [[0]] []
fcatInt = FCat (-2) (CId "Int") [[0]] []
fcatFloat = FCat (-3) (CId "Float") [[0]] []
fcat2cid :: FCat -> CId
fcat2cid (FCat _ c _ _) = c
instance Eq FCat where
(FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
instance Ord FCat where
compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
---
isCoercion :: Name -> Bool
isCoercion (Name fun [Unify [0]]) = False -- isWildIdent fun
isCoercion _ = False
e2e :: Op.Err a -> Err a
e2e e = case e of
Op.Ok v -> Ok v
Op.Bad s -> Bad s
type Name = NameProfile Fun

5
src/GF/Canon/GFCC/GFCCAPI.hs
View File

@@ -21,6 +21,7 @@ import GF.Canon.GFCC.AbsGFCC
import GF.Canon.GFCC.ParGFCC
import GF.Canon.GFCC.PrintGFCC
import GF.Canon.GFCC.ErrM
import GF.Canon.GFCC.FCFGParsing
--import GF.Data.Operations
--import GF.Infra.UseIO
import qualified Data.Map as Map
@@ -70,7 +71,9 @@ file2grammar f =
linearize mgr lang = GF.Canon.GFCC.DataGFCC.linearize mgr (CId lang)
parse mgr lang cat s = []
parse mgr lang cat s =
err error id $ parserLang mgr (CId lang) (CId cat) (words s)
{-
map tree2exp .
errVal [] .

64
src/GF/Conversion/FTypes.hs Normal file
View File

@@ -0,0 +1,64 @@
module GF.Conversion.FTypes where
import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC (CId(..))
import GF.Formalism.FCFG
import GF.Formalism.Utilities
import GF.Infra.PrintClass
import GF.Data.Assoc
import Control.Monad (foldM)
import Data.Array
----------------------------------------------------------------------
-- * basic (leaf) types
-- ** input tokens
---- type Token = String ---- inlined in FGrammar and FRule
----------------------------------------------------------------------
-- * fast nonerasing MCFG
type FIndex = Int
type FPath = [FIndex]
type FName = NameProfile AbsGFCC.CId
type FGrammar = FCFGrammar FCat FName String
type FRule = FCFRule FCat FName String
data FCat = FCat {-# UNPACK #-} !Int AbsGFCC.CId [FPath] [(FPath,FIndex)]
initialFCat :: AbsGFCC.CId -> FCat
initialFCat cat = FCat 0 cat [] []
fcatString = FCat (-1) (AbsGFCC.CId "String") [[0]] []
fcatInt = FCat (-2) (AbsGFCC.CId "Int") [[0]] []
fcatFloat = FCat (-3) (AbsGFCC.CId "Float") [[0]] []
fcat2cid :: FCat -> AbsGFCC.CId
fcat2cid (FCat _ c _ _) = c
instance Eq FCat where
(FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
instance Ord FCat where
compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
instance Print AbsGFCC.CId where
prt (AbsGFCC.CId s) = s
isCoercionF :: FName -> Bool
isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.CId "_"
isCoercionF _ = False
----------------------------------------------------------------------
-- * pretty-printing
instance Print FCat where
prt (FCat _ (AbsGFCC.CId cat) rcs tcs) = cat ++ "{" ++
prtSep ";" ([prt path | path <- rcs] ++
[prt path ++ "=" ++ prt term | (path,term) <- tcs])
++ "}"

1
src/GF/Conversion/GFC.hs
View File

@@ -25,6 +25,7 @@ import GF.Formalism.SimpleGFC (decl2cat)
import GF.Formalism.CFG (CFRule(..))
import GF.Formalism.Utilities (symbol, name2fun)
import GF.Conversion.Types
import GF.Conversion.FTypes
import qualified GF.Conversion.GFCtoSimple as G2S
import qualified GF.Conversion.SimpleToFinite as S2Fin

30
src/GF/Conversion/SimpleToFCFG.hs
View File

@@ -13,17 +13,17 @@
module GF.Conversion.SimpleToFCFG
(convertGrammar) where
(convertGrammar,convertGrammarCId,FCat(..)) where
import GF.System.Tracing
import GF.Infra.Print
import GF.Infra.PrintClass
import GF.Infra.Ident
import Control.Monad
import GF.Formalism.Utilities
import GF.Formalism.FCFG
import GF.Conversion.Types
import GF.Conversion.FTypes
import GF.Canon.GFCC.AbsGFCC
import GF.Canon.GFCC.DataGFCC
@@ -40,17 +40,27 @@ import Data.Maybe
----------------------------------------------------------------------
-- main conversion function
convertGrammar :: Grammar -> [(Ident,FGrammar)]
convertGrammar g@(Grm hdr (Abs abs_defs) cncs) = [(i2i cncname,convert abs_defs conc) | cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)]
type FToken = String
convertGrammar :: Grammar -> [(Ident,FCFGrammar FCat FName FToken)]
convertGrammar g = [(IC c, f) | (CId c,f) <- convertGrammarCId (mkGFCC g)]
-- this is more native for GFCC
convertGrammarCId :: GFCC -> [(CId,FCFGrammar FCat FName FToken)]
convertGrammarCId gfcc = [(cncname,convert abs_defs conc) |
cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)]
where
gfcc = mkGFCC g
i2i (CId i) = IC i
abs_defs = Map.assocs (funs (abstract gfcc))
convert :: [AbsDef] -> TermMap -> FGrammar
convert :: [(CId,Type)] -> TermMap -> FGrammar
convert abs_defs cnc_defs = getFRules (loop frulesEnv)
where
srules = [(XRule id args res (map findLinType args) (findLinType res) term) | Fun id (Typ args res) exp <- abs_defs, term <- Map.lookup id cnc_defs]
srules = [
(XRule id args res (map findLinType args) (findLinType res) term) |
(id, Typ args res) <- abs_defs,
term <- Map.lookup id cnc_defs]
findLinType (CId id) = fromJust (Map.lookup (CId ("__"++id)) cnc_defs)
@@ -119,7 +129,7 @@ translateLin idxArgs lbl' ((lbl,syms) : lins)
type CnvMonad a = BacktrackM Env a
type Env = (FCat, [(FCat,[FPath])], Term, [Term])
type LinRec = [(FPath, [Symbol (FPath, FIndex, Int) Token])]
type LinRec = [(FPath, [Symbol (FPath, FIndex, Int) FToken])]
type TermMap = Map.Map CId Term

33
src/GF/Conversion/Types.hs
View File

@@ -14,6 +14,8 @@
module GF.Conversion.Types where
---import GF.Conversion.FTypes
import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC (CId(..))
@@ -110,31 +112,8 @@ mcat2scat = ecat2scat . mcat2ecat
----------------------------------------------------------------------
-- * fast nonerasing MCFG
type FIndex = Int
type FPath = [FIndex]
type FName = NameProfile AbsGFCC.CId
type FGrammar = FCFGrammar FCat FName Token
type FRule = FCFRule FCat FName Token
data FCat = FCat {-# UNPACK #-} !Int AbsGFCC.CId [FPath] [(FPath,FIndex)]
---- moved to FTypes by AR 20/9/2007
initialFCat :: AbsGFCC.CId -> FCat
initialFCat cat = FCat 0 cat [] []
fcatString = FCat (-1) (AbsGFCC.CId "String") [[0]] []
fcatInt = FCat (-2) (AbsGFCC.CId "Int") [[0]] []
fcatFloat = FCat (-3) (AbsGFCC.CId "Float") [[0]] []
fcat2cid :: FCat -> AbsGFCC.CId
fcat2cid (FCat _ c _ _) = c
instance Eq FCat where
(FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
instance Ord FCat where
compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
instance Print AbsGFCC.CId where
prt (AbsGFCC.CId s) = s
----------------------------------------------------------------------
-- * CFG
@@ -163,9 +142,5 @@ instance Print MCat where
instance Print CCat where
prt (CCat cat label) = prt cat ++ prt label
instance Print FCat where
prt (FCat _ (AbsGFCC.CId cat) rcs tcs) = cat ++ "{" ++
prtSep ";" ([prt path | path <- rcs] ++
[prt path ++ "=" ++ prt term | (path,term) <- tcs])
++ "}"
---- instance Print FCat where ---- FCat

15
src/GF/FCFG/ToFCFG.hs
View File

@@ -11,7 +11,7 @@ module GF.FCFG.ToFCFG (printFGrammar) where
import GF.Formalism.FCFG
import GF.Formalism.SimpleGFC
import GF.Conversion.Types
import GF.Conversion.FTypes
import GF.Infra.Ident
import qualified GF.FCFG.AbsFCFG as F
@@ -28,22 +28,23 @@ import GF.Formalism.GCFG
import GF.Infra.Print
type FToken = String
-- this is the main function used
printFGrammar :: FCFGrammar FCat FName Token -> String
printFGrammar :: FCFGrammar FCat FName FToken -> String
printFGrammar = undefined {- printTree . fgrammar
fgrammar :: FCFGrammar FCat Name Token -> F.FGrammar
fgrammar :: FCFGrammar FCat Name FToken -> F.FGrammar
fgrammar = F.FGr . map frule
frule :: FCFRule FCat Name Token -> F.FRule
frule :: FCFRule FCat Name FToken -> F.FRule
frule (FRule ab rhs) =
F.FR (abstract ab) [[fsymbol sym | (_,sym) <- assocs syms] | (_,syms) <- assocs rhs]
abstract :: Abstract FCat Name -> F.Abstract
abstract (Abs cat cats n) = F.Abs (fcat cat) (map fcat cats) (name n)
fsymbol :: FSymbol FCat Token -> F.FSymbol
fsymbol :: FSymbol FCat FToken -> F.FSymbol
fsymbol fs = case fs of
FSymCat fc i j -> F.FSymCat (fcat fc) (toInteger i) (toInteger j)
FSymTok s -> F.FSymTok s
@@ -56,7 +57,7 @@ fcat (FCat i id ps pts) =
name :: Name -> F.Name
name (Name id profs) = F.Nm (ident id) (map profile profs)
pathel :: Either C.Label (Term SCat Token) -> F.PathEl
pathel :: Either C.Label (Term SCat FToken) -> F.PathEl
pathel lt = case lt of
Left lab -> F.PLabel $ label lab
Right trm -> F.PTerm $ term trm
@@ -76,7 +77,7 @@ forest f = case f of
FInt i -> F.FInt i
FFloat d -> F.FFloat d
term :: Term SCat Token -> F.Term
term :: Term SCat FToken -> F.Term
term tr = case tr of
Arg i id p -> F.Arg (toInteger i) (ident id) (path p)
Rec rs -> F.Rec [F.Ass (label l) (term t) | (l,t) <- rs]

4
src/GF/Formalism/FCFG.hs
View File

@@ -14,9 +14,9 @@ import Data.List (groupBy)
import Data.Array
import GF.Formalism.Utilities
import GF.Formalism.GCFG
--import GF.Formalism.GCFG
import GF.Infra.Print
import GF.Infra.PrintClass
------------------------------------------------------------

2
src/GF/Formalism/GCFG.hs
View File

@@ -16,7 +16,7 @@ module GF.Formalism.GCFG where
import GF.Formalism.Utilities (SyntaxChart)
import GF.Data.Assoc (assocMap, accumAssoc)
import GF.Data.SortedList (nubsort, groupPairs)
import GF.Infra.Print
import GF.Infra.PrintClass
----------------------------------------------------------------------

2
src/GF/Formalism/MCFG.hs
View File

@@ -19,7 +19,7 @@ import Data.List (groupBy)
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Infra.Print
import GF.Infra.PrintClass
------------------------------------------------------------

2
src/GF/Formalism/Utilities.hs
View File

@@ -22,7 +22,7 @@ import GF.Data.SortedList
import GF.Data.Assoc
import GF.Data.Utilities (sameLength, foldMerge, splitBy)
import GF.Infra.Print
import GF.Infra.PrintClass
------------------------------------------------------------
-- * symbols

61
src/GF/Infra/Print.hs
View File

@@ -12,16 +12,14 @@
-----------------------------------------------------------------------------
module GF.Infra.Print
(Print(..),
prtBefore, prtAfter, prtSep,
prtBeforeAfter, prtPairList,
prIO
(module GF.Infra.PrintClass
) where
-- haskell modules:
import Data.List (intersperse)
import Data.Char (toUpper)
-- gf modules:
import GF.Infra.PrintClass
import GF.Data.Operations (Err(..))
import GF.Infra.Ident (Ident(..))
import GF.Canon.AbsGFC
@@ -31,59 +29,6 @@ import qualified GF.Canon.PrintGFC as P
------------------------------------------------------------
prtBefore :: Print a => String -> [a] -> String
prtBefore before = prtBeforeAfter before ""
prtAfter :: Print a => String -> [a] -> String
prtAfter after = prtBeforeAfter "" after
prtSep :: Print a => String -> [a] -> String
prtSep sep = concat . intersperse sep . map prt
prtBeforeAfter :: Print a => String -> String -> [a] -> String
prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ]
prtPairList :: (Print a, Print b) => String -> String -> [(a,b)] -> String
prtPairList comma sep xys = prtSep sep [ prt x ++ comma ++ prt y | (x,y) <- xys ]
prIO :: Print a => a -> IO ()
prIO = putStr . prt
class Print a where
prt :: a -> String
prtList :: [a] -> String
prtList as = "[" ++ prtSep "," as ++ "]"
instance Print a => Print [a] where
prt = prtList
instance (Print a, Print b) => Print (a, b) where
prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")"
instance (Print a, Print b, Print c) => Print (a, b, c) where
prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")"
instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where
prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")"
instance Print Char where
prt = return
prtList = id
instance Print Int where
prt = show
instance Print Integer where
prt = show
instance Print a => Print (Maybe a) where
prt (Just a) = prt a
prt Nothing = "Nothing"
instance Print a => Print (Err a) where
prt (Ok a) = prt a
prt (Bad str) = str
----------------------------------------------------------------------
instance Print Ident where

56
src/GF/Infra/PrintClass.hs Normal file
View File

@@ -0,0 +1,56 @@
module GF.Infra.PrintClass where
import Data.List (intersperse)
import GF.Data.Operations (Err(..))
class Print a where
prt :: a -> String
prtList :: [a] -> String
prtList as = "[" ++ prtSep "," as ++ "]"
prtSep :: Print a => String -> [a] -> String
prtSep sep = concat . intersperse sep . map prt
prtBefore :: Print a => String -> [a] -> String
prtBefore before = prtBeforeAfter before ""
prtAfter :: Print a => String -> [a] -> String
prtAfter after = prtBeforeAfter "" after
prtBeforeAfter :: Print a => String -> String -> [a] -> String
prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ]
prtPairList :: (Print a, Print b) => String -> String -> [(a,b)] -> String
prtPairList comma sep xys = prtSep sep [ prt x ++ comma ++ prt y | (x,y) <- xys ]
prIO :: Print a => a -> IO ()
prIO = putStr . prt
instance Print a => Print [a] where
prt = prtList
instance (Print a, Print b) => Print (a, b) where
prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")"
instance (Print a, Print b, Print c) => Print (a, b, c) where
prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")"
instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where
prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")"
instance Print Char where
prt = return
prtList = id
instance Print Int where
prt = show
instance Print Integer where
prt = show
instance Print a => Print (Maybe a) where
prt (Just a) = prt a
prt Nothing = "Nothing"
instance Print a => Print (Err a) where
prt (Ok a) = prt a
prt (Bad str) = str

2
src/GF/Parsing/FCFG.hs
View File

@@ -18,7 +18,7 @@ import GF.Formalism.MCFG
import GF.Parsing.FCFG.PInfo
import qualified GF.Parsing.FCFG.Active as Active
import GF.Infra.Print
import GF.Infra.PrintClass
----------------------------------------------------------------------
-- parsing

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

@@ -20,7 +20,7 @@ import GF.Formalism.MCFG(Lin(..))
import GF.Formalism.Utilities
import GF.Infra.Ident
import GF.Infra.Print
import GF.Infra.PrintClass
import GF.Parsing.FCFG.Range
import GF.Parsing.FCFG.PInfo

2
src/GF/Parsing/FCFG/PInfo.hs
View File

@@ -10,7 +10,7 @@
module GF.Parsing.FCFG.PInfo where
import GF.System.Tracing
import GF.Infra.Print
import GF.Infra.PrintClass
import GF.Formalism.Utilities
import GF.Formalism.GCFG

2
src/GF/Parsing/FCFG/Range.hs
View File

@@ -14,7 +14,7 @@ module GF.Parsing.FCFG.Range
-- GF modules
import GF.Formalism.Utilities
import GF.Infra.Print
import GF.Infra.PrintClass
------------------------------------------------------------
-- ranges as single pairs

1
src/GF/Parsing/GFC.hs
View File

@@ -32,6 +32,7 @@ import GF.Data.SortedList
import GF.Data.Assoc
import GF.Formalism.Utilities
import GF.Conversion.Types
import GF.Conversion.FTypes
import qualified GF.Formalism.GCFG as G
import qualified GF.Formalism.SimpleGFC as S