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
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | Prepare a complete HTML export from retained parsed presentation.
module Render.Html.Export
( HtmlPresentation
, htmlPresentationFromParsedWorkspace
, HtmlExportError(..)
, renderHtmlExportError
, prepareHtmlExport
) where
import Base
import Felix.Parse
import Felix.Source
import Render.Html qualified as Html
import Render.Html.Context
import Render.Html.Layout
import Render.Html.Output
import Syntax.Abstract (Block)
import Control.Exception (Exception)
import Data.Bifunctor (first)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as Text
import Data.Text.Encoding qualified as TextEncoding
-- | The strict, invocation-local subset of parsed presentation needed by the
-- renderer. Construction forces the complete module sequence and every page
-- shell, severing references to parser payloads, syntax interfaces, and
-- canonical cache payloads.
data HtmlPresentation = HtmlPresentation
!(NonEmpty HtmlSourcePresentation)
data HtmlSourcePresentation = HtmlSourcePresentation
!ResolvedSource
![Block]
htmlPresentationFromParsedWorkspace
:: ParsedSourceWorkspace
-> HtmlPresentation
htmlPresentationFromParsedWorkspace workspace =
HtmlPresentation
(strictMapNonEmpty project parsedModules)
where
parsedModules =
parsedWorkspaceImportedBeforeImporter workspace
project parsedModule =
HtmlSourcePresentation
(parsedModuleResolved parsedModule)
(parsedModuleBlocks parsedModule)
strictMapNonEmpty :: (a -> b) -> NonEmpty a -> NonEmpty b
strictMapNonEmpty f (value :| values) =
let !firstPage = f value
!rest = strictMapList f values
in firstPage :| rest
strictMapList :: (a -> b) -> [a] -> [b]
strictMapList _ [] =
[]
strictMapList f (value : values) =
let !next = f value
!rest = strictMapList f values
in next : rest
data HtmlExportError
= HtmlRendererDataNotFound !FilePath ![FilePath]
| HtmlRendererDataLookupFailed !FilePath !Text
| HtmlRendererDataReadFailed !FilePath !Text
| HtmlExportLayoutError !HtmlLayoutError
| HtmlExportContextError !HtmlRenderContextError
deriving stock (Show)
instance Exception HtmlExportError
renderHtmlExportError :: HtmlExportError -> Text
renderHtmlExportError = \case
HtmlRendererDataNotFound requested searched ->
"renderer data " <> quotePath requested <> " was not found; searched "
<> Text.intercalate ", " (quotePath <$> searched)
HtmlRendererDataLookupFailed path reason ->
"could not locate renderer data " <> quotePath path <> ": " <> reason
HtmlRendererDataReadFailed path reason ->
"could not read renderer data " <> quotePath path <> ": " <> reason
HtmlExportLayoutError failure ->
renderHtmlLayoutError failure
HtmlExportContextError failure ->
case failure of
HtmlCurrentSourceNotRouted source ->
"current source has no HTML route: " <> sourceLabel source
HtmlReferencedSourceNotRouted source ->
"referenced source has no HTML route: " <> sourceLabel source
where
sourceLabel source =
sourceMountIdText (resolvedSourceMount source)
<> ":"
<> Text.pack
(safeRelativePathFilePath
(resolvedSourceRelativePath source))
quotePath = Text.pack . show
prepareHtmlExport
:: [(SourceMountId, [Text])]
-> HtmlPresentation
-> Text
-> Either HtmlExportError [PreparedHtmlArtifact]
prepareHtmlExport
mountPrefixes
(HtmlPresentation presentation)
hints = do
let sources =
sourceOf <$> NonEmpty.toList presentation
layout <-
first
HtmlExportLayoutError
(layoutHtmlSources mountPrefixes sources)
prepareRenderedExport hints layout presentation
where
sourceOf (HtmlSourcePresentation source _blocks) =
source
prepareRenderedExport
:: Text
-> HtmlLayout
-> NonEmpty HtmlSourcePresentation
-> Either HtmlExportError [PreparedHtmlArtifact]
prepareRenderedExport hints layout presentation = do
let sourceBlocks =
(\(HtmlSourcePresentation source blocks) ->
(source, blocks))
<$> presentation
(unforcedRenderIndex, pages) =
Html.buildRenderIndex sourceBlocks
!renderIndex = unforcedRenderIndex
renderEnvironment =
htmlRenderEnvironment layout
pageArtifacts <-
traverse
(prepareSourceArtifact
renderEnvironment
layout
hints
renderIndex)
pages
let supportRoute =
htmlSupportScriptRoute layout
supportArtifact =
preparedHtmlArtifact
(routeDestination supportRoute)
(Right
(TextEncoding.encodeUtf8
Html.supportScriptAssetContents))
-- Page artifacts retain imported-before-importer source order. The
-- singleton support asset is published deterministically afterward.
Right (NonEmpty.toList pageArtifacts <> [supportArtifact])
prepareSourceArtifact
:: HtmlRenderEnvironment
-> HtmlLayout
-> Text
-> Html.HtmlRenderIndex
-> Html.HtmlPagePresentation
-> Either
HtmlExportError
PreparedHtmlArtifact
prepareSourceArtifact renderEnvironment layout hints renderIndex page = do
let source = Html.htmlPagePresentationSource page
context <-
first
HtmlExportContextError
(htmlRenderContextFromEnvironment
renderEnvironment
source)
route <-
maybe
(Left
(HtmlExportContextError
(HtmlCurrentSourceNotRouted source)))
Right
(htmlPageRoute layout source)
Right
(preparedHtmlArtifact
(routeDestination route)
(first renderHtmlExportError
(TextEncoding.encodeUtf8
<$> first
HtmlExportContextError
(Html.renderDocument
context
hints
renderIndex
page))))
|
