packages feed

trifecta 0.13 → 0.14

raw patch · 13 files changed

+428/−117 lines, 13 filesdep +keysdep +profunctors

Dependencies added: keys, profunctors

Files

Text/Trifecta.hs view
@@ -13,12 +13,16 @@   , module Text.Trifecta.Parser.Result   , module Text.Trifecta.Parser.Step   , module Text.Trifecta.Path+  , module Text.Trifecta.Render.Prim   , module Text.Trifecta.Render.Caret   , module Text.Trifecta.Render.Fixit   , module Text.Trifecta.Render.Span   , module Text.Trifecta.Rope   , module Text.Trifecta.Strand   , module Text.Trifecta.Util.MaybePair+  , module Text.PrettyPrint.Free+  , module System.Console.Terminfo.PrettyPrint+  , module System.Console.Terminfo.Color   ) where  import Text.Trifecta.Bytes@@ -35,9 +39,14 @@ import Text.Trifecta.Parser.Result import Text.Trifecta.Parser.Step import Text.Trifecta.Path+import Text.Trifecta.Render.Prim import Text.Trifecta.Render.Caret import Text.Trifecta.Render.Fixit import Text.Trifecta.Render.Span import Text.Trifecta.Rope import Text.Trifecta.Strand import Text.Trifecta.Util.MaybePair++import Text.PrettyPrint.Free hiding (column, char, line, string, space)+import System.Console.Terminfo.PrettyPrint+import System.Console.Terminfo.Color
Text/Trifecta/Diagnostic.hs view
@@ -26,6 +26,7 @@ import Prelude hiding (log)  data Diagnostic m = Diagnostic !Render !DiagnosticLevel m [Diagnostic m]+  deriving Show  tellDiagnostic :: (MonadWriter t m, Reducer (Diagnostic e) t) => Diagnostic e -> m () tellDiagnostic = tell . unit@@ -58,9 +59,6 @@      <> (prettyTerm r <$ guard (not (nullRender r)))      <> (indent 2 (prettyTermList xs) <$ guard (not (null xs)))   prettyTermList = Prelude.foldr ((<>) . prettyTerm) empty--instance Pretty m => Show (Diagnostic m) where-  showsPrec d = showsPrec d . pretty  instance Functor Diagnostic where   fmap f (Diagnostic r l m xs) = Diagnostic r l (f m) $ map (fmap f) xs
Text/Trifecta/Parser/Class.hs view
@@ -14,18 +14,23 @@ import Data.Semigroup import Data.Set as Set import Text.Trifecta.Delta+import Text.Trifecta.Rope import Text.Trifecta.Parser.It  class ( Alternative m, MonadPlus m) => MonadParser m where-  satisfy :: (Char -> Bool) -> m Char-  commit :: m a -> m a-  labels :: m a -> Set String -> m a-  it :: It a -> m a-  mark :: m Delta-  release :: Delta -> m ()++  -- * non-committal actions+  try        :: m a -> m a+  labels     :: m a -> Set String -> m a+  liftIt     :: It Rope a -> m a+  mark       :: m Delta   unexpected :: MonadParser m => String -> m a-  line :: m ByteString+  line       :: m ByteString +  -- * actions that commit+  satisfy    :: (Char -> Bool) -> m Char+  release    :: Delta -> m ()+   satisfyAscii :: (Char -> Bool) -> m Char   satisfyAscii f = toEnum . fromEnum <$> satisfy (f . toEnum . fromEnum) @@ -36,10 +41,10 @@  instance MonadParser m => MonadParser (StateT s m) where   satisfy = lift . satisfy-  commit (StateT m) = StateT $ commit . m+  try (StateT m) = StateT $ try . m   labels (StateT m) ss = StateT $ \s -> labels (m s) ss   line = lift line-  it = lift . it+  liftIt = lift . liftIt   mark = lift mark    release = lift . release   unexpected = lift . unexpected@@ -58,4 +63,4 @@   m <- mark   a <- pa   r <- mark-  it $ f a <$> sliceIt m r+  liftIt $ f a <$> sliceIt m r
Text/Trifecta/Parser/Err.hs view
@@ -5,6 +5,7 @@   ) where  import Control.Applicative+import Control.Comonad import Data.Semigroup import Data.Monoid import Data.Functor.Plus@@ -22,6 +23,16 @@   | EndOfFileErr   | RichErr (Render -> Diagnostic e) +instance Show (Err e) where+  showsPrec _ EmptyErr = showString "EmptyErr"+  showsPrec d (FailErr s) = showParen (d > 10) $+    showString "FailErr " . showsPrec 11 s+  showsPrec d (UnexpectedErr s) = showParen (d > 10) $+    showString "UnexpectedErr " . showsPrec 11 s+  showsPrec _ EndOfFileErr = showString "EndOfFileErr"+  showsPrec d (RichErr _) = showParen (d > 10) $ +    showString "RichErr ..."+ knownErr :: Err e -> Bool knownErr EmptyErr = False knownErr _ = True@@ -40,22 +51,19 @@ diagnoseTerm0 = diagnose prettyTerm emptyRender  instance Pretty t => Pretty (Err t) where-  pretty = pretty . diagnose0-  prettyList = prettyList . map diagnose0+  pretty = pretty . extract . diagnose0+  prettyList = prettyList . map (extract . diagnose0)  instance PrettyTerm t => PrettyTerm (Err t) where   prettyTerm = prettyTerm . diagnoseTerm0   prettyTermList = prettyTermList . map diagnoseTerm0   -instance Pretty t => Show (Err t) where-  show = show . pretty- instance Functor Err where-  fmap _ EmptyErr          = EmptyErr-  fmap _ (FailErr s)       = FailErr s-  fmap _ EndOfFileErr      = EndOfFileErr+  fmap _ EmptyErr = EmptyErr+  fmap _ (FailErr s) = FailErr s+  fmap _ EndOfFileErr = EndOfFileErr   fmap _ (UnexpectedErr s) = UnexpectedErr s -  fmap f (RichErr k)       = RichErr (fmap f . k)+  fmap f (RichErr k) = RichErr (fmap f . k)  instance Alt Err where   EmptyErr <!> a = a
Text/Trifecta/Parser/It.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE MultiParamTypeClasses, BangPatterns, MagicHash, UnboxedTuples #-}+{-# LANGUAGE MultiParamTypeClasses, BangPatterns, MagicHash, UnboxedTuples, TypeFamilies #-}+-- | harder, better, faster, stronger... module Text.Trifecta.Parser.It -  ( It(Pure, It, result)+  ( It(Pure, It)   , needIt   , wantIt+  , simplifyIt+  , runIt   , fillIt-  , lineIt+  , rewindIt   , sliceIt   , stepIt   ) where@@ -17,81 +20,120 @@ import Data.ByteString.Lazy as Lazy import Data.Functor.Bind import Data.Functor.Plus+import Data.Profunctor+import Data.Key as Key import Text.Trifecta.Rope as Rope import Text.Trifecta.Delta import Text.Trifecta.Bytes+import Text.Trifecta.Util as Util import Text.Trifecta.Util.MaybePair import Text.Trifecta.Parser.Step -data It a-  = Pure { result :: a } -  | It { result :: a, _it :: Rope -> It a }+data It r a+  = Pure a +  | It a (r -> It r a) -instance Functor It where-  fmap f (Pure a) = Pure (f a)-  fmap f (It a k) = It (f a) (fmap f . k)+instance Show a => Show (It r a) where+  showsPrec d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a+  showsPrec d (It a _) = showParen (d > 10) $ showString "It " . showsPrec 11 a . showString " ..." -instance Applicative It where+instance Functor (It r) where+  fmap f (Pure a) = Pure $ f a+  fmap f (It a k) = It (f a) $ fmap f . k++type instance Key (It r) = r++instance Profunctor It where+  lmap _ (Pure a) = Pure a+  lmap f (It a k) = It a (lmap f . k . f)++  rmap g (Pure a) = Pure (g a)+  rmap g (It a k) = It (g a) (rmap g . k)++instance Applicative (It r) where   pure = Pure-  Pure f  <*> Pure a  = Pure (f a)-  Pure f  <*> It a ka = It (f a) (fmap f . ka)-  It f kf <*> Pure a  = It (f a) (fmap ($a) . kf)-  It f kf <*> It a ka = It (f a) (\r -> kf r <*> ka r)+  Pure f  <*> Pure a  = Pure $ f a+  Pure f  <*> It a ka = It (f a) $ fmap f . ka+  It f kf <*> Pure a  = It (f a) $ fmap ($a) . kf+  It f kf <*> It a ka = It (f a) $ \r -> kf r <*> ka r -instance Monad It where+instance Indexable (It r) where+  index (Pure a) _ = a+  index (It _ k) r = extract (k r)++instance Lookup (It r) where+  lookup = lookupDefault++instance Zip (It r) where+  zipWith = liftA2++simplifyIt :: It r a -> r -> It r a+simplifyIt (It _ k) r = k r+simplifyIt pa _       = pa++instance Monad (It r) where   return = Pure   Pure a >>= f = f a-  It a k >>= f = It (result (f a)) (k >=> f)+  It a k >>= f = It (extract (f a)) $ \r -> case k r of +    It a' k' -> It (Key.index (f a') r) $ k' >=> f+    Pure a' -> simplifyIt (f a') r -instance Apply It where (<.>) = (<*>) -instance Bind It where (>>-) = (>>=) +instance Apply (It r) where (<.>) = (<*>) +instance Bind (It r) where (>>-) = (>>=)  -instance Extend It where+instance Extend (It r) where   duplicate p@Pure{} = Pure p   duplicate p@(It _ k) = It p (duplicate . k)    extend f p@Pure{} = Pure (f p)   extend f p@(It _ k) = It (f p) (extend f . k) -instance Comonad It where-  extract = result+-- | It is a cofree comonad+instance Comonad (It r) where+  extract (Pure a) = a+  extract (It a _) = a -needIt :: a -> (Rope -> Maybe a) -> It a+needIt :: a -> (r -> Maybe a) -> It r a needIt z f = k where    k = It z $ \r -> case f r of      Just a -> Pure a     Nothing -> k -wantIt :: a -> (Rope -> (# Bool, a #)) -> It a+wantIt :: a -> (r -> (# Bool, a #)) -> It r a wantIt z f = It z k where    k r = case f r of     (# False, a #) -> It a k     (# True,  a #) -> Pure a --- given a position, go there, and grab the text forward from that point-fillIt :: Delta -> It (MaybePair Delta Strict.ByteString)+-- scott decoding+runIt :: (a -> o) -> (a -> (r -> It r a) -> o) -> It r a -> o+runIt p _ (Pure a) = p a+runIt _ i (It a k) = i a k++-- * Rope specifics++-- | Given a position, go there, and grab the text forward from that point+fillIt :: Delta -> It Rope (MaybePair Delta Strict.ByteString) fillIt n = wantIt NothingPair $ \r ->    (# bytes n < bytes (rewind (delta r))   ,  grabLine n r NothingPair JustPair #) ++stepIt :: It Rope a -> Step e a+stepIt = go mempty where+  go r (Pure a) = StepDone r mempty a+  go r (It a k) = StepCont r (pure a) $ \s -> go s (k s)                                        --- return the text of the line that contains a given position-lineIt :: Delta -> It (Maybe Strict.ByteString)-lineIt n = wantIt Nothing $ \r -> +-- | Return the text of the line that contains a given position+rewindIt :: Delta -> It Rope (Maybe Strict.ByteString)+rewindIt n = wantIt Nothing $ \r ->    (# bytes n < bytes (rewind (delta r))-  ,  grabLine n r Nothing (const Just) #)+  ,  grabLine (rewind n) r Nothing $ const Just #) -sliceIt :: Delta -> Delta -> It Strict.ByteString+sliceIt :: Delta -> Delta -> It Rope Strict.ByteString sliceIt !i !j = wantIt mempty $ \r -> -  (# bytes j < bytes (rewind (delta r))-  ,  grabRest i r mempty $ const $ -     Strict.concat . -     Lazy.toChunks . -     Lazy.take (fromIntegral (bj - bi)) #)+  (# bj < bytes (rewind (delta r))+  ,  grabRest i r mempty $ const $ Util.fromLazy . Lazy.take (fromIntegral (bj - bi)) #)   where     bi = bytes i     bj = bytes j -stepIt :: It a -> Step e a-stepIt = go mempty where-  go r (Pure a) = StepDone r mempty a-  go r (It a k) = StepCont r (pure a) (\s -> go s (k s))
Text/Trifecta/Parser/Prim.hs view
@@ -24,6 +24,8 @@ import Text.Trifecta.Delta import Text.Trifecta.Diagnostic import Text.Trifecta.Render.Prim+import Text.Trifecta.Render.Caret+import Text.Trifecta.Rope import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.It import Text.Trifecta.Parser.Err@@ -35,11 +37,11 @@  data Parser e a = Parser    { unparser :: forall r.-    (a -> ErrState e -> Delta -> ByteString -> It r) ->  -- uncommitted ok-    (ErrState e -> Delta -> ByteString -> It r) ->       -- uncommitted err-    (a ->  ErrState e -> Delta -> ByteString -> It r) -> -- committed ok-    (ErrState e -> Delta -> ByteString -> It r) ->       -- committed err-    ErrState e -> Delta -> ByteString -> It r+    (a -> ErrState e -> Delta -> ByteString -> It Rope r) ->  -- uncommitted ok+    (ErrState e -> Delta -> ByteString -> It Rope r) ->       -- uncommitted err+    (a ->  ErrState e -> Delta -> ByteString -> It Rope r) -> -- committed ok+    (ErrState e -> Delta -> ByteString -> It Rope r) ->       -- committed err+    Delta -> ByteString -> It Rope r   }   instance Functor (Parser e) where@@ -48,28 +50,35 @@  instance Apply (Parser e) where (<.>) = (<*>) instance Applicative (Parser e) where-  pure a = Parser $ \ eo _ _ _ -> eo a +  pure a = Parser $ \ eo _ _ _ -> eo a mempty   {-# INLINE pure #-}   Parser m <*> Parser n = Parser $ \ eo ee co ce -> -    m (\f -> n (eo . f) ee (co . f) ce) ee-      (\f -> n (co . f) ce (co . f) ce) ce+    m (\f e -> n (\a e' -> eo (f a) (e <> e')) ee (\a e' -> co (f a) (e <> e')) ce) ee+      (\f e -> n (\a e' -> co (f a) (e <> e')) ce (\a e' -> co (f a) (e <> e')) ce) ce   {-# INLINE (<*>) #-}  instance Alt (Parser e) where (<!>) = (<|>) instance Plus (Parser e) where zero = empty instance Alternative (Parser e) where-  empty = Parser $ \_ ee _ _ -> ee+  empty = Parser $ \_ ee _ _ -> ee mempty   {-# INLINE empty #-}-  Parser m <|> Parser n = Parser $ \ eo ee co ce -> m eo (n eo ee co ce) co ce+  -- Parser m <|> Parser n = Parser $ \ eo ee co ce -> m eo (n eo ee co ce) co ce+  Parser m <|> Parser n = Parser $ \ eo ee co ce -> +    m eo (\e -> n (\a e'-> eo a (e <> e')) +                  (\e' -> ee (e <> e')) +                  co +                  ce) +      co ce+    {-# INLINE (<|>) #-}  instance Bind (Parser e) where (>>-) = (>>=) instance Monad (Parser e) where-  return a = Parser $ \ eo _ _ _ -> eo a +  return a = Parser $ \ eo _ _ _ -> eo a mempty   {-# INLINE return #-}   Parser m >>= k = Parser $ \ eo ee co ce -> -    m (\a -> unparser (k a) eo ee co ce) ee -      (\a -> unparser (k a) co ce co ce) ce+    m (\a e -> unparser (k a) (\b e' -> eo b (e <> e')) (\e' -> ee (e <> e')) co ce) ee +      (\a e -> unparser (k a) (\b e' -> co b (e <> e')) (\e' -> ce (e <> e')) co ce) ce   {-# INLINE (>>=) #-}   fail = throwError . FailErr   {-# INLINE fail #-}@@ -79,7 +88,7 @@   mplus = (<|>)   instance MonadWriter (Seq (Diagnostic e)) (Parser e) where-  tell w = Parser $ \eo _ _ _ e -> eo () e { errLog = errLog e <> w }+  tell w = Parser $ \eo _ _ _ -> eo () mempty { errLog = w }   {-# INLINE tell #-}   listen (Parser m) = Parser $ \eo ee co ce ->      m (\ a e -> eo (a,errLog e) e) ee @@ -89,53 +98,59 @@       (\(a,p) e -> co a e { errLog = p $ errLog e }) ce  instance MonadError (Err e) (Parser e) where-  throwError m = Parser $ \_ ee _ _ e -> ee e { errMessage = errMessage e <> m } +  throwError m = Parser $ \_ ee _ _ -> ee mempty { errMessage = m }    {-# INLINE throwError #-}-  catchError (Parser p) k = Parser $ \ eo ee co ce e -> p eo (\e' -> unparser (k (errMessage e')) eo ee co ce e) co ce e+  catchError (Parser m) k = Parser $ \ eo ee co ce -> +    m eo (\e -> unparser (k (errMessage e)) (\a e'-> eo a (e <> e')) (\e' -> ee (e <> e')) co ce) +      co ce   {-# INLINE catchError #-}  instance MonadParser (Parser e) where-  commit (Parser m) = Parser $ \ _ _ co ce -> m co ce co ce-  unexpected s = Parser $ \ _ ee _ _ e -> ee e { errMessage = UnexpectedErr s } -  {-# INLINE commit #-}+  -- commit (Parser m) = Parser $ \ _ _ co ce -> m co ce co ce+  try (Parser m) = Parser $ \ eo ee co _ -> m eo ee co ee+  {-# INLINE try #-}+  unexpected s = Parser $ \ _ ee _ _ -> ee mempty { errMessage = UnexpectedErr s } +   labels (Parser p) msgs = Parser $ \ eo ee -> p-     (\a e -> eo a (if knownErr (errMessage e) then e { errExpected = errExpected e `union` msgs } else e))-     (\e -> ee e { errExpected = errExpected e `union` msgs })+     (\a e -> eo a $ if knownErr (errMessage e) +                     then e { errExpected = errExpected e }+                     else e)+     (\e -> ee e { errExpected = msgs })   {-# INLINE labels #-}-  it m = Parser $ \ eo _ _ _ e d bs -> do +  liftIt m = Parser $ \ eo _ _ _ d bs -> do       a <- m-     eo a e d bs-  {-# INLINE it #-}-  mark = Parser $ \eo _ _ _ e d -> eo d e d+     eo a mempty d bs+  {-# INLINE liftIt #-}+  mark = Parser $ \eo _ _ _ d -> eo d mempty d   {-# INLINE mark #-}-  release d' = Parser $ \eo ee _ _ e d bs -> do-    mbs <- lineIt d'+  release d' = Parser $ \_ ee co _ d bs -> do+    mbs <- rewindIt d'     case mbs of-      Just bs' -> eo () e d' bs'-      Nothing -> ee e d bs+      Just bs' -> co () mempty d' bs'+      Nothing -> ee mempty d bs   {-# INLINE release #-}-  line = Parser $ \eo _ _ _ e d bs -> eo bs e d bs+  line = Parser $ \eo _ _ _ d bs -> eo bs mempty d bs   {-# INLINE line #-}-  satisfy f = Parser $ \ eo ee _ _ e d bs ->+  satisfy f = Parser $ \ _ ee co _ d bs ->     case UTF8.uncons $ Strict.drop (columnByte d) bs of-      Nothing -> ee e { errMessage = EndOfFileErr } d bs+      Nothing             -> ee mempty { errMessage = EndOfFileErr } d bs       Just (c, xs) -        | not (f c) -> ee e d bs-        | Strict.null xs -> fillIt (d <> delta c) >>= \dbs -> case dbs of-          JustPair d' bs' -> eo c e d' bs'-          NothingPair -> eo c e (d <> delta c) bs -- END OF LINE-        | otherwise -> eo c e (d <> delta c) bs +        | not (f c)       -> ee mempty d bs+        | Strict.null xs  -> fillIt (d <> delta c) >>= \dbs -> case dbs of+          JustPair d' bs' -> co c mempty d' bs'+          NothingPair     -> co c mempty (d <> delta c) bs -- END OF LINE+        | otherwise       -> co c mempty (d <> delta c) bs    {-# INLINE satisfy #-}-  satisfyAscii f = Parser $ \ eo ee _ _ e d bs ->+  satisfyAscii f = Parser $ \ _ ee co _ d bs ->     let b = columnByte d in     if b >= 0 && b < Strict.length bs      then case toEnum $ fromEnum $ Strict.index bs b of-      c | not (f c) -> ee e d bs+      c | not (f c)                 -> ee mempty d bs         | b == Strict.length bs - 1 -> fillIt (d <> delta c) >>= \dbs -> case dbs of-          JustPair d' bs' -> eo c e d' bs'-          NothingPair -> eo c e (d <> delta c) bs-        | otherwise -> eo c e (d <> delta c) bs-    else ee e { errMessage = EndOfFileErr } d bs+          JustPair d' bs'           -> co c mempty d' bs'+          NothingPair               -> co c mempty (d <> delta c) bs+        | otherwise                 -> co c mempty (d <> delta c) bs+    else ee mempty { errMessage = EndOfFileErr } d bs   {-# INLINE satisfyAscii #-}  data St e a = JuSt a !(ErrState e) !Delta !ByteString@@ -147,9 +162,9 @@  stepParser :: (Diagnostic e -> Diagnostic t) ->                (ErrState e -> Delta -> ByteString -> Diagnostic t) ->-              Parser e a -> ErrState e -> Delta -> ByteString -> Step t a-stepParser yl y (Parser p) e0 d0 bs0 = -  go mempty $ p ju no ju no e0 d0 bs0+              Parser e a -> Delta -> ByteString -> Step t a+stepParser yl y (Parser p) d0 bs0 = +  go mempty $ p ju no ju no d0 bs0   where     ju a e d bs = Pure (JuSt a e d bs)     no e d bs = Pure (NoSt e d bs)@@ -160,17 +175,18 @@                                    NoSt e d bs  -> Failure (yl <$> errLog e) (y e d bs))                                  (go <*> k) -why :: (e -> Doc t) -> ErrState e -> Delta -> ByteString -> Diagnostic (Doc t)-why pp (ErrState ss m _) d bs -  | Set.null ss = diagnose pp (surface d bs) m-  | otherwise   = expected <$> diagnose pp (surface d bs) m +why :: Pretty e => (e -> Doc t) -> ErrState e -> Delta -> ByteString -> Diagnostic (Doc t)+why pp (ErrState ss _m _) d bs +  | Set.null ss = diagnose pp (addCaret d $ surface d bs) m+  | otherwise   = expected <$> diagnose pp (addCaret d $ surface d bs) m    where+    m = EmptyErr     expected doc = doc <> text ", expected" <+> fillSep (punctuate (char ',') $ text <$> toList ss) -parseTest :: Show a => Parser TermDoc a -> ByteString -> IO ()-parseTest p bs = case eof (feed st bs) of+parseTest :: Show a => Parser TermDoc a -> String -> IO ()+parseTest p s = case eof (feed st (UTF8.fromString s)) of   Failure xs e -> displayLn $ prettyTerm $ toList (xs |> e)   Success xs a -> do      displayLn $ prettyTerm $ toList xs     print a-  where st = stepParser id (why id) (release mempty *> p) mempty mempty bs+  where st = stepParser id (why id) (release mempty *> p) mempty mempty
Text/Trifecta/Parser/Result.hs view
@@ -12,10 +12,21 @@ import Data.Bifunctor import Data.Sequence import Text.Trifecta.Diagnostic+import Text.PrettyPrint.Free+import System.Console.Terminfo.PrettyPrint  data Result e a   = Success !(Seq (Diagnostic e)) a   | Failure !(Seq (Diagnostic e)) !(Diagnostic e)+  deriving Show++instance (Pretty e, Show a) => Pretty (Result e a) where+  pretty (Success xs a) = prettyList (toList xs) `above` string (show a)+  pretty (Failure xs e) = prettyList $ toList $ xs |> e++instance (PrettyTerm e, Show a) => PrettyTerm (Result e a) where+  prettyTerm (Success xs a) = prettyTermList (toList xs) `above` string (show a)+  prettyTerm (Failure xs e) = prettyTermList $ toList $ xs |> e  instance Functor (Result e) where   fmap f (Success xs a) = Success xs (f a)
Text/Trifecta/Parser/Step.hs view
@@ -19,6 +19,14 @@   | StepFail !Rope !(Seq (Diagnostic e)) !(Diagnostic e)   | StepCont !Rope (Result e a) (Rope -> Step e a) +instance (Show e, Show a) => Show (Step e a) where+  showsPrec d (StepDone r xs a) = showParen (d > 10) $ +    showString "StepDone " . showsPrec 11 r . showChar ' ' . showsPrec 11 xs . showChar ' ' . showsPrec 11 a+  showsPrec d (StepFail r xs e) = showParen (d > 10) $ +    showString "StepFail " . showsPrec 11 r . showChar ' ' . showsPrec 11 xs . showChar ' ' . showsPrec 11 e+  showsPrec d (StepCont r fin _) = showParen (d > 10) $ +    showString "StepCont " . showsPrec 11 r . showChar ' ' . showsPrec 11 fin . showString " ..."+     instance Functor (Step e) where   fmap f (StepDone r xs a) = StepDone r xs (f a)   fmap _ (StepFail r xs e) = StepFail r xs e
+ Text/Trifecta/Render/Prim.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE TypeSynonymInstances #-}+-- | Diagnostics rendering+module Text.Trifecta.Render.Prim +  ( Render(..)+  , Renderable(..)+  , Source(..)+  , Rendered(..)+  , surface+  , nullRender+  , emptyRender+  -- * Lower level drawing primitives+  , Lines+  , draw+  , ifNear+  , (.#)+  ) where++import Control.Applicative+import Control.Comonad+import Control.Monad.State+import Data.Array+import Data.ByteString hiding (groupBy, empty, any)+import Data.Foldable+import Data.Monoid+import Data.Function (on)+import Data.Functor.Bind+import Data.List (groupBy)+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Traversable+import Prelude as P+import Prelude hiding (span)+import System.Console.Terminfo.PrettyPrint+import Text.PrettyPrint.Free hiding (column)+import Text.Trifecta.Bytes+import Text.Trifecta.Delta+import qualified Data.ByteString.UTF8 as UTF8 ++outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect]+outOfRangeEffects xs = soft Bold : xs++type Lines = Array (Int,Int) ([ScopedEffect], Char)++(///) :: Ix i => Array i e -> [(i, e)] -> Array i e+a /// xs = a // P.filter (inRange (bounds a) . fst) xs+++grow :: Int -> Lines -> Lines+grow y a +  | inRange (t,b) y = a+  | otherwise = array new [ (i, if inRange old i then a ! i else ([],' ')) | i <- range new ]+  where old@((t,lo),(b,hi)) = bounds a+        new = ((min t y,lo),(max b y,hi))++draw :: [ScopedEffect] -> Int -> Int -> String -> Lines -> Lines+draw e y n xs a0 +  | Prelude.null xs = a0+  | otherwise = gt $ lt (a /// out) +  where +    a = grow y a0+    ((_,lo),(_,hi)) = bounds a+    out = P.zipWith (\i c -> ((y,i),(e,c))) [n..] xs+    lt | Prelude.any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))])+       | otherwise = id+    gt | Prelude.any (\el -> snd (fst el) > hi) out = (// [((y,hi),(outOfRangeEffects e,'>'))])+       | otherwise = id++data Render = Render +  { rDelta     :: !Delta                  -- focus, the render will keep this visible+  , rLineLen   :: {-# UNPACK #-} !Int     -- actual line length+  , rLine      :: Lines -> Lines+  , rDraw      :: Delta -> Lines -> Lines+  }++instance Show Render where+  showsPrec d (Render p ll _ _) = showParen (d > 10) $ +    showString "Render " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showString " ... ..."++nullRender :: Render -> Bool+nullRender (Render (Columns 0 0) 0 _ _) = True+nullRender _ = False++emptyRender :: Render +emptyRender = surface (Columns 0 0) ""++instance Semigroup Render where+  -- an unprincipled hack+  Render (Columns 0 0) 0 _ f <> Render del len doc g = Render del len doc $ \d l -> f d (g d l)+  Render del len doc f <> Render _ _ _ g = Render del len doc $ \d l -> f d (g d l)++instance Monoid Render where+  mappend = (<>) +  mempty = emptyRender+  +ifNear :: Delta -> (Lines -> Lines) -> Delta -> Lines -> Lines+ifNear d f d' l | near d d' = f l +                | otherwise = l++instance HasDelta Render where+  delta = rDelta++class Renderable t where+  render :: t -> Render ++instance Renderable Render where+  render = id++class Source t where+  source :: t -> (Int, Lines -> Lines)++instance Source String where+  source s = (P.length s', draw [] 0 0 s') where +    s' = go 0 s+    go n ('\t':xs) = let t = 8 - mod n 8 in P.replicate t ' ' ++ go (n + t) xs+    go _ ('\n':_)  = []+    go n (x:xs)    = x : go (n + 1) xs+    go _ []        = []++instance Source ByteString where+  source = source . UTF8.toString++-- | create a drawing surface+surface :: Source s => Delta -> s -> Render+surface del s = case source s of +  (len, doc) -> Render del len doc (\_ l -> l)++(.#) :: (Delta -> Lines -> Lines) -> Render -> Render+f .# Render d ll s g = Render d ll s $ \e l -> f e $ g e l ++instance Pretty Render where+  pretty r = prettyTerm r >>= const empty++instance PrettyTerm Render where+  prettyTerm (Render d ll l f) = nesting $ \k -> columns $ \n -> go (n - k) where+    go cols = align (vsep (P.map ln [t..b])) where +      (lo, hi) = window (column d) ll (cols - 2)+      a = f d $ l $ array ((0,lo),(-1,hi)) []+      ((t,_),(b,_)) = bounds a+      ln y = hcat +           $ P.map (\g -> P.foldr with (string (P.map snd g)) (fst (P.head g)))+           $ groupBy ((==) `on` fst) +           [ a ! (y,i) | i <- [lo..hi] ] ++window :: Int -> Int -> Int -> (Int, Int)+window c l w +  | c <= w2     = (0, min w l)+  | c + w2 >= l = if l > w then (l-w, l) else (0, w)+  | otherwise   = (c-w2,c + w2)+  where w2 = div w 2++data Rendered a = a :@ Render+  deriving Show+++instance Functor Rendered where+  fmap f (a :@ s) = f a :@ s++instance HasDelta (Rendered a) where+  delta = delta . render++instance HasBytes (Rendered a) where+  bytes = bytes . delta++instance Extend Rendered where+  extend f as@(_ :@ s) = f as :@ s++instance Comonad Rendered where+  extract (a :@ _) = a++instance Apply Rendered where+  (f :@ s) <.> (a :@ t) = f a :@ (s <> t)++instance Bind Rendered where+  (a :@ s) >>- f = case f a of+     b :@ t -> b :@ (s <> t)++instance Foldable Rendered where+  foldMap f (a :@ _) = f a ++instance Traversable Rendered where+  traverse f (a :@ s) = (:@ s) <$> f a++instance Foldable1 Rendered where+  foldMap1 f (a :@ _) = f a ++instance Traversable1 Rendered where+  traverse1 f (a :@ s) = (:@ s) <$> f a++instance Renderable (Rendered a) where+  render (_ :@ s) = s
Text/Trifecta/Rope.hs view
@@ -19,6 +19,7 @@ import Text.Trifecta.Delta import Text.Trifecta.Bytes import Text.Trifecta.Strand+import Text.Trifecta.Util as Util  data Rope = Rope !Delta !(FingerTree Delta Strand) deriving Show @@ -31,7 +32,7 @@ -- | grab a the contents of a rope from a given location up to a newline grabRest :: Delta -> Rope -> r -> (Delta -> Lazy.ByteString -> r) -> r grabRest i t kf ks = trim (toList r) (delta l) (bytes i - bytes l) where-  trim (PathStrand p : xs) j k = trim xs (j <> delta p) k+  trim (PathStrand p            : xs) j k = trim xs (j <> delta p) k   trim (HunkStrand (Hunk _ _ h) : xs) j 0 = go j h xs   trim (HunkStrand (Hunk _ _ h) : xs) _ k = go i (Strict.drop k h) xs   trim [] _ _ = kf@@ -40,7 +41,7 @@  -- | grab a the contents of a rope from a given location up to a newline grabLine :: Delta -> Rope -> r -> (Delta -> Strict.ByteString -> r) -> r-grabLine i t kf ks = grabRest i t kf $ \c -> ks c . Strict.concat . Lazy.toChunks . Lazy.takeWhile (/= 10)+grabLine i t kf ks = grabRest i t kf $ \c -> ks c . Util.fromLazy . Util.takeLine  instance HasBytes Rope where   bytes = bytes . measure
Text/Trifecta/Util.hs view
@@ -1,8 +1,15 @@ module Text.Trifecta.Util    ( argmin   , argmax+  -- * ByteString conversions+  , fromLazy+  , toLazy+  , takeLine   ) where +import Data.ByteString.Lazy as Lazy+import Data.ByteString as Strict+ argmin :: Ord b => (a -> b) -> a -> a -> a argmin f a b   | f a <= f b = a@@ -14,4 +21,15 @@   | f a > f b = a   | otherwise = b {-# INLINE argmax #-}++fromLazy :: Lazy.ByteString -> Strict.ByteString+fromLazy = Strict.concat . Lazy.toChunks+     +toLazy :: Strict.ByteString -> Lazy.ByteString+toLazy = Lazy.fromChunks . return++takeLine :: Lazy.ByteString -> Lazy.ByteString+takeLine s = case Lazy.elemIndex 10 s of+  Just i -> Lazy.take (i + 1) s+  Nothing -> s
Text/Trifecta/Util/MaybePair.hs view
@@ -14,6 +14,7 @@ import Data.Traversable  data MaybePair a b = JustPair a b | NothingPair+  deriving (Eq,Ord,Show,Read)  instance (Semigroup a, Semigroup b) => Semigroup (MaybePair a b) where   a <> NothingPair = a
trifecta.cabal view
@@ -1,6 +1,6 @@ name:          trifecta category:      Text, Parsing-version:       0.13+version:       0.14 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -30,6 +30,7 @@     semigroups         >= 0.7.1   && < 0.8,      fingertree         >= 0.0.1   && < 0.1,     reducers           >= 0.1.2   && < 0.2,+    profunctors        >= 0.1.1   && < 0.2,     parsec             >= 3.1.1   && < 3.2,     utf8-string        >= 0.3.6   && < 0.4,     semigroupoids      >= 1.2.4   && < 1.3,@@ -37,6 +38,7 @@     transformers       >= 0.2.2   && < 0.3,     comonad            >= 1.1.1   && < 1.2,     terminfo           >= 0.3.2   && < 0.4,+    keys               >= 2.0.1   && < 2.1,     wl-pprint-extras   >= 1.4     && < 1.5,     wl-pprint-terminfo >= 0.4     && < 0.5 @@ -58,6 +60,7 @@     Text.Trifecta.Parser.Result     Text.Trifecta.Parser.Step     Text.Trifecta.Path+    Text.Trifecta.Render.Prim     Text.Trifecta.Render.Caret     Text.Trifecta.Render.Fixit     Text.Trifecta.Render.Span