never executed always true always false
1 module ElmFormat.Render.Markdown where
2
3 import Cheapskate.Types
4 import qualified Data.Char as Char
5 import Data.Foldable (fold, toList)
6 import qualified Data.List as List
7 import Data.Maybe (fromMaybe)
8 import qualified Data.Text as Text
9 import Data.Text (Text)
10 import Data.Text.Extra (longestSpanOf, LongestSpanResult(..))
11 import Elm.Utils ((|>))
12 import qualified Regex
13
14
15 formatMarkdown :: (String -> Maybe String) -> Blocks -> String
16 formatMarkdown formatCode blocks =
17 let
18 blocks' =
19 toList blocks
20
21 needsInitialBlanks =
22 case blocks' of
23 (Para inlines : _ ) ->
24 case toList inlines of
25 (Str a : Str b : _) ->
26 if (a == Text.pack "@") && (b == Text.pack "docs")
27 then True
28 else False
29 _ -> False
30 [] -> False
31 _ -> True
32
33 needsTrailingBlanks =
34 case blocks' of
35 [] -> False
36 (_ : []) -> needsInitialBlanks
37 _ -> True
38 in
39 formatMarkdown' formatCode False needsInitialBlanks needsTrailingBlanks blocks'
40
41
42 mapWithPrev :: (Maybe a -> a -> b) -> [a] -> [b]
43 mapWithPrev _ [] = []
44 mapWithPrev f (first:rest) =
45 f Nothing first : zipWith (\prev next -> f (Just prev) next) (first:rest) rest
46
47
48 formatMarkdown' :: (String -> Maybe String) -> Bool -> Bool -> Bool -> [Block] -> String
49 formatMarkdown' formatCode isListItem needsInitialBlanks needsTrailingBlanks blocks =
50 let
51 intersperse =
52 case (isListItem, blocks) of
53 (True, [Para _, List _ _ _]) -> id
54 _ -> List.intersperse "\n"
55
56 contextFor prev =
57 case prev of
58 Just (List _ _ _) -> AfterIndentedList
59 _ -> Normal
60 in
61 (if needsInitialBlanks then "\n\n" else "")
62 ++ (fold $ intersperse $ mapWithPrev (\prev -> formatMardownBlock formatCode (contextFor prev)) $ blocks)
63 ++ (if needsTrailingBlanks then "\n" else "")
64
65
66 data Context
67 = Normal
68 | AfterIndentedList
69
70
71 formatMardownBlock :: (String -> Maybe String) -> Context -> Block -> String
72 formatMardownBlock formatCode context block =
73 case block of
74 ElmDocs terms ->
75 (List.intercalate "\n" $ fmap ((++) "@docs " . List.intercalate ", " . fmap Text.unpack) terms) ++ "\n"
76
77 Para inlines ->
78 (fold $ fmap (formatMarkdownInline True) $ inlines) ++ "\n"
79
80 Header level inlines ->
81 "\n" ++ replicate level '#' ++ " " ++ (fold $ fmap (formatMarkdownInline True) $ inlines) ++ "\n"
82
83 Blockquote blocks ->
84 formatMarkdown' formatCode False False False (toList blocks)
85 |> prefix' "> " "> "
86
87 List tight (Bullet _) items ->
88 fold $ (if tight then id else List.intersperse "\n") $
89 fmap (prefix' " - " " " . formatMarkdown' formatCode True False False . toList) items
90 List tight (Numbered _ _) items ->
91 fold $ (if tight then id else List.intersperse "\n") $
92 fmap (formatListItem formatCode) $ zip [1..] items
93
94 CodeBlock (CodeAttr lang _info) code ->
95 let
96 isElm =
97 lang' == "elm" || lang' == ""
98
99 formatted =
100 fromMaybe (Text.unpack $ ensureNewline code) $
101 if isElm
102 then formatCode $ Text.unpack code
103 else Nothing
104
105 ensureNewline text =
106 if Text.last text == '\n'
107 then text
108 else Text.snoc text '\n'
109
110 lang' =
111 Text.unpack lang
112
113 canIndent =
114 case context of
115 Normal -> True
116 AfterIndentedList -> False
117 in
118 if isElm && canIndent
119 then unlines $ fmap ((++) " ") $ lines $ formatted
120 else "```" ++ Text.unpack lang ++ "\n" ++ formatted ++ "```\n"
121
122 HtmlBlock text ->
123 Text.unpack text ++ "\n"
124
125 HRule ->
126 "---\n"
127
128 ReferencesBlock refs ->
129 fold $ fmap formatRef refs
130
131
132 formatListItem :: (String -> Maybe String) -> (Int, Blocks) -> String
133 formatListItem formatCode (i, item)=
134 let
135 pref =
136 if i < 10
137 then show i ++ ". "
138 else show i ++ ". "
139 in
140 prefix' pref " " $ formatMarkdown' formatCode True False False (toList item)
141
142
143 formatRef :: (Text, Text, Text) -> String
144 formatRef (label, url, title) =
145 "[" ++ Text.unpack label ++ "]: " ++ Text.unpack url
146 ++ (if Text.unpack title == "" then "" else " \"" ++ Text.unpack title ++ "\"")
147 ++ "\n"
148
149
150 prefix' :: String -> String -> String -> String
151 prefix' preFirst preRest =
152 unlines . prefix preFirst preRest . lines
153
154
155 prefix :: [a] -> [a] -> [[a]] -> [[a]]
156 prefix _ _ [] = []
157 prefix preFirst preRest (first:rest) =
158 (preFirst ++ first) : fmap ((++) preRest) rest
159
160
161 formatMarkdownInline :: Bool -> Inline -> String
162 formatMarkdownInline fixSpecialChars inline =
163 case inline of
164 Str text ->
165 Text.unpack $ (if fixSpecialChars then Text.concatMap fix else id) text
166 Space ->
167 " "
168 SoftBreak ->
169 "\n"
170 LineBreak ->
171 "\n"
172 Emph inlines ->
173 "_" ++ (fold $ fmap (formatMarkdownInline True) $ inlines) ++ "_" -- TODO: escaping
174 Strong inlines ->
175 "**" ++ (fold $ fmap (formatMarkdownInline True) $ inlines) ++ "**" -- TODO: escaping
176 Code text ->
177 case longestSpanOf '`' text of
178 NoSpan -> "`" ++ Text.unpack text ++ "`"
179 Span n ->
180 let
181 delimiter = replicate (n + 1) '`'
182 in
183 delimiter ++ " " ++ Text.unpack text ++ " " ++ delimiter
184
185 Link inlines (Url url) title ->
186 let
187 text = fold $ fmap (formatMarkdownInline fixSpecialChars) $ inlines
188 textRaw = fold $ fmap (formatMarkdownInline False) $ inlines
189
190 title' = Text.unpack title
191 url' = Text.unpack url
192
193 isValidAutolink =
194 Regex.match absoluteUrlRegex
195 in
196 if textRaw == url' && title' == "" && isValidAutolink url'
197 then
198 if fixSpecialChars
199 then "<" ++ url' ++ ">"
200 else url'
201 else
202 "[" ++ text
203 ++ "](" ++ Text.unpack url
204 ++ (if title' == "" then "" else " \"" ++ title' ++ "\"")
205 ++ ")"
206
207 Link inlines (Ref ref) _ ->
208 let
209 text = fold $ fmap (formatMarkdownInline fixSpecialChars) $ inlines
210
211 ref' = Text.unpack ref
212 in
213 if text == ref' || ref' == ""
214 then "[" ++ text ++ "]"
215 else "[" ++ text ++ "][" ++ ref' ++ "]"
216
217 Image inlines url title ->
218 "![" ++ (fold $ fmap (formatMarkdownInline fixSpecialChars) $ inlines)
219 ++ "](" ++ Text.unpack url
220 ++ (if Text.unpack title == "" then "" else " \"" ++ Text.unpack title ++ "\"")
221 ++ ")"
222
223 Entity text ->
224 Text.unpack text
225 RawHtml text ->
226 Text.unpack text
227 where
228 fix c =
229 case c of
230 '\\' -> Text.pack "\\\\"
231 -- TODO: only at the beginning of words
232 '`' -> Text.pack "\\`"
233 '_' -> Text.pack "\\_"
234 '*' -> Text.pack "\\*"
235 -- TODO: {} curly braces (when?)
236 -- TODO: [] square brackets (when?)
237 -- TODO: () parentheses (when?)
238 -- TODO: # hash mark (only at the beginning of lines, and within header lines?)
239 -- TODO: - minus sign (hyphen) (only at the beginning of lines?)
240 -- TODO: + plus sign (when?)
241 -- TODO: . dot (when?)
242 -- TODO: ! exclamation mark (when?)
243 _ -> Text.singleton c
244
245
246 {-| As defined at https://spec.commonmark.org/0.29/#autolinks -}
247 absoluteUrlRegex :: Regex.Regex Char
248 absoluteUrlRegex =
249 schemeInitial * Regex.plus schemeSubsequent * Regex.once ':' * Regex.star urlSafe
250 where
251 schemeInitial = Regex.satisfy isSchemeInitial
252 schemeSubsequent = Regex.satisfy isSchemeSubsequent
253 urlSafe = Regex.satisfy isUrlSafe
254
255 isSchemeInitial c =
256 isAsciiUpper c || isAsciiLower c
257
258 isSchemeSubsequent c =
259 isAsciiUpper c || isAsciiLower c || isAsciiDigit c || c == '+' || c == '.' || c == '-'
260
261 isUrlSafe c =
262 not (Char.isSpace c && c == '<' && c == '>')
263
264 isAsciiUpper c =
265 c >= 'A' && c <= 'Z'
266
267 isAsciiLower c =
268 c >= 'a' && c <= 'z'
269
270 isAsciiDigit c =
271 c >= '0' && c <= '9'