-
Notifications
You must be signed in to change notification settings - Fork 49
/
Highlight.hs
168 lines (145 loc) · 5.9 KB
/
Highlight.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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.Trifecta.Highlight
-- 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.Highlight
( Highlight
, HighlightedRope(HighlightedRope)
, HasHighlightedRope(..)
, withHighlight
, HighlightDoc(HighlightDoc)
, HasHighlightDoc(..)
, doc
) where
import Control.Lens
import Data.Foldable as F
import Data.Int (Int64)
import Data.Key hiding ((!))
import Data.List (sort)
import Data.Semigroup
import Data.Semigroup.Union
import Prelude hiding (head)
import Text.Blaze
import Text.Blaze.Html5 hiding (a,b,i)
import qualified Text.Blaze.Html5 as Html5
import Text.Blaze.Html5.Attributes hiding (title,id)
import Text.Blaze.Internal
import Text.Parser.Token.Highlight
import Text.PrettyPrint.ANSI.Leijen hiding ((<>))
import Text.Trifecta.Util.IntervalMap as IM
import Text.Trifecta.Delta
import Text.Trifecta.Rope
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8
withHighlight :: Highlight -> Doc -> Doc
withHighlight Comment = blue
withHighlight ReservedIdentifier = magenta
withHighlight ReservedConstructor = magenta
withHighlight EscapeCode = magenta
withHighlight Operator = yellow
withHighlight CharLiteral = cyan
withHighlight StringLiteral = cyan
withHighlight Constructor = bold
withHighlight ReservedOperator = yellow
withHighlight ConstructorOperator = yellow
withHighlight ReservedConstructorOperator = yellow
withHighlight _ = id
{-
pushToken, popToken :: Highlight -> Doc
pushToken h = Prelude.foldr (\x b -> pure (Push x) <> b) mempty (withHighlight h)
popToken h = Prelude.foldr (\_ b -> pure Pop <> b) mempty (withHighlight h)
-}
data HighlightedRope = HighlightedRope
{ _ropeHighlights :: !(IM.IntervalMap Delta Highlight)
, _ropeContent :: {-# UNPACK #-} !Rope
}
makeClassy ''HighlightedRope
instance HasDelta HighlightedRope where
delta = delta . _ropeContent
instance HasBytes HighlightedRope where
bytes = bytes . _ropeContent
instance Semigroup HighlightedRope where
HighlightedRope h bs <> HighlightedRope h' bs' = HighlightedRope (h `union` IM.offset (delta bs) h') (bs <> bs')
instance Monoid HighlightedRope where
mappend = (<>)
mempty = HighlightedRope mempty mempty
data Located a = a :@ {-# UNPACK #-} !Int64
infix 5 :@
instance Eq (Located a) where
_ :@ m == _ :@ n = m == n
instance Ord (Located a) where
compare (_ :@ m) (_ :@ n) = compare m n
instance ToMarkup HighlightedRope where
toMarkup (HighlightedRope intervals r) = Html5.pre $ go 0 lbs effects where
lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)]
ln no = Html5.a ! name (toValue $ "line-" ++ show no) $ Empty
effects = sort $ [ i | (Interval lo hi, tok) <- intersections mempty (delta r) intervals
, i <- [ (Leaf "span" "<span" ">" ! class_ (toValue $ show tok)) :@ bytes lo
, preEscapedString "</span>" :@ bytes hi
]
] ++ mapWithKey (\k i -> ln k :@ i) (L.elemIndices '\n' lbs)
go _ cs [] = unsafeLazyByteString cs
go b cs ((eff :@ eb) : es)
| eb <= b = eff >> go b cs es
| otherwise = unsafeLazyByteString om >> go eb nom es
where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs
instance Pretty HighlightedRope where
pretty (HighlightedRope _intervals r) = go 0 lbs effects where
lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)]
effects = error "pretty HighlightRope effects"
{-
effects = sort $ [ i | (Interval lo hi, tok) <- intersections mempty (delta r) intervals
, i <- [ pushToken tok :@ bytes lo
, popToken tok :@ bytes hi
]
]
-}
go _ cs [] = pretty (LazyUTF8.toString cs)
go b cs ((eff :@ eb) : es)
| eb <= b = eff <> go b cs es
| otherwise = pretty (LazyUTF8.toString om) <> go eb nom es
where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs
-- | Represents a source file like an HsColour rendered document
data HighlightDoc = HighlightDoc
{ _docTitle :: String
, _docCss :: String -- href for the css file
, _docContent :: HighlightedRope
}
makeClassy ''HighlightDoc
doc :: String -> HighlightedRope -> HighlightDoc
doc t r = HighlightDoc t "trifecta.css" r
instance ToMarkup HighlightDoc where
toMarkup (HighlightDoc t css cs) = docTypeHtml $ do
head $ do
preEscapedString "<!-- Generated by trifecta, http://github.com/ekmett/trifecta/ -->\n"
title $ toHtml t
link ! rel "stylesheet" ! type_ "text/css" ! href (toValue css)
body $ toHtml cs
{-
newtype Highlighter m a = Highlighter { runHighlighter :: IntervalMap Map Highlight -> m (a, IntervalMap Map Highlight) }
deriving (Functor)
instance (Functor m, Monad m) => Applicative (Highlighter m) where
(<*>) = ap
pure = return
instance (Functor m, MonadPlus m) => Alternative (Highlighter m) where
(<|>) = mplus
empty = mzero
instance Monad m => Monad (Highlighter m) where
return a = Highlighter $ \s -> return (a, s)
Highlighter m >>= f = Highlighter $ \s -> m s >>= \(a, s') -> runHighlighter (f a) s'
instance MonadTrans Highlighter where
lift m = Highlighter $ \s -> fmap (\a -> (a,s)) m
instance MonadPlus m => MonadPlus (Highlighter m) where
mplus (Highlighter m) (Highligher n) = Highlighter $ \s -> m s `mplus` n s
mzero = Highlighter $ const mzero
-- instance Parsing m => Parsing (Highlighter m) where
-}