Add error messages for incomplete parsing

Text/Boomerang/Error.hs

@@ -33,6 +33,7 @@ type instance Pos (ParserError p) = p
 
 instance ErrorPosition (ParserError p) where
     getPosition (ParserError mPos _) = mPos
+    setPosition mPos (ParserError _ msg) = ParserError (Just mPos) msg
 
 {-
 instance ErrorList ParserError where

Text/Boomerang/Pos.hs

@@ -16,6 +16,7 @@ type family Pos err :: *
 -- | extract the position information from an error
 class ErrorPosition err where
     getPosition :: err -> Maybe (Pos err)
+    setPosition :: Pos err -> err -> err
 
 -- | the initial position for a position type
 class InitialPosition e where

Text/Boomerang/Prim.hs

@@ -18,6 +18,7 @@ import Control.Monad       (MonadPlus(mzero, mplus), ap)
 import Control.Monad.Error (Error(..))
 import Data.Either         (partitionEithers)
 import Data.Function       (on)
+import Data.List           (partition)
 import Data.Monoid         (Monoid(mappend, mempty))
 import qualified Data.Semigroup as SG
 import Text.Boomerang.HStack   ((:-)(..), hdMap, hdTraverse)
@@ -159,19 +160,34 @@ val rs ss = Boomerang rs' ss'
       ss' =  (\(a :- r) -> map (\f -> (f, r)) (ss a))
 
 -- | Give all possible parses or errors.
-parse :: forall e a p tok. (InitialPosition e) => Boomerang e tok () a -> tok -> [Either e (a, tok)]
+parse :: forall e a p tok. (InitialPosition e) => Boomerang e tok () a -> tok -> [Either e (a, tok, Pos e)]
 parse p s =
-    map (either Left (\((f, tok), _) -> Right (f (), tok))) $ runParser (prs p) s (initialPos (Nothing :: Maybe e))
+    map (either Left (\((f, tok), pos) -> Right (f (), tok, pos))) $ runParser (prs p) s (initialPos (Nothing :: Maybe e))
 
 -- | Give the first parse, for Boomerangs with a parser that yields just one value.
 -- Otherwise return the error (or errors) with the highest error position.
-parse1 :: (ErrorPosition e, InitialPosition e, Show e, Ord (Pos e)) =>
-          (tok -> Bool) -> Boomerang e tok () (a :- ()) -> tok -> Either [e] a
-parse1 isComplete r paths =
-    let results = parse r paths
-    in case [ a | (Right (a,tok)) <- results, isComplete tok ] of
-         ((u :- ()):_) -> Right u
-         _             -> Left $ bestErrors [ e | Left e <- results ]
+parse1 :: (Error e, ErrorPosition e, InitialPosition e, Show e, Ord (Pos e), Show tok ) => (tok -> Bool) -> Boomerang e tok () (a :- ()) -> tok -> Either [e] a
+parse1 isComplete p s = 
+  case partition (either (const False) (\(_,tok,_) -> isComplete tok )) $
+       parse p s of
+    ( [],             badParsings )  -> bestMsgs Nothing [] badParsings 
+    ( Right ( u :- (), _, _ ):_, _) ->  Right u
+   where 
+    bestMsgs _      errMsgs []     = Left errMsgs
+    bestMsgs errPos errMsgs (x:xs) = case x of 
+      Right ( u :- ()  ,tok, pos) 
+        | justPos > errPos -> bestMsgs justPos (newErrMsg :[]) xs  
+        | otherwise        -> bestMsgs errPos   errMsgs        xs 
+          where 
+            justPos   = Just pos
+            newErrMsg = setPosition pos  $ strMsg $ 
+                        "no parse starting at " ++ (take 10 $ show tok) 
+      Left e  -> let mPos = getPosition e in   
+          case compare mPos errPos of 
+            GT -> bestMsgs mPos   [e]         xs
+            EQ -> bestMsgs mPos   (e:errMsgs) xs 
+            LT -> bestMsgs errPos    errMsgs  xs 
+
 
 -- | Give all possible serializations.
 unparse :: tok -> Boomerang e tok () url -> url -> [tok]