Skip to content
Browse files

Merge pull request #55 from statusfailed/failed-parse-locations

Failed parse locations
  • Loading branch information...
2 parents 6213e1d + 96174dd commit 9cece5b730f7405f5e1e4d2c9825d6a16d8e66f4 @ekmett committed
Showing with 54 additions and 33 deletions.
  1. +18 −10 src/Text/Trifecta/Parser.hs
  2. +35 −22 src/Text/Trifecta/Result.hs
  3. +1 −1 trifecta.cabal
View
28 src/Text/Trifecta/Parser.hs
@@ -65,7 +65,7 @@ newtype Parser a = Parser
(a -> Err -> It Rope r) ->
(Err -> It Rope r) ->
(a -> Set String -> Delta -> ByteString -> It Rope r) -> -- committed success
- (Doc -> It Rope r) -> -- committed err
+ (ErrInfo -> It Rope r) -> -- committed err
Delta -> ByteString -> It Rope r
}
@@ -108,7 +108,11 @@ instance Monad Parser where
m (\a e -> unparser (k a) (\b e' -> eo b (e <> e')) (\e' -> ee (e <> e')) co ce d bs) ee
(\a es d' bs' -> unparser (k a)
(\b e' -> co b (es <> _expected e') d' bs')
- (\e -> ce (explain (renderingCaret d' bs') e { _expected = _expected e <> es }))
+ (\e ->
+ let errDoc = explain (renderingCaret d' bs') e { _expected = _expected e <> es }
+ errDelta = _finalDeltas e
+ in ce $ ErrInfo errDoc (d' : errDelta)
+ )
co ce d' bs') ce d bs
{-# INLINE (>>=) #-}
(>>) = (*>)
@@ -125,7 +129,8 @@ instance MonadPlus Parser where
manyAccum :: (a -> [a] -> [a]) -> Parser a -> Parser [a]
manyAccum f (Parser p) = Parser $ \eo _ co ce d bs ->
let walk xs x es d' bs' = p (manyErr d' bs') (\e -> co (f x xs) (_expected e <> es) d' bs') (walk (f x xs)) ce d' bs'
- manyErr d' bs' _ e = ce $ explain (renderingCaret d' bs') (e <> failed "'many' applied to a parser that accepted an empty string")
+ manyErr d' bs' _ e = ce (ErrInfo errDoc [d'])
+ where errDoc = explain (renderingCaret d' bs') (e <> failed "'many' applied to a parser that accepted an empty string")
in p (manyErr d bs) (eo []) (walk []) ce d bs
liftIt :: It Rope a -> Parser a
@@ -202,7 +207,7 @@ instance MarkParsing Delta Parser where
data Step a
= StepDone !Rope a
- | StepFail !Rope Doc
+ | StepFail !Rope ErrInfo
| StepCont !Rope (Result a) (Rope -> Step a)
instance Show a => Show (Step a) where
@@ -245,21 +250,24 @@ data Stepping a
= EO a Err
| EE Err
| CO a (Set String) Delta ByteString
- | CE Doc
+ | CE ErrInfo
stepParser :: Parser a -> Delta -> ByteString -> Step a
stepParser (Parser p) d0 bs0 = go mempty $ p eo ee co ce d0 bs0 where
eo a e = Pure (EO a e)
ee e = Pure (EE e)
co a es d bs = Pure (CO a es d bs)
- ce doc = Pure (CE doc)
+ ce errInf = Pure (CE errInf)
go r (Pure (EO a _)) = StepDone r a
- go r (Pure (EE e)) = StepFail r $ explain (renderingCaret d0 bs0) e
+ go r (Pure (EE e)) = StepFail r $
+ let errDoc = explain (renderingCaret d0 bs0) e
+ in ErrInfo errDoc (_finalDeltas e)
go r (Pure (CO a _ _ _)) = StepDone r a
go r (Pure (CE d)) = StepFail r d
go r (It ma k) = StepCont r (case ma of
EO a _ -> Success a
- EE e -> Failure $ explain (renderingCaret d0 bs0) e
+ EE e -> Failure $
+ ErrInfo (explain (renderingCaret d0 bs0) e) (d0 : _finalDeltas e)
CO a _ _ _ -> Success a
CE d -> Failure d
) (go <*> k)
@@ -280,7 +288,7 @@ parseFromFile p fn = do
case result of
Success a -> return (Just a)
Failure xs -> do
- liftIO $ displayIO stdout $ renderPretty 0.8 80 $ xs <> linebreak
+ liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak
return Nothing
-- | @parseFromFileEx p filePath@ runs a parser @p@ on the
@@ -309,5 +317,5 @@ parseString p d inp = starve $ feed inp $ stepParser (release d *> p) mempty mem
parseTest :: (MonadIO m, Show a) => Parser a -> String -> m ()
parseTest p s = case parseByteString p mempty (UTF8.fromString s) of
- Failure xs -> liftIO $ displayIO stdout $ renderPretty 0.8 80 $ xs <> linebreak -- TODO: retrieve columns
+ Failure xs -> liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak -- TODO: retrieve columns
Success a -> liftIO (print a)
View
57 src/Text/Trifecta/Result.hs
@@ -29,6 +29,7 @@ module Text.Trifecta.Result
, _Failure
-- * Parsing Errors
, Err(..), HasErr(..), Errable(..)
+ , ErrInfo(..)
, explain
, failed
) where
@@ -46,35 +47,41 @@ import Text.Trifecta.Instances ()
import Text.Trifecta.Rendering
import Text.Trifecta.Delta as Delta
+data ErrInfo = ErrInfo
+ { _errDoc :: Doc
+ , _errDeltas :: [Delta]
+ } deriving(Show)
+
-- | This is used to report an error. What went wrong, some supplemental docs and a set of things expected
-- at the current location. This does not, however, include the actual location.
data Err = Err
- { _reason :: Maybe Doc
- , _footnotes :: [Doc]
- , _expected :: Set String
+ { _reason :: Maybe Doc
+ , _footnotes :: [Doc]
+ , _expected :: Set String
+ , _finalDeltas :: [Delta]
}
makeClassy ''Err
instance Semigroup Err where
- Err md mds mes <> Err nd nds nes
- = Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes)
+ Err md mds mes delta1 <> Err nd nds nes delta2
+ = Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes) (delta1 <> delta2)
{-# INLINE (<>) #-}
instance Monoid Err where
- mempty = Err Nothing [] mempty
+ mempty = Err Nothing [] mempty mempty
{-# INLINE mempty #-}
mappend = (<>)
{-# INLINE mappend #-}
-- | Generate a simple 'Err' word-wrapping the supplied message.
failed :: String -> Err
-failed m = Err (Just (fillSep (pretty <$> words m))) [] mempty
+failed m = Err (Just (fillSep (pretty <$> words m))) [] mempty mempty
{-# INLINE failed #-}
-- | Convert a location and an 'Err' into a 'Doc'
explain :: Rendering -> Err -> Doc
-explain r (Err mm as es)
+explain r (Err mm as es _)
| Set.null es = report (withEx mempty)
| isJust mm = report $ withEx $ Pretty.char ',' <+> expecting
| otherwise = report expecting
@@ -91,10 +98,14 @@ explain r (Err mm as es)
class Errable m where
raiseErr :: Err -> m a
+instance Monoid ErrInfo where
+ mempty = ErrInfo mempty mempty
+ mappend (ErrInfo xs d1) (ErrInfo ys d2) = ErrInfo (vsep [xs, ys]) (max d1 d2)
+
-- | The result of parsing. Either we succeeded or something went wrong.
data Result a
= Success a
- | Failure Doc
+ | Failure ErrInfo
deriving (Show,Functor,Foldable,Traversable)
-- | A 'Prism' that lets you embed or retrieve a 'Result' in a potentially larger type.
@@ -109,34 +120,36 @@ instance AsResult (Result a) (Result b) a b where
_Success :: AsResult s t a b => Prism s t a b
_Success = _Result . dimap seta (either id id) . right' . rmap (fmap Success) where
seta (Success a) = Right a
- seta (Failure d) = Left (pure (Failure d))
+ seta (Failure e) = Left (pure (Failure e))
{-# INLINE _Success #-}
-- | The 'Prism' for the 'Failure' constructor of 'Result'
-_Failure :: AsResult s s a a => Prism' s Doc
+_Failure :: AsResult s s a a => Prism' s ErrInfo
_Failure = _Result . dimap seta (either id id) . right' . rmap (fmap Failure) where
- seta (Failure d) = Right d
+ seta (Failure e) = Right e
seta (Success a) = Left (pure (Success a))
{-# INLINE _Failure #-}
instance Show a => Pretty (Result a) where
- pretty (Success a) = pretty (show a)
- pretty (Failure xs) = pretty xs
+ pretty (Success a) = pretty (show a)
+ pretty (Failure xs) = pretty . _errDoc $ xs
instance Applicative Result where
pure = Success
{-# INLINE pure #-}
- Success f <*> Success a = Success (f a)
- Success _ <*> Failure ys = Failure ys
- Failure xs <*> Success _ = Failure xs
- Failure xs <*> Failure ys = Failure $ vsep [xs, ys]
+ Success f <*> Success a = Success (f a)
+ Success _ <*> Failure y = Failure y
+ Failure x <*> Success _ = Failure x
+ Failure x <*> Failure y =
+ Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y)
{-# INLINE (<*>) #-}
instance Alternative Result where
- Failure xs <|> Failure ys = Failure $ vsep [xs, ys]
- Success a <|> Success _ = Success a
- Success a <|> Failure _ = Success a
- Failure _ <|> Success a = Success a
+ Failure x <|> Failure y =
+ Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y)
+ Success a <|> Success _ = Success a
+ Success a <|> Failure _ = Success a
+ Failure _ <|> Success a = Success a
{-# INLINE (<|>) #-}
empty = Failure mempty
{-# INLINE empty #-}
View
2 trifecta.cabal
@@ -68,7 +68,7 @@ library
default-language: Haskell2010
hs-source-dirs: src
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -Wall -fobject-code
test-suite doctests

0 comments on commit 9cece5b

Please sign in to comment.
Something went wrong with that request. Please try again.