diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 2de7fb9cf..2ea3e169c 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1004,9 +1004,7 @@ allCommands env@(pgf, mos) = Map.fromList [ toString = unwords . toStrings fromParse opts ts parses - | isOpt "bracket" opts = case catMaybes bss of - [] -> ([], "no brackets found") - bss -> ([], unlines $ map showBracketedString bss) + | isOpt "bracket" opts = ([], unlines $ map showBracketedString bss) | otherwise = case ts of [] -> ([], "no trees found" ++ missingWordMsg (optMorpho opts) (concatMap words (toStrings ts)) diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 26a727a47..128a58a35 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -154,10 +154,10 @@ parseAll :: PGF -> Type -> String -> [[Tree]] parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])] -- | 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 -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 depth in the generation, and doesn't give an initial expression. diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index 428ee276a..4c59ce0d9 100644 --- a/src/runtime/haskell/PGF/Forest.hs +++ b/src/runtime/haskell/PGF/Forest.hs @@ -32,8 +32,7 @@ data Forest { abstr :: Abstr , concr :: Concr , forest :: IntMap.IntMap (Set.Set Production) - , root :: {-# UNPACK #-} !FId - , label :: {-# UNPACK #-} !LIndex + , root :: [([Symbol],[FId])] } -------------------------------------------------------------------- @@ -49,11 +48,13 @@ linearizeWithBrackets = head . snd . untokn "" . bracketedTokn -- bracketedTokn :: Forest -> BracketedTokn -bracketedTokn (Forest abs cnc forest root label) = - let (fid,cat,lin) = render IntMap.empty root - in Bracket_ cat fid label (lin ! label) +bracketedTokn (Forest abs cnc forest root) = + case [computeSeq seq (map (render IntMap.empty) args) | (seq,args) <- root] of + ([bs@(Bracket_ cat fid label lin)]:_) -> bs + (bss:_) -> Bracket_ wildCId 0 0 bss + [] -> Bracket_ wildCId 0 0 [] where - trusted = trustedSpots IntSet.empty root + trusted = foldl1 IntSet.intersection [IntSet.unions (map (trustedSpots IntSet.empty) args) | (_,args) <- root] render parents fid = 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 Just (DTyp _ cat _,_,_) = Map.lookup fun (funs abs) 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 (PConst cat _ ts) = (fid,cat,listArray (0,0) [[LeafKS ts]]) 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 | otherwise = IntSet.insert fid $ case IntMap.lookup fid forest of @@ -81,11 +86,9 @@ bracketedTokn (Forest abs cnc forest root label) = descend (PCoerce fid) = trustedSpots parents' fid descend (PConst c e _) = IntSet.empty - computeSeq :: SeqId -> [(FId,CId,LinTable)] -> [BracketedTokn] - computeSeq seqid args = concatMap compute (elems seq) + computeSeq :: [Symbol] -> [(FId,CId,LinTable)] -> [BracketedTokn] + computeSeq seq args = concatMap compute seq where - seq = sequences cnc ! seqid - compute (SymCat d r) = getArg d r compute (SymLit d r) = getArg d r compute (SymKS ts) = [LeafKS ts] diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs index 9ae28bdab..ce195f752 100644 --- a/src/runtime/haskell/PGF/Parse.hs +++ b/src/runtime/haskell/PGF/Parse.hs @@ -38,16 +38,16 @@ data ParseResult -- 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. -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 where loop ps [] = getParseResult ps typ loop ps (t:ts) = case nextState ps t 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 -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 where 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 -- limited by the category specified, which is usually -- 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 _) = - let mb_bs = case roots of - ((AK fid lbl):_) -> Just $ linearizeWithBrackets $ Forest (abstract pgf) cnc (forest st) fid lbl - _ -> Nothing + let froots | null roots = getPartialSeq (sequences cnc) (reverse (active st : actives st)) acc1 + | otherwise = [([SymCat 0 lbl],[fid]) | AK fid lbl <- roots] + + bs = linearizeWithBrackets (Forest (abstract pgf) cnc (forest st) froots) + exps = nubsort $ do (AK fid lbl) <- roots @@ -172,11 +174,15 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) = then ParseFailed (offset chart) else ParseResult exps - in (res,mb_bs) + in (res,bs) where (mb_agenda,acc) = TMap.decompose items 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 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) | 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 - | otherwise = foldForest (\funid args trees -> + | Set.member fcat rec = mzero + | otherwise = foldForest (\funid args trees -> do let CncFun fn lins = cncfuns cnc ! funid args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args) check_ho_fun fn args `mplus` trees) - (\const _ trees -> + (\const _ trees -> return (freeVar const,const) `mplus` trees) - [] fcat (forest st) + [] fcat (forest st) check_ho_fun fun 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 _ = 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 (item@(Active j ppos funid seqid args key0):items) acc chart