module Text.Trifecta.Diagnostic.Rendering.Caret
( Caret(..)
, caret
, Careted(..)
, careted
, drawCaret
, addCaret
, caretEffects
) where
import Control.Applicative
import Control.Comonad
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Functor.Bind
import Data.Hashable
import Data.Semigroup
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Semigroup.Reducer
import Data.Traversable
import Prelude hiding (span)
import System.Console.Terminfo.Color
import System.Console.Terminfo.PrettyPrint
import Text.Trifecta.Rope.Bytes
import Text.Trifecta.Rope.Delta
import Text.Trifecta.Parser.Class
import Text.Trifecta.Diagnostic.Rendering.Prim
data Caret = Caret !Delta !ByteString deriving (Eq,Ord,Show)
instance Hashable Caret where
hash (Caret d bs) = hash d `hashWithSalt` bs
caretEffects :: [ScopedEffect]
caretEffects = [soft (Foreground Green), soft Bold]
drawCaret :: Delta -> Delta -> Lines -> Lines
drawCaret p = ifNear p $ draw caretEffects 1 (fromIntegral (column p)) "^"
addCaret :: Delta -> Rendering -> Rendering
addCaret p r = drawCaret p .# r
caret :: MonadParser m => m Caret
caret = Caret <$> mark <*> line
careted :: MonadParser m => m a -> m (Careted a)
careted p = do
m <- mark
l <- line
a <- p
return $ a :^ Caret m l
instance HasBytes Caret where
bytes = bytes . delta
instance HasDelta Caret where
delta (Caret d _) = d
instance Renderable Caret where
render (Caret d bs) = addCaret d $ rendering d bs
instance Reducer Caret Rendering where
unit = render
instance Semigroup Caret where
a <> _ = a
data Careted a = a :^ Caret deriving (Eq,Ord,Show)
instance Functor Careted where
fmap f (a :^ s) = f a :^ s
instance Extend Careted where
extend f as@(_ :^ s) = f as :^ s
instance Comonad Careted where
extract (a :^ _) = a
instance Foldable Careted where
foldMap f (a :^ _) = f a
instance Traversable Careted where
traverse f (a :^ s) = (:^ s) <$> f a
instance Foldable1 Careted where
foldMap1 f (a :^ _) = f a
instance Traversable1 Careted where
traverse1 f (a :^ s) = (:^ s) <$> f a
instance Renderable (Careted a) where
render (_ :^ a) = render a
instance Reducer (Careted a) Rendering where
unit = render
instance Hashable a => Hashable (Careted a) where