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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
|
-- Copyright 2019 Google LLC
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module RenderHtml (renderResults, renderResultsInc, renderStandaloneHTML) where
import Text.Blaze.Internal (MarkupM)
import Text.Blaze.Html5 as H hiding (map, a, b)
import Text.Blaze.Html5.Attributes as At
import Text.Blaze.Html.Renderer.String
import Data.ByteString.Lazy (toStrict)
import qualified Data.ByteString as BS
import Data.Aeson (ToJSON (..), encode)
import qualified Data.Map.Strict as M
import Control.Monad.State.Strict
import Data.Foldable (fold)
import Data.Maybe (fromJust)
import Data.Functor ((<&>))
import Data.String (fromString)
import Data.Text qualified as T
import CMark (commonmarkToHtml)
import GHC.Generics
import Err
import PPrint
import Types.Source
import Util (unsnoc, foldMapM)
import IncState
import Live.Eval
type RenderingState = NodeList RenderedCellState
type RenderingUpdate = NodeListUpdate RenderedCellState
data RenderedCellState = RenderedCellState RenderedSourceBlock CellStatus RenderedOutputs
deriving Generic
data RenderedCellUpdate = RenderedCellUpdate (Overwrite CellStatus) RenderedOutputs
deriving Generic
instance Semigroup RenderedCellUpdate where
RenderedCellUpdate s o <> RenderedCellUpdate s' o' = RenderedCellUpdate (s<>s') (o<>o')
instance Monoid RenderedCellUpdate where
mempty = RenderedCellUpdate mempty mempty
instance ToJSON RenderedCellState
instance ToJSON RenderedCellUpdate
instance IncState RenderedCellState where
type Delta RenderedCellState = RenderedCellUpdate
applyDiff (RenderedCellState sb status result) (RenderedCellUpdate status' result') =
RenderedCellState sb (fromOverwritable (applyDiff (Overwritable status) status')) (result <> result')
renderResults :: CellsState -> IO RenderingUpdate
renderResults cellsState = fst <$> renderResultsInc cellsState
renderResultsInc :: CellsState -> IO (RenderingUpdate, CellsUpdate -> IO RenderingUpdate)
renderResultsInc initState = do
(initRender, updates) <- runIncM renderCells initState
return (nodeListAsUpdate initRender, updates)
type BlockId = Int
renderCells :: IncVar CellsState -> IncM (IncVar RenderingState)
renderCells cells = fmapNodeList cells renderCell
renderCell :: BlockId -> IncVar CellState -> IncM (IncVar RenderedCellState)
renderCell blockId cellState = do
(sourceBlock, status, outputs) <- unpackCellStateInc cellState
sourceBlock' <- fmapAllOrNothing sourceBlock $ renderSourceBlock blockId
outputs' <- renderOutputs outputs
packRenderedCellState sourceBlock' status outputs'
renderOutputs :: IncVar (MonoidState Outputs) -> IncM (IncVar (MonoidState RenderedOutputs))
renderOutputs outputsVar = liftMonoidStateIncM outputsVar do
return \(Outputs outs) -> foldMapM renderOutput outs
fmapNodeList :: IncVar (NodeList a) -> (BlockId -> IncVar a -> IncM (IncVar b)) -> IncM (IncVar (NodeList b))
fmapNodeList nl f = do
(l, m) <- unpackNodeList nl
m' <- fmapIncMap m f
packNodeList l m'
unpackCellStateInc
:: IncVar CellState -> IncM ( IncVar (Unchanging SourceBlock)
, IncVar (Overwritable CellStatus)
, IncVar (MonoidState Outputs) )
unpackCellStateInc cellState = do
incUnzip3 =<< fmapIncVar cellState
(\(CellState sb s outs) -> (Unchanging sb, Overwritable s, MonoidState outs))
(\(CellUpdate s outs) -> ((), s, outs))
packRenderedCellState
:: IncVar (Unchanging RenderedSourceBlock)
-> IncVar (Overwritable CellStatus)
-> IncVar (MonoidState RenderedOutputs)
-> IncM (IncVar RenderedCellState)
packRenderedCellState sourceBlock status outputs = do
renderedCellState <- incZip3 sourceBlock status outputs
fmapIncVar renderedCellState
(\(Unchanging sb, Overwritable s, MonoidState outs) -> RenderedCellState sb s outs)
(\((), s, outs) -> RenderedCellUpdate s outs)
unpackNodeList :: IncVar (NodeList a) -> IncM (IncVar [NodeId], IncVar (M.Map NodeId a))
unpackNodeList nl = do
incUnzip2 =<< fmapIncVar nl (\(NodeList l m) -> (l, m)) (\(NodeListUpdate l m) -> (l, m))
packNodeList :: IncVar [NodeId] -> IncVar (M.Map NodeId a) -> IncM (IncVar (NodeList a))
packNodeList lv mv = do
nl <- incZip2 lv mv
fmapIncVar nl (\(l, m) -> NodeList l m) (\(l, m) -> NodeListUpdate l m)
-- === rendering results ===
-- RenderedOutputs, RenderedSourceBlock aren't 100% HTML themselves but the idea
-- is that they should be trivially convertable to JSON and sent over to the
-- client which can do the final rendering without much code or runtime work.
data RenderedSourceBlock = RenderedSourceBlock
{ rsbLine :: Int
, rsbNumLines :: Int
, rsbBlockId :: BlockId
, rsbLexemeList :: [SrcId]
, rsbText :: String
, rsbHtml :: String}
deriving (Generic)
type RenderedOutputs = [RenderedOutput]
data RenderedOutput =
RenderedTextOut String
| RenderedHtmlOut String
| RenderedPassResult PassName (Maybe String)
| RenderedMiscLog String
| RenderedError (Maybe SrcId) String
| RenderedTreeNodeUpdate [(SrcId, MapEltUpdate TreeNodeState)]
| RenderedFocusUpdate [(LexemeId, SrcId)]
deriving (Generic)
data HighlightType =
HighlightGroup
| HighlightLeaf
| HighlightError
| HighlightBinder
| HighlightOcc
| HighlightScope
deriving (Show, Eq, Generic)
type RenderedHighlight = (SrcId, HighlightType)
data TreeNodeState = TreeNodeState
{ tnSpan :: (LexemeId, LexemeId)
, tnHighlights :: [RenderedHighlight]
, tnText :: String }
deriving (Show, Eq, Generic)
data TreeNodeUpdate = TreeNodeUpdate
{ tnuHighlights :: [RenderedHighlight]
, tnuText :: [String] }
deriving (Show, Eq, Generic)
instance Semigroup TreeNodeUpdate where
TreeNodeUpdate x y <> TreeNodeUpdate x' y' = TreeNodeUpdate (x<>x') (y<>y')
instance Monoid TreeNodeUpdate where
mempty = TreeNodeUpdate mempty mempty
instance IncState TreeNodeState where
type Delta TreeNodeState = TreeNodeUpdate
applyDiff (TreeNodeState s h t) (TreeNodeUpdate h' t') =
TreeNodeState s (h<>h') (t<>fold t')
renderOutput :: Output -> IO [RenderedOutput]
renderOutput = \case
TextOut s -> emit $ RenderedTextOut s
HtmlOut s -> emit $ RenderedHtmlOut s
SourceInfo s -> case s of
SIGroupingInfo info -> return $ renderGroupingInfo info
SINamingInfo info -> return $ renderNamingInfo info
SITypingInfo info -> return $ renderTypingInfo info
PassResult n s -> emit $ RenderedPassResult n s
MiscLog s -> emit $ RenderedMiscLog s
Error e -> emit $ RenderedError (getErrSrcId e) (pprint e)
where emit :: RenderedOutput -> IO [RenderedOutput]
emit x = return [x]
renderSourceBlock :: BlockId -> SourceBlock -> RenderedSourceBlock
renderSourceBlock n b = RenderedSourceBlock
{ rsbLine = sbLine b
, rsbNumLines = length $ lines $ T.unpack $ sbText b
, rsbBlockId = n
, rsbLexemeList = unsnoc $ lexemeList $ sbLexemeInfo b
, rsbText = T.unpack $ sbText b
, rsbHtml = renderHtml case sbContents b of
Misc (ProseBlock s) -> cdiv "prose-block" $ mdToHtml s
_ -> renderSpans n (sbLexemeInfo b) (sbText b)
}
renderGroupingInfo :: GroupingInfo -> RenderedOutputs
renderGroupingInfo (GroupingInfo m) =
[ RenderedFocusUpdate focus
, RenderedTreeNodeUpdate treeNodeUpdate]
where
treeNodeUpdate = M.toList m <&> \(sid, node) -> (sid, Create $ renderTreeNode m sid node)
focus = fold $ uncurry renderFocus <$> M.toList m
renderTreeNode :: M.Map SrcId GroupTreeNode -> SrcId -> GroupTreeNode -> TreeNodeState
renderTreeNode m sid node = TreeNodeState (gtnSpan node) (getHighlights m sid node) ""
getHighlights :: M.Map SrcId GroupTreeNode -> SrcId -> GroupTreeNode -> [RenderedHighlight]
getHighlights m sid node = case gtnChildren node of
[] -> [(sid, HighlightGroup)]
children -> children <&> \childSrcId -> do
let child = fromJust $ M.lookup childSrcId m
let highlight = case gtnIsAtomicLexeme child of
True -> HighlightLeaf
False -> HighlightGroup
(childSrcId, highlight)
renderFocus :: SrcId -> GroupTreeNode -> [(LexemeId, SrcId)]
renderFocus srcId node = case gtnChildren node of
[] -> case gtnIsAtomicLexeme node of
False -> [(srcId, srcId)]
True -> case gtnParent node of
Nothing -> [(srcId, srcId)]
Just parentId -> [(srcId, parentId)]
_ -> [] -- not a lexeme
renderNamingInfo :: NamingInfo -> RenderedOutputs
renderNamingInfo (NamingInfo m) = [RenderedTreeNodeUpdate treeNodeUpdate]
where treeNodeUpdate = fold $ M.toList m <&> \(sid, node) -> renderNameInfo sid node
renderNameInfo :: SrcId -> NameInfo -> [(SrcId, MapEltUpdate TreeNodeState)]
renderNameInfo sid = \case
LocalOcc binderSid -> do
let occUpdate = (sid, Update $ TreeNodeUpdate [(binderSid, HighlightBinder)] ["Local name"])
let binderUpdate = (binderSid, Update $ TreeNodeUpdate [(sid, HighlightOcc)] [])
[occUpdate, binderUpdate]
-- TODO: this path isn't exercised because we don't actually generate any
-- `LocalBinder` info in `SourceRename`
LocalBinder binderScope -> [(sid, Update $ TreeNodeUpdate (selfHighlight:scopeHighlights) mempty)]
where selfHighlight = (sid, HighlightBinder)
scopeHighlights = binderScope <&> \scopeSid -> (scopeSid, HighlightScope)
TopOcc s -> [(sid, Update $ TreeNodeUpdate [] [s])]
renderTypingInfo :: TypingInfo -> RenderedOutputs
renderTypingInfo (TypingInfo m) = [RenderedTreeNodeUpdate treeNodeUpdate]
where
treeNodeUpdate = M.toList m <&> \(sid, node) ->
(sid, Update $ renderTypeInfo node)
renderTypeInfo :: TypeInfo -> TreeNodeUpdate
renderTypeInfo = \case
ExprType s -> TreeNodeUpdate mempty ["Type: " <> s]
_ -> TreeNodeUpdate mempty mempty
instance ToJSON RenderedSourceBlock
instance ToJSON RenderedOutput
instance ToJSON TreeNodeState
instance ToJSON TreeNodeUpdate
instance ToJSON HighlightType
-- -----------------
renderStandaloneHTML :: FilePath -> RenderingUpdate -> IO ()
renderStandaloneHTML pagePath renderingInfo = do
let jsonPath = pagePath ++ ".json"
let htmlPath = pagePath ++ ".html"
BS.writeFile jsonPath $ toStrict $ encode renderingInfo
writeFile htmlPath $ renderHtml $ buildMainHtml jsonPath
buildMainHtml :: FilePath -> Html
buildMainHtml jsonPath = docTypeHtml $ do
H.head do
H.meta ! charset "UTF-8"
H.link ! rel "stylesheet" ! type_ "text/css" ! href "/static/style.css"
H.body ! onload (textValue $ fromString jsSource) $ do
H.div mempty ! At.id "minimap"
H.div "(hover over code for more information)" ! At.id "hover-info"
H.div mempty ! At.id "main-output"
H.script ! src "/static/index.js" $ mempty
where
jsSource :: String
jsSource = "render('Static', '/" ++ jsonPath ++ "');"
mdToHtml :: T.Text -> Html
mdToHtml s = preEscapedText $ commonmarkToHtml [] s
cdiv :: String -> Html -> Html
cdiv c inner = H.div inner ! class_ (stringValue c)
renderSpans :: BlockId -> LexemeInfo -> T.Text -> Markup
renderSpans blockId lexInfo sourceText = cdiv "code-block" do
runTextWalkerT sourceText do
forM_ (lexemeList lexInfo) \sourceId -> do
let (lexemeTy, (l, r)) = fromJust $ M.lookup sourceId (lexemeInfo lexInfo)
takeTo l >>= emitWhitespace
takeTo r >>= emitSpan (Just (blockId, sourceId)) (lexemeClass lexemeTy)
takeRest >>= emitSpan Nothing (Just "comment")
emitWhitespace :: T.Text -> TextWalker ()
emitWhitespace t
| t == "" = return ()
| blankText t = emitSpan Nothing Nothing t
| otherwise = emitSpan Nothing (Just "comment") t
blankText :: T.Text -> Bool
blankText t = all (==' ') $ T.unpack t
emitSpan :: Maybe (BlockId, SrcId) -> Maybe String -> T.Text -> TextWalker ()
emitSpan maybeSrcId className t = lift do
let classAttr = case className of
Nothing -> mempty
Just c -> class_ (stringValue c)
let idAttr = case maybeSrcId of
Nothing -> mempty
Just (bid, SrcId sid) -> At.id (fromString $ "span_" ++ show bid ++ "_"++ show sid)
H.span (toHtml t) ! classAttr ! idAttr
lexemeClass :: LexemeType -> Maybe String
lexemeClass = \case
Keyword -> Just "keyword"
Symbol -> Just "symbol"
TypeName -> Just "type-name"
LowerName -> Nothing
UpperName -> Nothing
LiteralLexeme -> Just "literal"
StringLiteralLexeme -> Nothing
MiscLexeme -> Nothing
type TextWalker a = StateT (Int, T.Text) MarkupM a
runTextWalkerT :: T.Text -> TextWalker a -> MarkupM a
runTextWalkerT t cont = evalStateT cont (0, t)
-- index is the *absolute* index, from the very beginning
takeTo :: Int -> TextWalker T.Text
takeTo startPos = do
(curPos, curText) <- get
let (prefix, remText) = T.splitAt (startPos- curPos) curText
put (startPos, remText)
return prefix
takeRest :: TextWalker T.Text
takeRest = do
(curPos, curText) <- get
put (curPos + T.length curText, mempty)
return curText
|