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

example based also with treebank, with real term parser

Browse Source
This commit is contained in:
aarne
2006-03-04 22:14:33 +00:00
parent 84e01c303d
commit 2657c51e04
7 changed files with 95 additions and 102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

36
examples/animal/QuestionsI.gf
View File

@@ -1,23 +1,17 @@
-- File generated by GF from QuestionsI.gfe
--# -resource=../../lib/resource-1.0/english/LangEng.gf
--# -path=.:present:prelude
-- to compile: gf -examples QuestionsI.gfe
-- or use directly gf <mkAnimals.gfs
incomplete concrete QuestionsI of Questions = open Lang in {
lincat
Phrase = Phr ;
Entity = N ;
Action = V2 ;
lin
Who love_V2 man_N = PhrUtt NoPConj (UttAdv (AdvSC (EmbedQS (UseQCl TPres ASimul PPos (QuestVP whoSg_IP (ComplV2 love_V2 (DetCN (DetPl (PlQuant IndefArt) NoNum NoOrd) (UseN man_N)))))))) NoVoc ; -- AMBIGUOUS:
-- PhrUtt NoPConj (UttQS (UseQCl TPres ASimul PPos (QuestVP whoSg_IP (ComplV2 love_V2 (DetCN (DetPl (PlQuant IndefArt) NoNum NoOrd) (UseN man_N)))))) NoVoc ;
Whom man_N love_V2 = PhrUtt NoPConj (UttQS (UseQCl TPres ASimul PPos (QuestSlash whoPl_IP (SlashV2 (DetCN (DetSg (SgQuant DefArt) NoOrd) (UseN man_N)) love_V2)))) NoVoc ; -- AMBIGUOUS:
-- PhrUtt NoPConj (UttQS (UseQCl TPres ASimul PPos (QuestSlash whoSg_IP (SlashV2 (DetCN (DetSg (SgQuant DefArt) NoOrd) (UseN man_N)) love_V2)))) NoVoc ;
Answer woman_N love_V2 man_N = PhrUtt NoPConj (UttS (UseCl TPres ASimul PPos (PredVP (DetCN (DetSg (SgQuant DefArt) NoOrd) (UseN woman_N)) (ComplV2 love_V2 (DetCN (DetPl (PlQuant IndefArt) NoNum NoOrd) (UseN man_N)))))) NoVoc ;
}
lincat Action = V2 ;
lin Answer = \woman_N -> \love_V2 -> \man_N -> % Lang.PhrUtt % Lang.NoPConj (% Lang.UttS (% Lang.UseCl % Lang.TPres % Lang.ASimul % Lang.PPos (% Lang.PredVP (% Lang.DetCN (% Lang.DetSg (% Lang.SgQuant % Lang.DefArt)% Lang.NoOrd)(% Lang.UseN % Lang.woman_N)) (% Lang.ComplV2 % Lang.love_V2 (% Lang.DetCN (% Lang.DetPl (% Lang.PlQuant % Lang.IndefArt)% Lang.NoNum % Lang.NoOrd)(% Lang.UseN % Lang.man_N)))))) % Lang.NoVoc ;
lincat Entity = N ;
lincat Phrase = Phr ;
lin Who = \love_V2 -> \man_N -> in Phr "who lovs men" ;
lin Whom = \man_N -> \love_V2 -> % Lang.PhrUtt % Lang.NoPConj (% Lang.UttQS (% Lang.UseQCl % Lang.TPres % Lang.ASimul % Lang.PPos (% Lang.QuestSlash % Lang.whoPl_IP (% Lang.SlashV2 (% Lang.DetCN (% Lang.DetSg (% Lang.SgQuant % Lang.DefArt)% Lang.NoOrd)(% Lang.UseN % Lang.man_N)) % Lang.love_V2)))) % Lang.NoVoc ;
}
{-
NO PARSE Who
who lovs men
unknown words: lovs
AMBIGUOUS Whom
whom does the man love
PhrUtt NoPConj (UttQS (UseQCl TPres ASimul PPos (QuestSlash whoSg_IP (SlashV2 (DetCN (DetSg (SgQuant DefArt) NoOrd) (UseN man_N)) love_V2)))) NoVoc
-}

4
src/GF.hs
View File

@@ -63,7 +63,7 @@ main = do
return ()
_ | opt makeConcrete -> do
mkConcretes fs
mkConcretes os fs
_ | opt openEditor -> do
system $ "jgf" +++ unwords xs
@@ -88,7 +88,7 @@ main = do
if opt fromExamples
then do
es <- liftM (nub . concat) $ mapM (getGFEFiles os) fs
mkConcretes es
mkConcretes os es
doGF (removeOption fromExamples os) fs
else doGF os fs

145
src/GF/Compile/MkConcrete.hs
View File

@@ -12,15 +12,16 @@
-- Compile a gfe file into a concrete syntax by using the parser on a resource grammar.
-----------------------------------------------------------------------------
module GF.Compile.MkConcrete (mkConcretes,mkCncLine) where
module GF.Compile.MkConcrete (mkConcretes) where
import GF.Grammar.Values (Tree,tree2exp)
import GF.Grammar.PrGrammar (prt_)
import GF.Grammar.Grammar (Term(Q,QC)) ---
import GF.Grammar.Macros (composSafeOp, record2subst)
import GF.Grammar.PrGrammar (prt_,prModule)
import GF.Grammar.Grammar --- (Term(..),SourceModule)
import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent)
import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords)
import GF.Compile.PGrammar (pTerm)
import GF.Compile.PGrammar (pTerm,pTrm)
import GF.Compile.Compile
import GF.Compile.GetGrammar
import GF.API
import GF.API.IOGrammar
import qualified GF.Embed.EmbedAPI as EA
@@ -28,8 +29,10 @@ import qualified GF.Embed.EmbedAPI as EA
import GF.Data.Operations
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Infra.Modules
import GF.Infra.ReadFiles
import GF.System.Arch
import GF.UseGrammar.Treebank
import System.Directory
import Data.Char
@@ -50,38 +53,40 @@ import Data.List
-- notice: we use a hand-crafted lexer and parser in order to preserve
-- the layout and comments in the rest of the file.
mkConcretes :: [FilePath] -> IO ()
mkConcretes files = do
mkConcretes :: Options -> [FilePath] -> IO ()
mkConcretes opts files = do
ress <- mapM getResPath files
let grps = groupBy (\a b -> fst a == fst b) $
sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files
mapM_ mkCncGroups [(rp,map snd gs) | gs@((rp,_):_) <- grps]
mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps]
mkCncGroups ((res,path),files) = do
mkCncGroups opts0 ((res,path),files) = do
putStrLnFlush $ "Going to preprocess examples in " ++ unwords files
putStrLn $ "Compiling resource " ++ res
let opts = options [beSilent,pathList path]
let opts = addOptions (options [beSilent,pathList path]) opts0
let treebank = oElem (iOpt "treebank") opts
egr <- appIOE $ shellStateFromFiles opts emptyShellState res
gr <- err (\s -> putStrLn s >> error "resource grammar rejected")
(return . firstStateGrammar) egr
let parser cat =
errVal ([],"No parse") .
optParseArgErrMsg (options [newMParser, firstCat cat, beVerbose]) gr
let morpho = isKnownWord gr
(parser,morpho) <- if treebank then do
tb <- err (\_ -> error "no treebank")
return
(egr >>= flip findTreebank (zIdent (unsuffixFile res)))
return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb,
isWordInTreebank tb)
else do
gr <- err (\s -> putStrLn s >> error "resource grammar rejected")
(return . firstStateGrammar) egr
return
(\cat s ->
errVal ([],"No parse") $
optParseArgErrMsg (options [newMParser, firstCat cat, beVerbose]) gr s >>=
(\ (ts,e) -> return (map tree2exp ts, e)) ,
isKnownWord gr)
putStrLn "Building parser"
mapM_ (mkConcrete parser morpho) files
type Parser = String -> String -> ([Tree],String)
type Parser = String -> String -> ([Term],String)
type Morpho = String -> Bool
mkConcrete :: Parser -> Morpho -> FilePath -> IO ()
mkConcrete parser morpho file = do
cont <- liftM getExLines $ readFileIf file
let out = suffixFile "gf" $ justModuleName file
writeFile out $ "-- File generated by GF from " ++ file
appendFile out "\n"
mapM_ (mkCnc out parser morpho) cont
getResPath :: FilePath -> IO (String,String)
getResPath file = do
s <- liftM lines $ readFileIf file
@@ -95,62 +100,46 @@ getResPath file = do
"--#":w:_ -> isPrefixOf ('-':tag) w
_ -> False
getExLines :: String -> [Either String String]
getExLines = getl . lines where
getl ls = case ls of
s:ss | begEx (words s) -> case break endEx ls of
(x,y:z) -> Left (unwords (x ++ [y])) : getl z
_ -> Left s : getl ss
s:ss -> Right s : getl ss
[] -> []
begEx s = case s of
"=":"in":_ -> True
_:ws -> begEx ws
_ -> False
endEx s = case dropWhile isSpace (reverse s) of
';':_ -> True
_ -> False
mkCnc :: FilePath -> Parser -> Morpho -> Either String String -> IO ()
mkCnc out parser morpho line = do
let (res,msg) = mkCncLine parser morpho line
appendFile out res
mkConcrete :: Parser -> Morpho -> FilePath -> IO ()
mkConcrete parser morpho file = do
src <- appIOE (getSourceModule noOptions file) >>= err error return
let (src',msgs) = mkModule parser morpho src
let out = suffixFile "gf" $ justModuleName file
writeFile out $ "-- File generated by GF from " ++ file
appendFile out "\n"
ifNull (return ()) putStrLnFlush msg
appendFile out (prModule src')
appendFile out "{-\n"
appendFile out $ unlines $ filter (not . null) msgs
appendFile out "-}\n"
mkCncLine :: (String -> String -> ([Tree],String)) -> (String -> Bool) ->
Either String String -> (String,String)
mkCncLine parser morpho (Right line) = (line,[])
mkCncLine parser morpho (Left line) = mkLinRule (words line) where
mkLinRule s =
let
(pre,str) = span (/= "in") s
([mcat],rest) = splitAt 1 $ tail str
(lin,subst) = span (/= '"') $ tail $ unwords rest
cat = reverse $ takeWhile (/= '.') $ reverse mcat
substs = doSubst (init (tail subst))
def
| last pre /= "=" = line -- ordinary lin rule
| otherwise = case parser cat lin of
(t:ts,_) -> ind ++ unwords pre +++
substs (tree2exp t) +++ ";" ++
if null ts then [] else (" -- AMBIGUOUS:" ++++
unlines ["-- " ++ substs (tree2exp s) +++ ";" | s <- ts])
([],msg) -> "{-" ++ line ++++ morph lin ++++ "-}"
in
(def,def)
mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String])
mkModule parser morpho (name,src) = case src of
ModMod m@(Module mt st fs me ops js) ->
let js1 = jments m
(js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) []
mod2 = ModMod $ Module mt st fs me ops $ js2
in ((name,mod2), msgs)
where
mkInfo ni@(name,info) = case info of
CncFun mt (Yes trm) ppr -> do
trm' <- mkTrm trm
return (name, CncFun mt (Yes trm') ppr)
_ -> return ni
where
mkTrm t = case t of
Example (P _ cat) s -> parse cat s t
Example (Vr cat) s -> parse cat s t
_ -> composOp mkTrm t
parse cat s t = case parser (prt_ cat) s of
(tr:[], _) -> return tr
(tr:trs,_) -> do
updateSTM ((("AMBIGUOUS" +++ prt_ name) : s : map prt_ trs) ++)
return tr
([],ms) -> do
updateSTM ((("NO PARSE" +++ prt_ name) : s : ms : [morph s]) ++)
return t
morph s = case [w | w <- words s, not (morpho w)] of
[] -> ""
ws -> "unknown words: " ++ unwords ws
ind = takeWhile isSpace line
doSubst :: String -> Term -> String
doSubst subst0 trm = prt_ $ subt subst trm where
subst
| all isSpace subst0 = []
| otherwise = err error id $ pTerm subst0 >>= record2subst
subt g t = case t of
Q _ c -> maybe t id $ lookup c g
QC _ c -> maybe t id $ lookup c g
_ -> composSafeOp (subt g) t

1
src/GF/Grammar/Grammar.hs
View File

@@ -128,6 +128,7 @@ data Term =
| Typed Term Term -- ^ type-annotated term
--
-- /below this, the constructors are only for concrete syntax/
| Example Term String -- ^ example-based term: @in M.C "foo"
| RecType [Labelling] -- ^ record type: @{ p : A ; ...}@
| R [Assign] -- ^ record: @{ p = a ; ...}@
| P Term Label -- ^ projection: @r.p@

5
src/GF/Source/GrammarToSource.hs
View File

@@ -35,7 +35,9 @@ trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
trModule :: (Ident,SourceModInfo) -> P.ModDef
trModule (i,mo) = case mo of
ModMod m -> P.MModule compl typ body where
compl = P.CMCompl -- always complete module
compl = case mstatus m of
MSIncomplete -> P.CMIncompl
_ -> P.CMCompl
i' = tri i
typ = case typeOfModule mo of
MTResource -> P.MTResource i'
@@ -140,6 +142,7 @@ trt trm = case trm of
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
Example t s -> P.EExample (trt t) s
R [] -> P.ETuple [] --- to get correct parsing when read back
R r -> P.ERecord $ map trAssign r
RecType r -> P.ERecord $ map trLabelling r

1
src/GF/Source/SourceToGrammar.hs
View File

@@ -437,6 +437,7 @@ transExp x = case x of
EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp)
EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp)
ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp)
EExample exp str -> liftM2 G.Example (transExp exp) (return str)
EProd decl exp -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp)
ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp)

5
src/GF/UseGrammar/Treebank.hs
View File

@@ -25,6 +25,7 @@ module GF.UseGrammar.Treebank (
readMultiTreebank,
lookupTreebank,
assocsTreebank,
isWordInTreebank,
printAssoc
) where
@@ -45,6 +46,7 @@ import GF.Infra.Ident (Ident)
import GF.Infra.UseIO
import qualified GF.Grammar.Abstract as A
import qualified Data.Map as M
import qualified Data.Set as S
-- Generate a treebank with a multilingual grammar. AR 8/2/2006
-- (c) Aarne Ranta 2006 under GNU GPL
@@ -142,6 +144,9 @@ ret = [] -- return ()
assocsTreebank :: UniTreebank -> [(String,[String])]
assocsTreebank = M.assocs
isWordInTreebank :: UniTreebank -> String -> Bool
isWordInTreebank tb w = S.member w (S.fromList (concatMap words (M.keys tb)))
printAssoc (s, ts) = s ++ concat ["\t" ++ t | t <- ts]
getTreebanks :: [String] -> [(String,String,String)]