forked from GitHub/gf-core
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
208
src-3.0/GF/Parsing/GFC.hs
Normal file
208
src-3.0/GF/Parsing/GFC.hs
Normal file
@@ -0,0 +1,208 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/13 12:40:19 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.9 $
|
||||
--
|
||||
-- The main parsing module, parsing GFC grammars
|
||||
-- by translating to simpler formats, such as PMCFG and CFG
|
||||
----------------------------------------------------------------------
|
||||
|
||||
module GF.Parsing.GFC
|
||||
(parse, PInfo(..), buildPInfo) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
import qualified GF.Grammar.PrGrammar as PrGrammar
|
||||
|
||||
import GF.Data.ErrM
|
||||
|
||||
import qualified GF.Grammar.Grammar as Grammar
|
||||
import qualified GF.Grammar.Macros as Macros
|
||||
import qualified GF.Canon.AbsGFC as AbsGFC
|
||||
import qualified GF.GFCC.DataGFCC as AbsGFCC
|
||||
import GF.GFCC.CId
|
||||
import qualified GF.Infra.Ident as Ident
|
||||
import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok)
|
||||
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Conversion.Types
|
||||
|
||||
import qualified GF.Formalism.GCFG as G
|
||||
import qualified GF.Formalism.SimpleGFC as S
|
||||
import qualified GF.Formalism.MCFG as M
|
||||
import GF.Formalism.FCFG
|
||||
import qualified GF.Formalism.CFG as C
|
||||
import qualified GF.Parsing.MCFG as PM
|
||||
import qualified GF.Parsing.FCFG as PF
|
||||
import qualified GF.Parsing.CFG as PC
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- parsing information
|
||||
|
||||
data PInfo = PInfo { mcfPInfo :: MCFPInfo
|
||||
, fcfPInfo :: PF.FCFPInfo
|
||||
, cfPInfo :: CFPInfo
|
||||
}
|
||||
|
||||
type MCFPInfo = PM.MCFPInfo MCat Name MLabel Token
|
||||
type CFPInfo = PC.CFPInfo CCat Name Token
|
||||
|
||||
buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo
|
||||
buildPInfo mcfg fcfg cfg = PInfo { mcfPInfo = PM.buildMCFPInfo mcfg
|
||||
, fcfPInfo = PF.buildFCFPInfo fcfg
|
||||
, cfPInfo = PC.buildCFPInfo cfg
|
||||
}
|
||||
|
||||
instance Print PInfo where
|
||||
prt (PInfo m f c) = prt m ++ "\n" ++ prt c
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- main parsing function
|
||||
|
||||
parse :: String -- ^ parsing algorithm (mcfg or cfg)
|
||||
-> String -- ^ parsing strategy
|
||||
-> PInfo -- ^ compiled grammars (mcfg and cfg)
|
||||
-> Ident.Ident -- ^ abstract module name
|
||||
-> CFCat -- ^ starting category
|
||||
-> [CFTok] -- ^ input tokens
|
||||
-> Err [Grammar.Term] -- ^ resulting GF terms
|
||||
|
||||
|
||||
-- parsing via CFG
|
||||
parse "c" strategy pinfo abs startCat inString
|
||||
= do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $
|
||||
inputMany (map wordsCFTok inString)
|
||||
let startCats = tracePrt "Parsing.GFC - starting CF categories" prt $
|
||||
filter isStart $ map fst $ aAssocs $ PC.topdownRules cfpi
|
||||
isStart cat = ccat2scat cat == cfCat2Ident startCat
|
||||
cfpi = cfPInfo pinfo
|
||||
cfParser <- PC.parseCF strategy
|
||||
let cfChart = tracePrt "Parsing.GFC - CF chart" (prt . length) $
|
||||
cfParser cfpi startCats inTokens
|
||||
chart = tracePrt "Parsing.GFC - chart" (prt . map (length.snd) . aAssocs) $
|
||||
C.grammar2chart cfChart
|
||||
finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $
|
||||
map (uncurry Edge (inputBounds inTokens)) startCats
|
||||
forests = chart2forests chart (const False) finalEdges
|
||||
traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests))
|
||||
traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees)))
|
||||
let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $
|
||||
forests >>= applyProfileToForest
|
||||
-- compactFs = tracePrt "#compactForests" (prt . length) $
|
||||
-- tracePrt "compactForests" (prtBefore "\n") $
|
||||
-- compactForests forests
|
||||
trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $
|
||||
nubsort $ filteredForests >>= forest2trees
|
||||
-- compactFs >>= forest2trees
|
||||
return $ map (tree2term abs) trees
|
||||
|
||||
|
||||
-- parsing via MCFG
|
||||
parse "m" strategy pinfo abs startCat inString
|
||||
= do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $
|
||||
inputMany (map wordsCFTok inString)
|
||||
let startCats = tracePrt "Parsing.GFC - starting MCF categories" prt $
|
||||
filter isStart $ PM.grammarCats mcfpi
|
||||
isStart cat = mcat2scat cat == cfCat2Ident startCat
|
||||
mcfpi = mcfPInfo pinfo
|
||||
mcfParser <- PM.parseMCF strategy
|
||||
let chart = mcfParser mcfpi startCats inTokens
|
||||
finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $
|
||||
[ PM.makeFinalEdge cat lbl (inputBounds inTokens) |
|
||||
cat@(MCat _ [lbl]) <- startCats ]
|
||||
forests = chart2forests chart (const False) finalEdges
|
||||
traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests))
|
||||
traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees)))
|
||||
let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $
|
||||
forests >>= applyProfileToForest
|
||||
-- compactFs = tracePrt "#compactForests" (prt . length) $
|
||||
-- tracePrt "compactForests" (prtBefore "\n") $
|
||||
-- compactForests forests
|
||||
trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $
|
||||
nubsort $ filteredForests >>= forest2trees
|
||||
-- compactFs >>= forest2trees
|
||||
return $ map (tree2term abs) trees
|
||||
|
||||
|
||||
-- parsing via FCFG
|
||||
parse "f" strategy pinfo abs startCat inString =
|
||||
let Ident.IC x = cfCat2Ident startCat
|
||||
cat' = CId x
|
||||
in case PF.parseFCF strategy (fcfPInfo pinfo) cat' (map prCFTok inString) of
|
||||
Ok es -> Ok (map (exp2term abs) es)
|
||||
Bad msg -> Bad msg
|
||||
|
||||
|
||||
-- error parser:
|
||||
selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy
|
||||
|
||||
cnv_forests FMeta = FMeta
|
||||
cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (Ident.IC n) (map cnv_profile p)) (map (map cnv_forests) fss)
|
||||
cnv_forests (FString x) = FString x
|
||||
cnv_forests (FInt x) = FInt x
|
||||
cnv_forests (FFloat x) = FFloat x
|
||||
|
||||
cnv_profile (Unify x) = Unify x
|
||||
cnv_profile (Constant x) = Constant (cnv_forests2 x)
|
||||
|
||||
cnv_forests2 FMeta = FMeta
|
||||
cnv_forests2 (FNode (CId n) fss) = FNode (Ident.IC n) (map (map cnv_forests2) fss)
|
||||
cnv_forests2 (FString x) = FString x
|
||||
cnv_forests2 (FInt x) = FInt x
|
||||
cnv_forests2 (FFloat x) = FFloat x
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- parse trees to GF terms
|
||||
|
||||
tree2term :: Ident.Ident -> SyntaxTree Fun -> Grammar.Term
|
||||
tree2term abs (TNode f ts) = Macros.mkApp (Macros.qq (abs,f)) (map (tree2term abs) ts)
|
||||
tree2term abs (TString s) = Macros.string2term s
|
||||
tree2term abs (TInt n) = Macros.int2term n
|
||||
tree2term abs (TFloat f) = Macros.float2term f
|
||||
tree2term abs (TMeta) = Macros.mkMeta 0
|
||||
|
||||
exp2term :: Ident.Ident -> AbsGFCC.Exp -> Grammar.Term
|
||||
exp2term abs (AbsGFCC.DTr _ a es) = ---- TODO: bindings
|
||||
Macros.mkApp (atom2term abs a) (map (exp2term abs) es)
|
||||
|
||||
atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term
|
||||
atom2term abs (AbsGFCC.AC (CId f)) = Macros.qq (abs,Ident.IC f)
|
||||
atom2term abs (AbsGFCC.AS s) = Macros.string2term s
|
||||
atom2term abs (AbsGFCC.AI n) = Macros.int2term n
|
||||
atom2term abs (AbsGFCC.AF f) = Macros.float2term f
|
||||
atom2term abs (AbsGFCC.AM i) = Macros.mkMeta (fromInteger i)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- conversion and unification of forests
|
||||
|
||||
-- simplest implementation
|
||||
applyProfileToForest :: SyntaxForest Name -> [SyntaxForest Fun]
|
||||
applyProfileToForest (FNode name@(Name fun profile) children)
|
||||
| isCoercion name = concat chForests
|
||||
| otherwise = [ FNode fun chForests | not (null chForests) ]
|
||||
where chForests = concat [ applyProfileM unifyManyForests profile forests |
|
||||
forests0 <- children,
|
||||
forests <- mapM applyProfileToForest forests0 ]
|
||||
applyProfileToForest (FString s) = [FString s]
|
||||
applyProfileToForest (FInt n) = [FInt n]
|
||||
applyProfileToForest (FFloat f) = [FFloat f]
|
||||
applyProfileToForest (FMeta) = [FMeta]
|
||||
|
||||
{-
|
||||
-- more intelligent(?) implementation
|
||||
applyProfileToForest (FNode (Name name profile) children)
|
||||
| isCoercion name = concat chForests
|
||||
| otherwise = [ FNode name chForests | not (null chForests) ]
|
||||
where chForests = concat [ mapM (checkProfile forests) profile |
|
||||
forests0 <- children,
|
||||
forests <- mapM applyProfileToForest forests0 ]
|
||||
-}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user