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

added explicit depth parameter to the parsing API and the corresponding command in the shell

Browse Source
This commit is contained in:
krasimir
2010-10-18 16:51:25 +00:00
parent afce46b386
commit 51452d4ef0
5 changed files with 35 additions and 32 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
src/compiler/GF/Command/Commands.hs
View File

@@ -492,7 +492,8 @@ allCommands env@(pgf, mos) = Map.fromList [
flags = [ flags = [
("cat","target category of parsing"), ("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)"), ("lang","the languages of parsing (comma-separated, no spaces)"),
("openclass","list of open-class categories for robust parsing") ("openclass","list of open-class categories for robust parsing"),
("depth","maximal depth for proof search if the abstract syntax tree has meta variables")
], ],
options = [ options = [
("bracket","prints the bracketed string from the parser") ("bracket","prints the bracketed string from the parser")
@@ -902,8 +903,10 @@ allCommands env@(pgf, mos) = Map.fromList [
] ]
where where
par opts s = case optOpenTypes opts of par opts s = case optOpenTypes opts of
[] -> [parse_ pgf lang (optType opts) s | lang <- optLangs opts] [] -> [parse_ pgf lang (optType opts) (Just dp) s | lang <- optLangs opts]
open_typs -> [parseWithRecovery pgf lang (optType opts) open_typs s | lang <- optLangs opts] open_typs -> [parseWithRecovery pgf lang (optType opts) open_typs (Just dp) s | lang <- optLangs opts]
where
dp = valIntOpts "depth" 4 opts
void = ([],[]) void = ([],[])
@@ -993,7 +996,7 @@ allCommands env@(pgf, mos) = Map.fromList [
Just ty -> case checkType pgf ty of Just ty -> case checkType pgf ty of
Left tcErr -> error $ render (ppTcError tcErr) Left tcErr -> error $ render (ppTcError tcErr)
Right ty -> ty Right ty -> ty
Nothing -> error ("Can't parse '"++str++"' as type") Nothing -> error ("Can't parse '"++str++"' as a type")
optComm opts = valStrOpts "command" "" opts optComm opts = valStrOpts "command" "" opts
optViewFormat opts = valStrOpts "format" "png" opts optViewFormat opts = valStrOpts "format" "png" opts
optViewGraph opts = valStrOpts "view" "open" opts optViewGraph opts = valStrOpts "view" "open" opts

2
src/compiler/GF/Compile/ExampleBased.hs
View File

@@ -41,7 +41,7 @@ convertFile conf src file = do
convEx (cat,ex) = do convEx (cat,ex) = do
appn "(" appn "("
let typ = maybe (error "no valid cat") id $ readType cat let typ = maybe (error "no valid cat") id $ readType cat
ws <- case fst (parse_ pgf lang typ ex) of ws <- case fst (parse_ pgf lang typ (Just 4) ex) of
ParseFailed _ -> do ParseFailed _ -> do
let ws = morphoMissing morpho (words ex) let ws = morphoMissing morpho (words ex)
appv ("WARNING: cannot parse example " ++ ex) appv ("WARNING: cannot parse example " ++ ex)

14
src/runtime/haskell/PGF.hs
View File

@@ -182,10 +182,10 @@ parseAll :: PGF -> Type -> String -> [[Tree]]
parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])] parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
-- | The same as 'parse' but returns more detailed information -- | The same as 'parse' but returns more detailed information
parse_ :: PGF -> Language -> Type -> String -> (Parse.ParseOutput,BracketedString) parse_ :: PGF -> Language -> Type -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
-- | This is an experimental function. Use it on your own risk -- | This is an experimental function. Use it on your own risk
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> (Parse.ParseOutput,BracketedString) parseWithRecovery :: PGF -> Language -> Type -> [Type] -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
-- | List of all languages available in the given grammar. -- | List of all languages available in the given grammar.
languages :: PGF -> [Language] languages :: PGF -> [Language]
@@ -227,21 +227,21 @@ functionType :: PGF -> CId -> Maybe Type
readPGF f = decodeFile f readPGF f = decodeFile f
parse pgf lang typ s = parse pgf lang typ s =
case parse_ pgf lang typ s of case parse_ pgf lang typ (Just 4) s of
(Parse.ParseOk ts,_) -> ts (Parse.ParseOk ts,_) -> ts
_ -> [] _ -> []
parseAll mgr typ = map snd . parseAllLang mgr typ parseAll mgr typ = map snd . parseAllLang mgr typ
parseAllLang mgr typ s = parseAllLang mgr typ s =
[(lang,ts) | lang <- languages mgr, (Parse.ParseOk ts,_) <- [parse_ mgr lang typ s]] [(lang,ts) | lang <- languages mgr, (Parse.ParseOk ts,_) <- [parse_ mgr lang typ (Just 4) s]]
parse_ pgf lang typ s = parse_ pgf lang typ dp s =
case Map.lookup lang (concretes pgf) of case Map.lookup lang (concretes pgf) of
Just cnc -> Parse.parse pgf lang typ (words s) Just cnc -> Parse.parse pgf lang typ dp (words s)
Nothing -> error ("Unknown language: " ++ showCId lang) Nothing -> error ("Unknown language: " ++ showCId lang)
parseWithRecovery pgf lang typ open_typs s = Parse.parseWithRecovery pgf lang typ open_typs (words s) parseWithRecovery pgf lang typ open_typs dp s = Parse.parseWithRecovery pgf lang typ open_typs dp (words s)
groupResults :: [[(Language,String)]] -> [(Language,[String])] groupResults :: [[(Language,String)]] -> [(Language,[String])]
groupResults = Map.toList . foldr more Map.empty . start . concat groupResults = Map.toList . foldr more Map.empty . start . concat

16
src/runtime/haskell/PGF/Forest.hs
View File

@@ -47,16 +47,16 @@ data Forest
-- Rendering of bracketed strings -- Rendering of bracketed strings
-------------------------------------------------------------------- --------------------------------------------------------------------
linearizeWithBrackets :: Forest -> BracketedString linearizeWithBrackets :: Maybe Int -> Forest -> BracketedString
linearizeWithBrackets = head . snd . untokn "" . bracketedTokn linearizeWithBrackets dp = head . snd . untokn "" . bracketedTokn dp
--------------------------------------------------------------- ---------------------------------------------------------------
-- Internally we have to do everything with Tokn first because -- Internally we have to do everything with Tokn first because
-- we must handle the pre {...} construction. -- we must handle the pre {...} construction.
-- --
bracketedTokn :: Forest -> BracketedTokn bracketedTokn :: Maybe Int -> Forest -> BracketedTokn
bracketedTokn f@(Forest abs cnc forest root) = bracketedTokn dp f@(Forest abs cnc forest root) =
case [computeSeq isTrusted seq (map (render forest) args) | (seq,args) <- root] of case [computeSeq isTrusted seq (map (render forest) args) | (seq,args) <- root] of
([bs@(Bracket_ _ _ _ _ _)]:_) -> bs ([bs@(Bracket_ _ _ _ _ _)]:_) -> bs
(bss:_) -> Bracket_ wildCId 0 0 [] bss (bss:_) -> Bracket_ wildCId 0 0 [] bss
@@ -79,7 +79,7 @@ bracketedTokn f@(Forest abs cnc forest root) =
Just (DTyp _ cat _,_,_,_) -> cat Just (DTyp _ cat _,_,_,_) -> cat
largs = map (render forest) args largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),either (const []) id $ getAbsTrees f arg Nothing,ltable) in ((cat,fid),either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
descend forest (PCoerce fid) = render forest (PArg [] fid) descend forest (PCoerce fid) = render forest (PArg [] fid)
descend forest (PConst cat e ts) = ((cat,fid),[e],([],listArray (0,0) [[LeafKS ts]])) descend forest (PConst cat e ts) = ((cat,fid),[e],([],listArray (0,0) [[LeafKS ts]]))
@@ -116,10 +116,10 @@ isLindefCId id
-- that spans the whole input consumed so far. The trees are also -- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually -- limited by the category specified, which is usually
-- the same as the startup category. -- the same as the startup category.
getAbsTrees :: Forest -> PArg -> Maybe Type -> Either [(FId,TcError)] [Expr] getAbsTrees :: Forest -> PArg -> Maybe Type -> Maybe Int -> Either [(FId,TcError)] [Expr]
getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty = getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty dp =
let (err,res) = runTcM abs (do e <- go Set.empty emptyScope (fmap (TTyp []) ty) arg let (err,res) = runTcM abs (do e <- go Set.empty emptyScope (fmap (TTyp []) ty) arg
generateForForest (prove (Just 20)) e) fid IntMap.empty generateForForest (prove dp) e) fid IntMap.empty
in if null res in if null res
then Left (nub err) then Left (nub err)
else Right (nubsort [e | (_,_,e) <- res]) else Right (nubsort [e | (_,_,e) <- res])

24
src/runtime/haskell/PGF/Parse.hs
View File

@@ -52,25 +52,25 @@ data ParseOutput
-- The list should be non-empty. -- The list should be non-empty.
| ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced | ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced
parse :: PGF -> Language -> Type -> [Token] -> (ParseOutput,BracketedString) parse :: PGF -> Language -> Type -> Maybe Int -> [Token] -> (ParseOutput,BracketedString)
parse pgf lang typ toks = loop (initState pgf lang typ) toks parse pgf lang typ dp toks = loop (initState pgf lang typ) toks
where where
loop ps [] = getParseOutput ps typ loop ps [] = getParseOutput ps typ dp
loop ps (t:ts) = case nextState ps (simpleParseInput t) of loop ps (t:ts) = case nextState ps (simpleParseInput t) of
Left es -> case es of Left es -> case es of
EState _ _ chart -> (ParseFailed (offset chart),snd (getParseOutput ps typ)) EState _ _ chart -> (ParseFailed (offset chart),snd (getParseOutput ps typ dp))
Right ps -> loop ps ts Right ps -> loop ps ts
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> (ParseOutput,BracketedString) parseWithRecovery :: PGF -> Language -> Type -> [Type] -> Maybe Int -> [String] -> (ParseOutput,BracketedString)
parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks parseWithRecovery pgf lang typ open_typs dp toks = accept (initState pgf lang typ) toks
where where
accept ps [] = getParseOutput ps typ accept ps [] = getParseOutput ps typ dp
accept ps (t:ts) = accept ps (t:ts) =
case nextState ps (simpleParseInput t) of case nextState ps (simpleParseInput t) of
Right ps -> accept ps ts Right ps -> accept ps ts
Left es -> skip (recoveryStates open_typs es) ts Left es -> skip (recoveryStates open_typs es) ts
skip ps_map [] = getParseOutput (fst ps_map) typ skip ps_map [] = getParseOutput (fst ps_map) typ dp
skip ps_map (t:ts) = skip ps_map (t:ts) =
case Map.lookup t (snd ps_map) of case Map.lookup t (snd ps_map) of
Just ps -> accept ps ts Just ps -> accept ps ts
@@ -210,19 +210,19 @@ recoveryStates open_types (EState pgf cnc chart) =
-- that spans the whole input consumed so far. The trees are also -- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually -- limited by the category specified, which is usually
-- the same as the startup category. -- the same as the startup category.
getParseOutput :: ParseState -> Type -> (ParseOutput,BracketedString) getParseOutput :: ParseState -> Type -> Maybe Int -> (ParseOutput,BracketedString)
getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) = getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) dp =
let froots | null roots = getPartialSeq (sequences cnc) (reverse (active chart1 : actives chart1)) seq let froots | null roots = getPartialSeq (sequences cnc) (reverse (active chart1 : actives chart1)) seq
| otherwise = [([SymCat 0 lbl],[PArg [] fid]) | AK fid lbl <- roots] | otherwise = [([SymCat 0 lbl],[PArg [] fid]) | AK fid lbl <- roots]
f = Forest (abstract pgf) cnc (forest chart1) froots f = Forest (abstract pgf) cnc (forest chart1) froots
bs = linearizeWithBrackets f bs = linearizeWithBrackets dp f
res | not (null es) = ParseOk es res | not (null es) = ParseOk es
| not (null errs) = TypeError errs | not (null errs) = TypeError errs
| otherwise = ParseIncomplete | otherwise = ParseIncomplete
where xs = [getAbsTrees f (PArg [] fid) (Just ty) | (AK fid lbl) <- roots] where xs = [getAbsTrees f (PArg [] fid) (Just ty) dp | (AK fid lbl) <- roots]
es = concat [es | Right es <- xs] es = concat [es | Right es <- xs]
errs = concat [errs | Left errs <- xs] errs = concat [errs | Left errs <- xs]