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

modernized parser in EmbedAPI

Browse Source
This commit is contained in:
aarne
2007-09-05 14:05:42 +00:00
parent 22b4069803
commit f357082c27
15 changed files with 335 additions and 87 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
examples/tutorial/embedded/LexMath.gf Normal file
View File

@@ -0,0 +1,8 @@
interface LexMath = open Syntax in {
oper
even_A : A ;
odd_A : A ;
prime_A : A ;
}

8
examples/tutorial/embedded/LexMathEng.gf Normal file
View File

@@ -0,0 +1,8 @@
instance LexMathEng of LexMath = open SyntaxEng, ParadigmsEng in {
oper
even_A = mkA "even" ;
odd_A = mkA "odd" ;
prime_A = mkA "prime" ;
}

8
examples/tutorial/embedded/LexMathFre.gf Normal file
View File

@@ -0,0 +1,8 @@
instance LexMathFre of LexMath = open SyntaxFre, ParadigmsFre in {
oper
even_A = mkA "pair" ;
odd_A = mkA "impair" ;
prime_A = mkA "premier" ;
}

18
examples/tutorial/embedded/Makefile Normal file
View File

@@ -0,0 +1,18 @@
all: gf hs run
gf:
echo "pm | wf math.gfcm" | gf MathEng.gf MathFre.gf
hs: gf
echo "pg -printer=haskell | wf haskell/GSyntax.hs" | gf math.gfcm
run: hs
ghc --make -o ./math -ihaskell haskell/Run.hs
strip math
clean:
rm -f *.gfc *.gfr haskell/*.o haskell/*.hi
distclean:
rm -f GSyntax.hs math math.gfcm *.gfc *.gfr haskell/*.o haskell/*.hi

14
examples/tutorial/embedded/Math.gf Normal file
View File

@@ -0,0 +1,14 @@
abstract Math = {
cat Answer ; Question ; Object ;
fun
Even : Object -> Question ;
Odd : Object -> Question ;
Prime : Object -> Question ;
Number : Int -> Object ;
Yes : Answer ;
No : Answer ;
}

6
examples/tutorial/embedded/MathEng.gf Normal file
View File

@@ -0,0 +1,6 @@
--# -path=.:present:prelude:mathematical
concrete MathEng of Math = MathI with
(Syntax = SyntaxEng),
(Symbol = SymbolEng),
(LexMath = LexMathEng) ;

6
examples/tutorial/embedded/MathFre.gf Normal file
View File

@@ -0,0 +1,6 @@
--# -path=.:present:prelude:mathematical
concrete MathFre of Math = MathI with
(Syntax = SyntaxFre),
(Symbol = SymbolFre),
(LexMath = LexMathFre) ;

23
examples/tutorial/embedded/MathI.gf Normal file
View File

@@ -0,0 +1,23 @@
incomplete concrete MathI of Math =
open Syntax, Symbol, LexMath in {
flags startcat = Question ; lexer = textlit ; unlexer = text ;
lincat
Answer = Text ;
Question = Text ;
Object = NP ;
lin
Even = questAdj even_A ;
Odd = questAdj odd_A ;
Prime = questAdj prime_A ;
Number n = mkNP (IntPN n) ;
Yes = mkText yes_Phr ;
No = mkText no_Phr ;
oper
questAdj : A -> NP -> Text = \adj,x -> mkText (mkQS (mkCl x adj)) ;
}

41
examples/tutorial/embedded/TransferLoop.hs Normal file
View File

@@ -0,0 +1,41 @@
module Main where
import GF.Embed.EmbedAPI
import GSyntax
main :: IO ()
main = do
gr <- file2grammar "math.gfcm"
loop (translate answerTree gr)
loop :: (String -> String) -> IO ()
loop trans = do
s <- getLine
if s == "quit" then putStrLn "bye" else do
putStrLn $ trans s
loop trans
translate :: (Tree -> Tree) -> MultiGrammar -> String -> String
translate tr gr = unlines . map transLine . lines where
transLine s = case parseAllLang gr (startCat gr) s of
(lg,t:_):_ -> linearize gr lg (tr t)
_ -> "NO PARSE"
answerTree :: Tree -> Tree
answerTree = gf . answer . fg
answer :: GQuestion -> GAnswer
answer p = case p of
GOdd x -> test odd x
GEven x -> test even x
GPrime x -> test prime x
value :: GObject -> Int
value e = case e of
GNumber (GInt i) -> fromInteger i
test :: (Int -> Bool) -> GObject -> GAnswer
test f x = if f (value x) then GYes else GNo
prime :: Int -> Bool
prime = (< 8) ----

16
examples/tutorial/embedded/Translator.hs Normal file
View File

@@ -0,0 +1,16 @@
module Main where
import GF.Embed.EmbedAPI
import System (getArgs)
main :: IO ()
main = do
file:_ <- getArgs
gr <- file2grammar file
interact (translate gr)
translate :: MultiGrammar -> String -> String
translate gr = unlines . map transLine . lines where
transLine s =
let (lang,tree:_):_ = parseAllLang gr (startCat gr) s
in unlines [linearize gr lg tree | lg <- languages gr, lg /= lang]

23
examples/tutorial/embedded/TranslatorLoop.hs Normal file
View File

@@ -0,0 +1,23 @@
module Main where
import GF.Embed.EmbedAPI
import System (getArgs)
main :: IO ()
main = do
file:_ <- getArgs
gr <- file2grammar file
loop (translate gr)
loop :: (String -> String) -> IO ()
loop trans = do
s <- getLine
if s == "quit" then putStrLn "bye" else do
putStrLn $ trans s
loop trans
translate :: MultiGrammar -> String -> String
translate gr = unlines . map transLine . lines where
transLine s = case parseAllLang gr (startCat gr) s of
(lg,t:_):_ -> unlines [linearize gr l t | l <- languages gr, l /= lg]
_ -> "NO PARSE"

100
examples/tutorial/embedded/haskell/GSyntax.hs Normal file
View File

@@ -0,0 +1,100 @@
module GSyntax where
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.PrGrammar
import GF.Grammar.Macros
import GF.Data.Operations
----------------------------------------------------
-- automatic translation from GF to Haskell
----------------------------------------------------
class Gf a where gf :: a -> Trm
class Fg a where fg :: Trm -> a
newtype GString = GString String deriving Show
instance Gf GString where
gf (GString s) = K s
instance Fg GString where
fg t =
case termForm t of
Ok ([], K s ,[]) -> GString s
_ -> error ("no GString " ++ prt t)
newtype GInt = GInt Integer deriving Show
instance Gf GInt where
gf (GInt s) = EInt s
instance Fg GInt where
fg t =
case termForm t of
Ok ([], EInt s ,[]) -> GInt s
_ -> error ("no GInt " ++ prt t)
newtype GFloat = GFloat Double deriving Show
instance Gf GFloat where
gf (GFloat s) = EFloat s
instance Fg GFloat where
fg t =
case termForm t of
Ok ([], EFloat s ,[]) -> GFloat s
_ -> error ("no GFloat " ++ prt t)
----------------------------------------------------
-- below this line machine-generated
----------------------------------------------------
data GAnswer =
GYes
| GNo
deriving Show
data GObject = GNumber GInt
deriving Show
data GQuestion =
GPrime GObject
| GOdd GObject
| GEven GObject
deriving Show
instance Gf GAnswer where
gf GYes = appqc "Math" "Yes" []
gf GNo = appqc "Math" "No" []
instance Gf GObject where gf (GNumber x1) = appqc "Math" "Number" [gf x1]
instance Gf GQuestion where
gf (GPrime x1) = appqc "Math" "Prime" [gf x1]
gf (GOdd x1) = appqc "Math" "Odd" [gf x1]
gf (GEven x1) = appqc "Math" "Even" [gf x1]
instance Fg GAnswer where
fg t =
case termForm t of
Ok ([], Q (IC "Math") (IC "Yes"),[]) -> GYes
Ok ([], Q (IC "Math") (IC "No"),[]) -> GNo
_ -> error ("no Answer " ++ prt t)
instance Fg GObject where
fg t =
case termForm t of
Ok ([], Q (IC "Math") (IC "Number"),[x1]) -> GNumber (fg x1)
_ -> error ("no Object " ++ prt t)
instance Fg GQuestion where
fg t =
case termForm t of
Ok ([], Q (IC "Math") (IC "Prime"),[x1]) -> GPrime (fg x1)
Ok ([], Q (IC "Math") (IC "Odd"),[x1]) -> GOdd (fg x1)
Ok ([], Q (IC "Math") (IC "Even"),[x1]) -> GEven (fg x1)
_ -> error ("no Question " ++ prt t)

38
examples/tutorial/embedded/haskell/Run.hs Normal file
View File

@@ -0,0 +1,38 @@
module Main where
import GSyntax
import GF.Embed.EmbedAPI
main :: IO ()
main = do
gr <- file2grammar "math.gfcm"
loop gr
loop :: MultiGrammar -> IO ()
loop gr = do
s <- getLine
interpret gr s
loop gr
interpret :: MultiGrammar -> String -> IO ()
interpret gr s = do
let ltss = parseAllLang gr "Question" s
case ltss of
[] -> putStrLn "no parse"
(l,t:_):_ -> putStrLn $ linearize gr l $ gf $ answer $ fg t
answer :: GQuestion -> GAnswer
answer p = case p of
GOdd x -> test odd x
GEven x -> test even x
GPrime x -> test prime x
value :: GObject -> Int
value e = case e of
GNumber (GInt i) -> fromInteger i
test :: (Int -> Bool) -> GObject -> GAnswer
test f x = if f (value x) then GYes else GNo
prime :: Int -> Bool
prime = (< 8) ----

23
src/GF/Embed/EmbedAPI.hs
View File

@@ -15,7 +15,7 @@
module GF.Embed.EmbedAPI where
import GF.Compile.ShellState (ShellState,grammar2shellState,canModules,stateGrammarOfLang,abstract,grammar,firstStateGrammar,allLanguages,allCategories,stateOptions)
import GF.Compile.ShellState (ShellState,grammar2shellState,canModules,stateGrammarOfLang,abstract,grammar,firstStateGrammar,allLanguages,allCategories,stateOptions,firstAbsCat)
import GF.UseGrammar.Linear (linTree2string)
import GF.UseGrammar.GetTree (string2tree)
import GF.Embed.EmbedParsing (parseString)
@@ -53,8 +53,11 @@ file2grammar :: FilePath -> IO MultiGrammar
linearize :: MultiGrammar -> Language -> Tree -> String
parse :: MultiGrammar -> Language -> Category -> String -> [Tree]
linearizeAll :: MultiGrammar -> Tree -> [String]
parseAll :: MultiGrammar -> Category -> String -> [[Tree]]
linearizeAll :: MultiGrammar -> Tree -> [String]
linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)]
parseAll :: MultiGrammar -> Category -> String -> [[Tree]]
parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])]
readTree :: MultiGrammar -> String -> Tree
showTree :: Tree -> String
@@ -62,6 +65,8 @@ showTree :: Tree -> String
languages :: MultiGrammar -> [Language]
categories :: MultiGrammar -> [Category]
startCat :: MultiGrammar -> Category
---------------------------------------------------
-- Implementation
---------------------------------------------------
@@ -84,15 +89,19 @@ linearize mgr lang =
parse mgr lang cat =
map tree2exp .
errVal [] .
parseString noOptions sgr cfcat
parseString (stateOptions sgr) sgr cfcat
where
sgr = stateGrammarOfLang mgr (zIdent lang)
cfcat = string2CFCat abs cat
abs = maybe (error "no abstract syntax") prIdent $ abstract mgr
linearizeAll mgr t = [linearize mgr lang t | lang <- languages mgr]
linearizeAll mgr = map snd . linearizeAllLang mgr
linearizeAllLang mgr t = [(lang,linearize mgr lang t) | lang <- languages mgr]
parseAll mgr cat s = [parse mgr lang cat s | lang <- languages mgr]
parseAll mgr cat = map snd . parseAllLang mgr cat
parseAllLang mgr cat s =
[(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)]
readTree mgr s = tree2exp $ string2tree (firstStateGrammar mgr) s
@@ -101,3 +110,5 @@ showTree t = prt_ t
languages mgr = [prt_ l | l <- allLanguages mgr]
categories mgr = [prt_ c | (_,c) <- allCategories mgr]
startCat = prt_ . snd . firstAbsCat noOptions . firstStateGrammar

90
src/GF/Embed/EmbedParsing.hs
View File

@@ -33,8 +33,7 @@ import GF.Infra.Option
import GF.Compile.ShellState
import GF.Embed.EmbedCustom
import GF.CF.PPrCF (prCFTree)
import qualified GF.OldParsing.ParseCF as PCFOld -- OBSOLETE
import qualified GF.Parsing.GFC as New
-- import qualified GF.Parsing.GFC as New
@@ -55,83 +54,12 @@ parseStringMsg os sg cat s = do
return (ts,unlines ss)
parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree]
parseStringC opts0 sg cat s
| otherwise = do
let opts = unionOptions opts0 $ stateOptions sg
cf = stateCF sg
gr = stateGrammarST sg
cn = cncId sg
tok = customOrDefault opts useTokenizer customTokenizer sg
parser = PCFOld.parse "ibn" (stateCF sg) cat -- customOrDefault opts useParser customParser sg cat
tokens2trms opts sg cn parser (tok s)
tokens2trms :: Options ->StateGrammar ->Ident -> CFParser -> [CFTok] -> Check [Tree]
tokens2trms opts sg cn parser toks = trees2trms opts sg cn toks trees info
where result = parser toks
info = snd result
trees = {- nub $ -} cfParseResults result -- peb 25/5-04: removed nub (O(n^2))
trees2trms :: Options -> StateGrammar -> Ident -> [CFTok] -> [CFTree] -> String -> Check [Tree]
trees2trms opts sg cn as ts0 info = do
ts <- case () of
_ | null ts0 -> checkWarn "No success in cf parsing" >> return []
_ | raw -> do
ts1 <- return (map cf2trm0 ts0) ----- should not need annot
checks [
mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated, often fails
,checkWarn (unlines ("Raw CF trees:":(map prCFTree ts0))) >> return []
]
_ -> do
let num = optIntOrN opts flagRawtrees 999999
let (ts01,rest) = splitAt num ts0
if null rest then return ()
else checkWarn ("Warning: only" +++ show num +++ "raw parses out of" +++
show (length ts0) +++
"considered; use -rawtrees=<Int> to see more"
)
(ts1,ss) <- checkErr $ mapErrN 1 postParse ts01
if null ts1 then raise ss else return ()
ts2 <- mapM (checkErr . annotate gr . refreshMetas [] . trExp) ts1 ----
if forgive then return ts2 else do
let tsss = [(t, allLinsOfTree gr cn t) | t <- ts2]
ps = [t | (t,ss) <- tsss,
any (compatToks as) (map str2cftoks ss)]
if null ps
then raise $ "Failure in morphology." ++
if verb
then "\nPossible corrections: " +++++
unlines (nub (map sstr (concatMap snd tsss)))
else ""
else return ps
if verb
then checkWarn $ " the token list" +++ show as ++++ unknown as +++++ info
else return ()
return $ optIntOrAll opts flagNumber $ nub ts
where
gr = stateGrammarST sg
raw = oElem rawParse opts
verb = oElem beVerbose opts
forgive = oElem forgiveParse opts
unknown ts = case filter noMatch [t | t@(TS _) <- ts] of
[] -> "where all words are known"
us -> "with the unknown tokens" +++ show us --- needs to be fixed for literals
terminals = map TS $ stateGrammarWords sg
noMatch t = all (not . compatTok t) terminals
--- too much type checking in building term info? return FullTerm to save work?
-- | raw parsing: so simple it is for a context-free CF grammar
cf2trm0 :: CFTree -> C.Exp
cf2trm0 (CFTree (fun, (_, trees))) = mkAppAtom (cffun2trm fun) (map cf2trm0 trees)
where
cffun2trm (CFFun (fun,_)) = fun
mkApp = foldl C.EApp
mkAppAtom a = mkApp (C.EAtom a)
parseStringC opts0 sg cat s = do
let opts = unionOptions opts0 $ stateOptions sg
algorithm = "f" -- default algorithm: FCFG
strategy = "bottomup"
tokenizer = customOrDefault opts useTokenizer customTokenizer sg
toks = tokenizer s
ts <- checkErr $ New.parse algorithm strategy (pInfo sg) (absId sg) cat toks
checkErr $ allChecks $ map (annotate (stateGrammarST sg) . refreshMetas []) ts