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

now the parser could return partial parse results

Browse Source
This commit is contained in:
krasimir
2010-05-19 12:31:36 +00:00
parent ec227abe43
commit 31856ebb4c
4 changed files with 56 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1004,9 +1004,7 @@ allCommands env@(pgf, mos) = Map.fromList [
toString = unwords . toStrings toString = unwords . toStrings
fromParse opts ts parses fromParse opts ts parses
| isOpt "bracket" opts = case catMaybes bss of | isOpt "bracket" opts = ([], unlines $ map showBracketedString bss)
[] -> ([], "no brackets found")
bss -> ([], unlines $ map showBracketedString bss)
| otherwise = case ts of | otherwise = case ts of
[] -> ([], "no trees found" ++ [] -> ([], "no trees found" ++
missingWordMsg (optMorpho opts) (concatMap words (toStrings ts)) missingWordMsg (optMorpho opts) (concatMap words (toStrings ts))

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

@@ -154,10 +154,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.ParseResult,Maybe BracketedString) parse_ :: PGF -> Language -> Type -> String -> (Parse.ParseResult,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.ParseResult,Maybe BracketedString) parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> (Parse.ParseResult,BracketedString)
-- | The same as 'generateAllDepth' but does not limit -- | The same as 'generateAllDepth' but does not limit
-- the depth in the generation, and doesn't give an initial expression. -- the depth in the generation, and doesn't give an initial expression.

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

@@ -32,8 +32,7 @@ data Forest
{ abstr :: Abstr { abstr :: Abstr
, concr :: Concr , concr :: Concr
, forest :: IntMap.IntMap (Set.Set Production) , forest :: IntMap.IntMap (Set.Set Production)
, root :: {-# UNPACK #-} !FId , root :: [([Symbol],[FId])]
, label :: {-# UNPACK #-} !LIndex
} }
-------------------------------------------------------------------- --------------------------------------------------------------------
@@ -49,11 +48,13 @@ linearizeWithBrackets = head . snd . untokn "" . bracketedTokn
-- --
bracketedTokn :: Forest -> BracketedTokn bracketedTokn :: Forest -> BracketedTokn
bracketedTokn (Forest abs cnc forest root label) = bracketedTokn (Forest abs cnc forest root) =
let (fid,cat,lin) = render IntMap.empty root case [computeSeq seq (map (render IntMap.empty) args) | (seq,args) <- root] of
in Bracket_ cat fid label (lin ! label) ([bs@(Bracket_ cat fid label lin)]:_) -> bs
(bss:_) -> Bracket_ wildCId 0 0 bss
[] -> Bracket_ wildCId 0 0 []
where where
trusted = trustedSpots IntSet.empty root trusted = foldl1 IntSet.intersection [IntSet.unions (map (trustedSpots IntSet.empty) args) | (_,args) <- root]
render parents fid = render parents fid =
case (IntMap.lookup fid parents) `mplus` (fmap Set.toList $ IntMap.lookup fid forest) of case (IntMap.lookup fid parents) `mplus` (fmap Set.toList $ IntMap.lookup fid forest) of
@@ -63,12 +64,16 @@ bracketedTokn (Forest abs cnc forest root label) =
descend parents (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid descend parents (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid
Just (DTyp _ cat _,_,_) = Map.lookup fun (funs abs) Just (DTyp _ cat _,_,_) = Map.lookup fun (funs abs)
largs = map (render parents) args largs = map (render parents) args
in (fid,cat,listArray (bounds lins) [computeSeq seqid largs | seqid <- elems lins]) ltable = listArray (bounds lins)
[computeSeq (elems (sequences cnc ! seqid)) largs |
seqid <- elems lins]
in (fid,cat,ltable)
descend parents (PCoerce fid) = render parents fid descend parents (PCoerce fid) = render parents fid
descend parents (PConst cat _ ts) = (fid,cat,listArray (0,0) [[LeafKS ts]]) descend parents (PConst cat _ ts) = (fid,cat,listArray (0,0) [[LeafKS ts]])
trustedSpots parents fid trustedSpots parents fid
| IntSet.member fid parents | fid < totalCats cnc || -- forest ids from the grammar correspond to metavariables
IntSet.member fid parents -- this avoids loops in the grammar
= IntSet.empty = IntSet.empty
| otherwise = IntSet.insert fid $ | otherwise = IntSet.insert fid $
case IntMap.lookup fid forest of case IntMap.lookup fid forest of
@@ -81,11 +86,9 @@ bracketedTokn (Forest abs cnc forest root label) =
descend (PCoerce fid) = trustedSpots parents' fid descend (PCoerce fid) = trustedSpots parents' fid
descend (PConst c e _) = IntSet.empty descend (PConst c e _) = IntSet.empty
computeSeq :: SeqId -> [(FId,CId,LinTable)] -> [BracketedTokn] computeSeq :: [Symbol] -> [(FId,CId,LinTable)] -> [BracketedTokn]
computeSeq seqid args = concatMap compute (elems seq) computeSeq seq args = concatMap compute seq
where where
seq = sequences cnc ! seqid
compute (SymCat d r) = getArg d r compute (SymCat d r) = getArg d r
compute (SymLit d r) = getArg d r compute (SymLit d r) = getArg d r
compute (SymKS ts) = [LeafKS ts] compute (SymKS ts) = [LeafKS ts]

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

@@ -38,16 +38,16 @@ data ParseResult
-- if there are many analizes for some phrase but they all are not type correct. -- if there are many analizes for some phrase but they all are not type correct.
| ParseResult [Tree] -- ^ If the parsing was successful we get a list of abstract syntax trees. The list should be non-empty. | ParseResult [Tree] -- ^ If the parsing was successful we get a list of abstract syntax trees. The list should be non-empty.
parse :: PGF -> Language -> Type -> [String] -> (ParseResult,Maybe BracketedString) parse :: PGF -> Language -> Type -> [String] -> (ParseResult,BracketedString)
parse pgf lang typ toks = loop (initState pgf lang typ) toks parse pgf lang typ toks = loop (initState pgf lang typ) toks
where where
loop ps [] = getParseResult ps typ loop ps [] = getParseResult ps typ
loop ps (t:ts) = case nextState ps t of loop ps (t:ts) = case nextState ps t of
Left es -> case es of Left es -> case es of
EState _ _ chart -> (ParseFailed (offset chart),Nothing) EState _ _ chart -> (ParseFailed (offset chart),snd (getParseResult ps typ))
Right ps -> loop ps ts Right ps -> loop ps ts
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> (ParseResult,Maybe BracketedString) parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> (ParseResult,BracketedString)
parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks
where where
accept ps [] = getParseResult ps typ accept ps [] = getParseResult ps typ
@@ -155,11 +155,13 @@ 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.
getParseResult :: ParseState -> Type -> (ParseResult,Maybe BracketedString) getParseResult :: ParseState -> Type -> (ParseResult,BracketedString)
getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) = getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
let mb_bs = case roots of let froots | null roots = getPartialSeq (sequences cnc) (reverse (active st : actives st)) acc1
((AK fid lbl):_) -> Just $ linearizeWithBrackets $ Forest (abstract pgf) cnc (forest st) fid lbl | otherwise = [([SymCat 0 lbl],[fid]) | AK fid lbl <- roots]
_ -> Nothing
bs = linearizeWithBrackets (Forest (abstract pgf) cnc (forest st) froots)
exps = nubsort $ do exps = nubsort $ do
(AK fid lbl) <- roots (AK fid lbl) <- roots
@@ -172,11 +174,15 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
then ParseFailed (offset chart) then ParseFailed (offset chart)
else ParseResult exps else ParseResult exps
in (res,mb_bs) in (res,bs)
where where
(mb_agenda,acc) = TMap.decompose items (mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
(_,st) = process Nothing (\_ _ -> id) (sequences cnc) (cncfuns cnc) agenda () chart (acc1,st) = process Nothing add (sequences cnc) (cncfuns cnc) agenda [] chart
add _ (Active j ppos funid seqid args key) items = (j,lin,args,key) : items
where
lin = take (ppos-1) (elems (unsafeAt (sequences cnc) seqid))
roots = case Map.lookup start (cnccats cnc) of roots = case Map.lookup start (cnccats cnc) of
Just (CncCat s e lbls) -> do cat <- range (s,e) Just (CncCat s e lbls) -> do cat <- range (s,e)
@@ -187,18 +193,18 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
go rec fcat' (d,fcat) go rec fcat' (d,fcat)
| fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments | fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
| Set.member fcat rec = mzero | Set.member fcat rec = mzero
| otherwise = foldForest (\funid args trees -> | otherwise = foldForest (\funid args trees ->
do let CncFun fn lins = cncfuns cnc ! funid do let CncFun fn lins = cncfuns cnc ! funid
args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args) args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args)
check_ho_fun fn args check_ho_fun fn args
`mplus` `mplus`
trees) trees)
(\const _ trees -> (\const _ trees ->
return (freeVar const,const) return (freeVar const,const)
`mplus` `mplus`
trees) trees)
[] fcat (forest st) [] fcat (forest st)
check_ho_fun fun args check_ho_fun fun args
| fun == _V = return (head args) | fun == _V = return (head args)
@@ -211,6 +217,25 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
freeVar (EFun v) = Set.singleton v freeVar (EFun v) = Set.singleton v
freeVar _ = Set.empty freeVar _ = Set.empty
getPartialSeq seqs actives = expand Set.empty
where
expand acc [] =
[(lin,args) | (j,lin,args,key) <- Set.toList acc, j == 0]
expand acc (item@(j,lin,args,key) : items)
| item `Set.member` acc = expand acc items
| otherwise = expand acc' items'
where
acc' = Set.insert item acc
items' = case lookupAC key (actives !! j) of
Nothing -> items
Just set -> [if j' < j
then let lin' = take ppos (elems (unsafeAt seqs seqid))
in (j',lin'++map (inc (length args')) lin,args'++args,key')
else (j',lin,args,key') | Active j' ppos funid seqid args' key' <- Set.toList set] ++ items
inc n (SymCat d r) = SymCat (n+d) r
inc n (SymLit d r) = SymLit (n+d) r
inc n s = s
process mbt fn !seqs !funs [] acc chart = (acc,chart) process mbt fn !seqs !funs [] acc chart = (acc,chart)
process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart