/
Span.hs
125 lines (101 loc) · 3.42 KB
/
Span.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.Trifecta.Diagnostic.Rendering.Span
-- Copyright : (C) 2011 Edward Kmett
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : experimental
-- Portability : non-portable
--
----------------------------------------------------------------------------
module Text.Trifecta.Diagnostic.Rendering.Span
( Span(..)
, span
, Spanned(..)
, spanned
-- * Internals
, spanEffects
, drawSpan
, addSpan
) where
import Control.Applicative
import Data.Hashable
import Data.Semigroup
import Data.Semigroup.Reducer
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Foldable
import Data.Traversable
import Control.Comonad
import Data.Functor.Bind
import Data.ByteString (ByteString)
import Text.Trifecta.Rope.Bytes
import Text.Trifecta.Rope.Delta
import Text.Trifecta.Diagnostic.Rendering.Prim
import Text.Trifecta.Util
import Text.Trifecta.Parser.Class
import Data.Array
import System.Console.Terminfo.Color
import System.Console.Terminfo.PrettyPrint
import Prelude as P hiding (span)
spanEffects :: [ScopedEffect]
spanEffects = [soft (Foreground Green)]
drawSpan :: Delta -> Delta -> Delta -> Lines -> Lines
drawSpan s e d a
| nl && nh = go (column l) (rep (max (column h - column l) 0) '~') a
| nl = go (column l) (rep (max (snd (snd (bounds a)) - column l + 1) 0) '~') a
| nh = go (-1) (rep (max (column h + 1) 0) '~') a
| otherwise = a
where
go = draw spanEffects 1 . fromIntegral
l = argmin bytes s e
h = argmax bytes s e
nl = near l d
nh = near h d
rep = P.replicate . fromIntegral
-- |
-- > int main(int argc, char ** argv) { int; }
-- > ^~~
addSpan :: Delta -> Delta -> Rendering -> Rendering
addSpan s e r = drawSpan s e .# r
data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show)
instance Renderable Span where
render (Span s e bs) = addSpan s e $ rendering s bs
instance Semigroup Span where
Span s _ b <> Span _ e _ = Span s e b
instance Reducer Span Rendering where
unit = render
data Spanned a = a :~ Span deriving (Eq,Ord,Show)
instance Functor Spanned where
fmap f (a :~ s) = f a :~ s
instance Extend Spanned where
extend f as@(_ :~ s) = f as :~ s
instance Comonad Spanned where
extract (a :~ _) = a
instance Apply Spanned where
(f :~ s) <.> (a :~ t) = f a :~ (s <> t)
instance Bind Spanned where
(a :~ s) >>- f = case f a of
b :~ t -> b :~ (s <> t)
instance Foldable Spanned where
foldMap f (a :~ _) = f a
instance Traversable Spanned where
traverse f (a :~ s) = (:~ s) <$> f a
instance Foldable1 Spanned where
foldMap1 f (a :~ _) = f a
instance Traversable1 Spanned where
traverse1 f (a :~ s) = (:~ s) <$> f a
instance Reducer (Spanned a) Rendering where
unit = render
instance Renderable (Spanned a) where
render (_ :~ s) = render s
instance Hashable Span where
hash (Span s e bs) = hash s `hashWithSalt` e `hashWithSalt` bs
instance Hashable a => Hashable (Spanned a) where
hash (a :~ s) = hash a `hashWithSalt` s
span :: MonadParser m => m a -> m Span
span p = (\s l e -> Span s e l) <$> position <*> line <*> (p *> position)
spanned :: MonadParser m => m a -> m (Spanned a)
spanned p = (\s l a e -> a :~ Span s e l) <$> position <*> line <*> p <*> position