packages feed

parsix (empty) → 0.1.0.0

raw patch · 18 files changed

+885/−0 lines, 18 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, fingertree, mtl, parsers, parsix, prettyprinter, prettyprinter-ansi-terminal, tasty, tasty-hunit, tasty-quickcheck, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Olle Fredriksson (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,10 @@+# parsix [![Build Status](https://travis-ci.org/ollef/parsix.svg?branch=master)](https://travis-ci.org/ollef/parsix)++Adventures in parser combinators.++This is basically a [Trifecta](https://github.com/ekmett/trifecta) clone, i.e. an implementation of the [parsers](https://github.com/ekmett/parsers/) interface, with the following differences:++* Add error recovery (see `withRecovery`) based on [Megaparsec](https://github.com/mrkkrp/megaparsec)'s.+* Use the `text` library instead of `bytestring` for input strings. This means that the library interfaces better with the rest of the Haskell library ecosystem and that slicing (see `sliced`) returns `Text`.+* Use the [prettyprinter](https://github.com/quchen/prettyprinter) library for pretty-printing.+* Actually implement the highlighting interface from `parsers`. This means that error messages that show input code are syntax highlighted.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ parsix.cabal view
@@ -0,0 +1,65 @@+name:                parsix+version:             0.1.0.0+synopsis:            Parser combinators with slicing, error recovery, and syntax highlighting+description:         A parser combinator library based on 'parsers' (like 'trifecta') with slicing, error recovery, and syntax highlighted diagnostics+homepage:            https://github.com/ollef/parsix+license:             BSD3+license-file:        LICENSE+author:              Olle Fredriksson+maintainer:          fredriksson.olle@gmail.com+copyright:           2017-2018 Olle Fredriksson+category:            Parsing+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10+tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3++source-repository head+  type:     git+  location: https://github.com/ollef/parsix++library+  hs-source-dirs:      src+  exposed-modules:+                       Text.Parsix+                       Text.Parsix.Combinators+                       Text.Parsix.Highlight+                       Text.Parsix.Internal+                       Text.Parsix.Parser+                       Text.Parsix.Parser.Internal+                       Text.Parsix.Position+                       Text.Parsix.Result+  build-depends:       base >= 4.7 && < 5,+                       bytestring,+                       containers,+                       fingertree,+                       mtl,+                       parsers,+                       prettyprinter,+                       prettyprinter-ansi-terminal,+                       text,+                       transformers+  default-language:    Haskell2010+  ghc-options:         -Wall+                       -Wcompat+                       -funbox-strict-fields++test-suite tests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             Main.hs+  default-language:    Haskell2010+  ghc-options:         -Wall+                       -Wcompat+  build-depends:       base,+                       QuickCheck,+                       parsix,+                       tasty,+                       tasty-hunit,+                       tasty-quickcheck,+                       text+  other-modules:       Empty+                       Fail+                       NotFollowedBy+                       Util+                       WithRecovery
+ src/Text/Parsix.hs view
@@ -0,0 +1,10 @@+module Text.Parsix(module X) where++import Text.Parser.Char as X+import Text.Parser.Combinators as X+import Text.Parser.Token as X++import Text.Parsix.Combinators as X+import Text.Parsix.Parser as X+import Text.Parsix.Position as X+import Text.Parsix.Result as X
+ src/Text/Parsix/Combinators.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE DefaultSignatures, GADTs #-}+module Text.Parsix.Combinators where++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Reader+import Control.Monad.Trans.RWS.Lazy as Lazy+import Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict+import Data.Text(Text)+import qualified Data.Text.Unsafe as Unsafe+import Text.Parser.Combinators++import Text.Parsix.Highlight+import Text.Parsix.Parser.Internal+import Text.Parsix.Position+import Text.Parsix.Result++class Parsing m => SliceParsing m where+  slicedWith :: (a -> Text -> b) -> m a -> m b+  position :: m Position++  default position+    :: (MonadTrans t, Monad n, SliceParsing n, m ~ t n) => m Position+  position = lift position++instance SliceParsing Parser where+  slicedWith f p = do+    i <- position+    a <- p+    j <- position+    inp <- input+    return+      $ f a+      $ Unsafe.takeWord16 (codeUnits j - codeUnits i)+      $ Unsafe.dropWord16 (codeUnits i) inp++  position = Parser $ \s0 _s _e0 _e pos _hl _inp -> s0 pos mempty++sliced :: SliceParsing m => m a -> m Text+sliced = slicedWith (\_ t -> t)++class Parsing m => RecoveryParsing m where+  withRecovery :: (ErrorInfo -> m a) -> m a -> m a++instance RecoveryParsing Parser where+  withRecovery recover (Parser p) = Parser+    $ \s0 s e0 e pos hl inp -> p+      s0+      s+      (\err -> unParser (recover err)+        (\a _err' -> s0 a err)+        s+        (\_err' -> e0 err)+        (\_err' _pos' _hl' -> e0 err)+        pos+        hl+        inp)+      (\err pos' hl' -> unParser (recover err)+        (\a _err' -> s a err pos' hl')+        s+        (\_err' -> e err pos' hl')+        (\_err' _pos'' _hl'' -> e err pos' hl')+        pos'+        hl'+        inp)+      pos+      hl+      inp++careted :: (SliceParsing m, Applicative m) => m a -> m (Position, a)+careted m = (,) <$> position <*> m++spanned :: (SliceParsing m, Applicative m) => m a -> m (Span, a)+spanned m = (\start a end -> (Span start end, a)) <$> position <*> m <*> position++-------------------------------------------------------------------------------+-- * Low-level queries+input :: Parser Text+input = Parser $ \s0 _s _e0 _e _pos _hl inp -> s0 inp mempty++highlights :: Parser Highlights+highlights = Parser $ \s0 _s _e0 _e _pos hl _inp -> s0 hl mempty++-------------------------------------------------------------------------------+-- Boilerplate instances+instance (SliceParsing m, MonadPlus m) => SliceParsing (Lazy.StateT s m) where+  slicedWith f (Lazy.StateT m)+    = Lazy.StateT+    $ \s -> slicedWith (\(a, s') b -> (f a b, s')) $ m s++instance (SliceParsing m, MonadPlus m) => SliceParsing (Strict.StateT s m) where+  slicedWith f (Strict.StateT m)+    = Strict.StateT+    $ \s -> slicedWith (\(a, s') b -> (f a b, s')) $ m s++instance (SliceParsing m, MonadPlus m) => SliceParsing (ReaderT e m) where+  slicedWith f (ReaderT m) = ReaderT $ slicedWith f . m++instance (SliceParsing m, MonadPlus m, Monoid w) => SliceParsing (Strict.WriterT w m) where+  slicedWith f (Strict.WriterT m)+    = Strict.WriterT+    $ slicedWith (\(a, s') b -> (f a b, s')) m++instance (SliceParsing m, MonadPlus m, Monoid w) => SliceParsing (Lazy.WriterT w m) where+  slicedWith f (Lazy.WriterT m)+    = Lazy.WriterT+    $ slicedWith (\(a, s') b -> (f a b, s')) m++instance (SliceParsing m, MonadPlus m, Monoid w) => SliceParsing (Lazy.RWST r w s m) where+  slicedWith f (Lazy.RWST m)+    = Lazy.RWST+    $ \r s -> slicedWith (\(a, s', w) b -> (f a b, s', w)) $ m r s++instance (SliceParsing m, MonadPlus m, Monoid w) => SliceParsing (Strict.RWST r w s m) where+  slicedWith f (Strict.RWST m)+    = Strict.RWST+    $ \r s -> slicedWith (\(a, s', w) b -> (f a b, s', w)) $ m r s++instance (SliceParsing m, MonadPlus m) => SliceParsing (IdentityT m) where+  slicedWith f (IdentityT m) = IdentityT $ slicedWith f m++instance (RecoveryParsing m, MonadPlus m) => RecoveryParsing (Lazy.StateT s m) where+  withRecovery r (Lazy.StateT m)+    = Lazy.StateT+    $ \s -> withRecovery (\err -> Lazy.runStateT (r err) s) (m s)++instance (RecoveryParsing m, MonadPlus m) => RecoveryParsing (Strict.StateT s m) where+  withRecovery r (Strict.StateT m)+    = Strict.StateT+    $ \s -> withRecovery (\err -> Strict.runStateT (r err) s) (m s)++instance (RecoveryParsing m, MonadPlus m) => RecoveryParsing (ReaderT e m) where+  withRecovery r (ReaderT m)+    = ReaderT+    $ \s -> withRecovery (\err -> runReaderT (r err) s) (m s)++instance (RecoveryParsing m, MonadPlus m, Monoid w) => RecoveryParsing (Strict.WriterT w m) where+  withRecovery r (Strict.WriterT m)+    = Strict.WriterT+    $ withRecovery (Strict.runWriterT . r) m++instance (RecoveryParsing m, MonadPlus m, Monoid w) => RecoveryParsing (Lazy.WriterT w m) where+  withRecovery r (Lazy.WriterT m)+    = Lazy.WriterT+    $ withRecovery (Lazy.runWriterT . r) m++instance (RecoveryParsing m, MonadPlus m, Monoid w) => RecoveryParsing (Lazy.RWST r w s m) where+  withRecovery r (Lazy.RWST m)+    = Lazy.RWST+    $ \s s' -> withRecovery (\err -> Lazy.runRWST (r err) s s') (m s s')++instance (RecoveryParsing m, MonadPlus m, Monoid w) => RecoveryParsing (Strict.RWST r w s m) where+  withRecovery r (Strict.RWST m)+    = Strict.RWST+    $ \s s' -> withRecovery (\err -> Strict.runRWST (r err) s s') (m s s')++instance (RecoveryParsing m, MonadPlus m) => RecoveryParsing (IdentityT m) where+  withRecovery r (IdentityT m)+    = IdentityT+    $ withRecovery (runIdentityT . r) m
+ src/Text/Parsix/Highlight.hs view
@@ -0,0 +1,77 @@+module Text.Parsix.Highlight where++import Data.IntervalMap.FingerTree(IntervalMap)+import qualified Data.IntervalMap.FingerTree as IntervalMap+import Data.List+import Data.Semigroup+import Data.Text(Text)+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Terminal+import Text.Parser.Token.Highlight++import Text.Parsix.Internal++type Highlights = IntervalMap Int Highlight++highlightInterval+  :: Semigroup a+  => (Text -> a)+  -> (Highlight -> a -> a)+  -> Text+  -> Int+  -> Int+  -> Highlights+  -> a+highlightInterval textPart highlightPart input start end highlights = go start boundaries+  where+    boundaries+      = uniq+      $ sort+      [ i+      | (s, e) <- rightOpenView . fst <$> IntervalMap.intersections+          (rightOpen start end)+          highlights+      , i <- [max start s, min end e]+      ]++    part s e+      = foldr+        highlightPart+        (textPart $ codeUnitSlice s e input)+        (snd <$> IntervalMap.dominators (rightOpen s e) highlights)++    go s [] = part s end+    go s (e:bs) = part s e <> go e bs++    uniq :: Eq a => [a] -> [a]+    uniq [] = []+    uniq (x:xs) = uniq1 x xs++    uniq1 :: Eq a => a -> [a] -> [a]+    uniq1 x [] = [x]+    uniq1 x (y:ys)+      | x == y = uniq1 x ys+      | otherwise = x : uniq1 y ys++prettyInterval+  :: Text+  -> Int+  -> Int+  -> Highlights+  -> Doc Highlight+prettyInterval = highlightInterval pretty annotate++defaultStyle :: Highlight -> AnsiStyle+defaultStyle h = case h of+  Comment -> color Blue+  ReservedIdentifier -> color Magenta+  ReservedConstructor -> color Magenta+  EscapeCode -> color Magenta+  Operator -> color Yellow+  CharLiteral -> color Cyan+  StringLiteral -> color Cyan+  Constructor -> bold+  ReservedOperator -> color Yellow+  ConstructorOperator -> color Yellow+  ReservedConstructorOperator -> color Yellow+  _ -> mempty
+ src/Text/Parsix/Internal.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE BangPatterns #-}+-- | This module exposes internals of the package: its API may change independently of the PVP-compliant version number.+module Text.Parsix.Internal where++import qualified Data.IntervalMap.FingerTree as IntervalMap+import Data.Text(Text)+import qualified Data.Text.Unsafe as Unsafe++codeUnitSlice :: Int -> Int -> Text -> Text+codeUnitSlice start end text+  = Unsafe.takeWord16 (end' - start')+  $ Unsafe.dropWord16 start' text+  where+    start' = clamp start+    end' = clamp end+    clamp x = max 0 $ min x $ Unsafe.lengthWord16 text++nextNewline :: Text -> Int -> Int+nextNewline inp i = go inp i'+  where+    i' = max 0 i+    go text index+      | index >= len = len+      | otherwise = case Unsafe.iter text index of+        Unsafe.Iter '\n' _ -> index+        Unsafe.Iter _ delta -> nextNewline text $ index + delta+      where+        len = Unsafe.lengthWord16 text++prevNewline :: Text -> Int -> Int+prevNewline inp i = go inp (i' - 1) + 1+  where+    i' = min i $ Unsafe.lengthWord16 inp+    go text index+      | index < 0 = -1+      | otherwise = case Unsafe.reverseIter text index of+        ('\n', _) -> index+        (_, delta) -> go text $ index + delta++rightOpen :: Int -> Int -> IntervalMap.Interval Int+rightOpen !start !end = IntervalMap.Interval start $! end - 1++rightOpenView :: IntervalMap.Interval Int -> (Int, Int)+rightOpenView (IntervalMap.Interval !start !end) = (,) start $! end + 1
+ src/Text/Parsix/Parser.hs view
@@ -0,0 +1,10 @@+module Text.Parsix.Parser+  ( Parser+  , parseFromFile+  , parseFromFileEx+  , parseText+  , parseString+  , parseTest+  ) where++import Text.Parsix.Parser.Internal
+ src/Text/Parsix/Parser/Internal.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings, RankNTypes #-}+-- | This module exposes internals of the package: its API may change independently of the PVP-compliant version number.+module Text.Parsix.Parser.Internal where++import Control.Applicative+import Control.Monad+import Control.Monad.Fail as Fail+import Control.Monad.IO.Class+import qualified Data.IntervalMap.FingerTree as IntervalMap+import Data.Semigroup+import qualified Data.Set as Set+import Data.Text(Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Terminal+import qualified Data.Text.Unsafe as Unsafe+import Text.Parser.Char+import Text.Parser.Combinators+import Text.Parser.LookAhead+import Text.Parser.Token++import Text.Parsix.Highlight+import Text.Parsix.Internal+import Text.Parsix.Position+import Text.Parsix.Result++newtype Parser a = Parser+  { unParser+    :: forall r+    . (a -> ErrorInfo -> r) -- success epsilon+    -> (a -> ErrorInfo -> Position -> Highlights -> r) -- success committed+    -> (ErrorInfo -> r) -- error epsilon+    -> (ErrorInfo -> Position -> Highlights -> r) -- error committed+    -> Position -- Input position+    -> Highlights -- Highlighting intervals+    -> Text -- Input+    -> r+  }++instance Semigroup a => Semigroup (Parser a) where+  (<>) = liftA2 (<>)++instance Monoid a => Monoid (Parser a) where+  mempty = pure mempty+  mappend = liftA2 mappend++instance Functor Parser where+  fmap f (Parser p) = Parser $ \s0 s e0 e -> p (s0 . f) (s . f) e0 e++instance Applicative Parser where+  pure a = Parser $ \s0 _s _e0 _e _pos _hl _inp -> s0 a mempty+  (<*>) = ap++instance Alternative Parser where+  empty = Parser $ \_s0 _s e0 _e _pos _hl _inp -> e0 mempty+  Parser p <|> Parser q = Parser+    $ \s0 s e0 e pos hl inp -> p+      s0+      s+      (\err -> q s0 s (\err' -> e0 $ err <> err') e pos hl inp)+      e+      pos+      hl+      inp+  many p = reverse <$> manyAccum (:) p+  some p = (:) <$> p <*> many p++instance Monad Parser where+  return = pure+  Parser p >>= f = Parser+    $ \s0 s e0 e pos hl inp -> p+      (\a err -> unParser (f a)+        (\b err' -> s0 b $ err <> err')+        s+        (\err' -> e0 $ err <> err')+        e+        pos+        hl+        inp)+      (\a err pos' hl' -> unParser (f a)+        (\b err' -> s b (err <> err') pos' hl')+        s+        (\err' -> e (err <> err') pos' hl')+        e+        pos'+        hl'+        inp)+      e0+      e+      pos+      hl+      inp+  fail = Fail.fail++instance MonadFail Parser where+  fail x = Parser+    $ \_s0 _s e0 _e _pos _hl _inp -> e0 $ failed $ Text.pack x++instance MonadPlus Parser where+  mzero = empty+  mplus = (<|>)++manyAccum :: (a -> [a] -> [a]) -> Parser a -> Parser [a]+manyAccum f (Parser p) = Parser+  $ \s0 s _e0 e pos hl inp -> do+    let manyFailed pos' hl' _ _ =+          e (failed "'many' applied to a parser that accepts an empty string") pos' hl'+        walk xs x err pos' hl' = p+          (manyFailed pos' hl')+          (walk $ f x xs)+          (\err' -> s (f x xs) (err <> err') pos' hl')+          e+          pos'+          hl'+          inp+    p (manyFailed pos hl) (walk []) (s0 []) e pos hl inp++instance Parsing Parser where+  try (Parser p) = Parser+    $ \s0 s e0 _e -> p s0 s e0 (\_err _pos _hl -> e0 mempty)++  Parser p <?> expected = Parser+    $ \s0 s e0 e -> p+      (\a -> s0 a . setExpected)+      s+      (e0 . setExpected)+      e+    where+      expectedText = Text.pack expected+      setExpected e = e { errorInfoExpected = Set.singleton expectedText }++  skipMany p = () <$ manyAccum (\_ _ -> []) p++  unexpected s = Parser+    $ \_s0 _s e0 _e _pos _hl _inp -> e0 $ failed $ "unexpected " <> Text.pack s++  eof = notFollowedBy anyChar <?> "end of input"++  notFollowedBy p = try (optional p >>= maybe (pure ()) (unexpected . show))++instance CharParsing Parser where+  satisfy f = Parser+    $ \_s0 s e0 _e pos hl inp ->+      if codeUnits pos < Unsafe.lengthWord16 inp then+        case Unsafe.iter inp $ codeUnits pos of+          Unsafe.Iter c delta+            | f c -> s c mempty (next c delta pos) hl+            | otherwise -> e0 mempty+      else+        e0 $ failed "Unexpected EOF"++instance TokenParsing Parser where+  highlight h (Parser p) = Parser+    $ \s0 s e0 e pos -> p+      s0+      (\a err pos' -> s a err pos' . ins pos pos')+      e0+      (\err pos' -> e err pos' . ins pos pos')+      pos+    where+      ins pos pos' = IntervalMap.insert (rightOpen (codeUnits pos) (codeUnits pos')) h++instance LookAheadParsing Parser where+  lookAhead (Parser p) = Parser+    $ \s0 s e0 e pos -> p s0 (\a _ _ -> s a mempty pos) e0 e pos++parseFromFile :: MonadIO m => Parser a -> FilePath -> m (Maybe a)+parseFromFile p file = do+  result <- parseFromFileEx p file+  case result of+   Success a -> return $ Just a+   Failure e -> do+     liftIO $ putDoc $ prettyError e <> line+     return Nothing++parseFromFileEx :: MonadIO m => Parser a -> FilePath -> m (Result a)+parseFromFileEx p file = do+  s <- liftIO $ Text.readFile file+  return $ parseText p s file++-- | @parseText p i file@ runs a parser @p@ on @i@. @file@ is only used for+-- reporting errors.+parseText :: Parser a -> Text -> FilePath -> Result a+parseText (Parser p) inp file = p+  (\res _ -> Success res)+  (\res _ _pos _hl -> Success res)+  (\err -> Failure $ Error err start inp mempty file)+  (\err pos hl -> Failure $ Error err pos inp hl file)+  start+  mempty+  inp+  where+    start = Position 0 0 0++-- | @parseString p i file@ runs a parser @p@ on @i@. @file@ is only used for+-- reporting errors.+parseString :: Parser a -> String -> FilePath -> Result a+parseString p s = parseText p $ Text.pack s++-- | Parse some input and print the result to the console.+parseTest :: (MonadIO m, Show a) => Parser a -> String -> m ()+parseTest p s = case parseText p (Text.pack s) "<interactive>" of+  Failure e -> liftIO $ putDoc $ prettyError e <> line+  Success a -> liftIO $ print a
+ src/Text/Parsix/Position.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+module Text.Parsix.Position where++import Data.Semigroup+import Data.Text(Text)+import qualified Data.Text as Text+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Terminal+import Text.Parser.Token.Highlight++import Text.Parsix.Highlight+import Text.Parsix.Internal++data Position = Position+  { codeUnits :: !Int+  , visualRow :: !Int+  , visualColumn :: !Int+  } deriving (Eq, Ord, Show)++next :: Char -> Int -> Position -> Position+next !c !delta !pos = Position+  { codeUnits = codeUnits pos + delta+  , visualRow = row'+  , visualColumn = col'+  }+  where+    row = visualRow pos+    col = visualColumn pos+    (row', col') = case c of+      '\n' -> (row + 1, 0)+      '\t' -> (row, col + 8 - mod col 8)+      _ -> (row, col + 1)++positionRow :: Position -> Text -> Highlights -> Doc Highlight+positionRow pos inp+  = prettyInterval+    inp+    (prevNewline inp $ codeUnits pos)+    (nextNewline inp $ codeUnits pos)++prettyPosition+  :: (Highlight -> AnsiStyle)+  -> Position+  -> Text+  -> Highlights+  -> Doc AnsiStyle+prettyPosition style pos inp hl+  = rowStringPadding <> bar <> line+  <> prettyRow <> bar <+> fmap style (positionRow pos inp hl) <> line+  <> rowStringPadding <> bar <+> pretty positionPadding <> annotate (color Red) "^"+  where+    barHighlight = annotate (color Blue)+    bar = barHighlight "|"+    prettyRow = barHighlight $ pretty rowString+    rowString = Text.pack (show $ visualRow pos + 1) <> " "+    rowStringPadding = pretty $ Text.replicate (Text.length rowString) " "++    positionPadding+      = Text.map go+      $ codeUnitSlice start end inp+      where+        start = prevNewline inp end+        end = codeUnits pos+        go '\t' = '\t'+        go _ = ' '++data Span = Span+  { spanStart :: !Position+  , spanEnd :: !Position+  } deriving (Eq, Ord, Show)
+ src/Text/Parsix/Result.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, OverloadedStrings #-}+module Text.Parsix.Result where++import Control.Applicative+import Data.Semigroup+import qualified Data.Set as Set+import Data.Set(Set)+import Data.Text(Text)+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.Terminal+import Text.Parser.Token.Highlight++import Text.Parsix.Position+import Text.Parsix.Highlight++data ErrorInfo = ErrorInfo+  { errorInfoReason :: Maybe Text+  , errorInfoExpected :: Set Text+  } deriving (Eq, Ord, Show)++prettyErrorInfo :: ErrorInfo -> Doc AnsiStyle+prettyErrorInfo (ErrorInfo (Just reason) expected)+  | Set.null expected = pretty reason+  | otherwise = pretty reason <> colon <+> "expected" <> colon+    <+> hsep (punctuate comma $ pretty <$> Set.toList expected)+prettyErrorInfo (ErrorInfo Nothing expected)+  | Set.null expected = mempty+  | otherwise = "expected" <> colon+    <+> hsep (punctuate comma $ pretty <$> Set.toList expected)++failed :: Text -> ErrorInfo+failed x = ErrorInfo (Just x) mempty++instance Monoid ErrorInfo where+  mempty = ErrorInfo empty mempty+  mappend = (<>)++instance Semigroup ErrorInfo where+  ErrorInfo r1 e1 <> ErrorInfo r2 e2+    = ErrorInfo (r1 <|> r2) (e1 <> e2)++data Result a+  = Success a+  | Failure Error+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++data Error = Error+  { errorInfo :: !ErrorInfo+  , errorPosition :: !Position+  , errorSourceText :: !Text+  , errorHighlights :: Highlights+  , errorFilePath :: FilePath+  } deriving (Eq, Ord, Show)++errorReason :: Error -> Maybe Text+errorReason = errorInfoReason . errorInfo++errorExpected :: Error -> Set Text+errorExpected = errorInfoExpected . errorInfo++prettyError :: Error -> Doc AnsiStyle+prettyError = prettyErrorWithStyle defaultStyle++prettyErrorWithStyle :: (Highlight -> AnsiStyle) -> Error -> Doc AnsiStyle+prettyErrorWithStyle style (Error info pos inp hl file)+  = (if null file then "" else pretty file <> ":")+  <> pretty (visualRow pos + 1) <> colon+  <> pretty (visualColumn pos + 1) <> colon <> line+  <> annotate (color Red) "error" <> colon <+> prettyErrorInfo info <> line+  <> prettyPosition style pos inp hl
+ tests/Empty.hs view
@@ -0,0 +1,11 @@+module Empty where++import Test.Tasty.QuickCheck++import Util++tests :: TestTree+tests = testGroup "Empty parsers"+  [ testProperty "mempty succeeds" $ isSuccess . parse (mempty :: Parser ())+  , testProperty "empty fails" $ isFailure . parse empty+  ]
+ tests/Fail.hs view
@@ -0,0 +1,10 @@+module Fail where++import Test.Tasty.QuickCheck++import Util++tests :: TestTree+tests = testGroup "Failing parsers"+  [ testProperty "Fail" $ isFailure . parse (fail "fail")+  ]
+ tests/Main.hs view
@@ -0,0 +1,15 @@+module Main where++import qualified Empty+import qualified Fail+import qualified NotFollowedBy+import Util+import qualified WithRecovery++main :: IO ()+main = defaultMain $ testGroup "Tests"+  [ Empty.tests+  , Fail.tests+  , NotFollowedBy.tests+  , WithRecovery.tests+  ]
+ tests/NotFollowedBy.hs view
@@ -0,0 +1,21 @@+module NotFollowedBy where++import Test.Tasty.QuickCheck++import Util++tests :: TestTree+tests = testGroup "notFollowedBy"+  [ testProperty "1"+    $ \x y -> result (\_ -> x == y) (/= y)+    $ parse (notFollowedBy (char y) *> anyChar) [x]+  , testProperty "2"+    $ \x -> isFailure+    $ parse (notFollowedBy (char x) *> anyChar) [x]+  , testProperty "3"+    $ \x y -> isFailure+    $ parse (anyChar *> notFollowedBy (char y) *> char y) x+  , testProperty "4"+    $ \x -> isSuccess+    $ parse (notFollowedBy (char x) <|> char x *> pure ()) [x]+  ]
+ tests/Util.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE BangPatterns #-}+module Util+  ( module Control.Applicative+  , module Control.Monad+  , module Data.Monoid+  , module Text.Parsix+  , module Test.Tasty+  , parse, isSuccess, isFailure, result, success, failure, atPosition+  ) where++import Control.Applicative+import Control.Monad+import Data.Monoid+import qualified Data.Text.Unsafe as Unsafe+import Test.Tasty++import Text.Parsix++parse :: Parser a -> String -> Result a+parse p s = parseString p s "<test input>"++isSuccess, isFailure :: Result a -> Bool+isSuccess Failure {} = False+isSuccess Success {} = True+isFailure Failure {} = True+isFailure Success {} = False++result :: (Error -> b) -> (a -> b) -> Result a -> b+result f _ (Failure e) = f e+result _ g (Success a) = g a++success :: (a -> Bool) -> Result a -> Bool+success = result $ const False++failure :: (Error -> Bool) -> Result a -> Bool+failure f = result f $ const False++atPosition :: Int -> Error -> Bool+atPosition pos err = go pos 0 == codeUnits (errorPosition err)+  where+    inp = errorSourceText err+    go 0 !cp = cp+    go n !cp = go (n - 1) $ cp + Unsafe.iter_ inp cp
+ tests/WithRecovery.hs view
@@ -0,0 +1,27 @@+module WithRecovery where++import Test.Tasty.QuickCheck++import Util++tests :: TestTree+tests = testGroup "withRecovery"+  [ testProperty "inner epsilon success"+    $ \xs -> success (== Just ())+    $ parse (withRecovery (\_ -> pure Nothing) (pure (Just ()))) xs+  , testProperty "inner committed success"+    $ \x -> success (== Just x)+    $ parse (withRecovery (\_ -> pure Nothing) (Just <$> char x)) [x]+  , testProperty "inner epsilon error"+    $ \x y -> x /= y ==> success (== Nothing)+    $ parse (withRecovery (\_ -> pure Nothing) (Just <$> char x)) [y]+  , testProperty "inner committed error"+    $ \x y -> x /= y ==> success (== Nothing)+    $ parse (withRecovery (\_ -> pure Nothing) (Just <$> char x <* char x)) [x, y]+  , testProperty "recover epsilon error"+    $ \x y -> x /= y ==> failure (atPosition 1)+    $ parse (withRecovery (\_ -> empty) (Just <$> char x <* char x)) [x, y]+  , testProperty "recover committed error"+    $ \x y z -> x /= y && y /= z ==> failure (atPosition 1)+    $ parse (withRecovery (\_ -> Nothing <$ char y <* char y) (Just <$> char x <* char x)) [x, y, z]+  ]