1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Render.Code
4  ( Source
5  , toSource
6  , toSnippet
7  , toPair
8  , Next(..)
9  , whatIsNext
10  , nextLineStartsWithKeyword
11  , nextLineStartsWithCloseCurly
12  )
13  where
14
15
16import qualified Data.ByteString as B
17import qualified Data.ByteString.UTF8 as UTF8_BS
18import qualified Data.Char as Char
19import qualified Data.IntSet as IntSet
20import qualified Data.List as List
21import qualified Data.Name as Name
22import qualified Data.Set as Set
23import Data.Word (Word16)
24
25import qualified Reporting.Annotation as A
26import qualified Reporting.Doc as D
27import Reporting.Doc (Doc)
28import Parse.Primitives (Row, Col)
29import Parse.Symbol (binopCharSet)
30import Parse.Variable (reservedWords)
31
32
33
34-- CODE
35
36
37newtype Source =
38  Source [(Word16, String)]
39
40
41toSource :: B.ByteString -> Source
42toSource source =
43  Source $ zip [1..] $
44    lines (UTF8_BS.toString source) ++ [""]
45
46
47
48-- CODE FORMATTING
49
50
51toSnippet :: Source -> A.Region -> Maybe A.Region -> (D.Doc, D.Doc) -> D.Doc
52toSnippet source region highlight (preHint, postHint) =
53  D.vcat
54    [ preHint
55    , ""
56    , render source region highlight
57    , postHint
58    ]
59
60
61toPair :: Source -> A.Region -> A.Region -> (D.Doc, D.Doc) -> (D.Doc, D.Doc, D.Doc) -> D.Doc
62toPair source r1 r2 (oneStart, oneEnd) (twoStart, twoMiddle, twoEnd) =
63  case renderPair source r1 r2 of
64    OneLine codeDocs ->
65      D.vcat
66        [ oneStart
67        , ""
68        , codeDocs
69        , oneEnd
70        ]
71
72    TwoChunks code1 code2 ->
73      D.vcat
74        [ twoStart
75        , ""
76        , code1
77        , twoMiddle
78        , ""
79        , code2
80        , twoEnd
81        ]
82
83
84
85-- RENDER SNIPPET
86
87
88(|>) :: a -> (a -> b) -> b
89(|>) a f =
90  f a
91
92
93render :: Source -> A.Region -> Maybe A.Region -> Doc
94render (Source sourceLines) region@(A.Region (A.Position startLine _) (A.Position endLine _)) maybeSubRegion =
95  let
96    relevantLines =
97      sourceLines
98        |> drop (fromIntegral (startLine - 1))
99        |> take (fromIntegral (1 + endLine - startLine))
100
101    width =
102      length (show (fst (last relevantLines)))
103
104    smallerRegion =
105      maybe region id maybeSubRegion
106  in
107    case makeUnderline width endLine smallerRegion of
108      Nothing ->
109        drawLines True width smallerRegion relevantLines D.empty
110
111      Just underline ->
112        drawLines False width smallerRegion relevantLines underline
113
114
115makeUnderline :: Int -> Word16 -> A.Region -> Maybe Doc
116makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end c2)) =
117  if start /= end || end < realEndLine then
118    Nothing
119
120  else
121    let
122      spaces = replicate (fromIntegral c1 + width + 1) ' '
123      zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^'
124    in
125      Just (D.fromChars spaces <> D.red (D.fromChars zigzag))
126
127
128drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc
129drawLines addZigZag width (A.Region (A.Position startLine _) (A.Position endLine _)) sourceLines finalLine =
130  D.vcat $
131    map (drawLine addZigZag width startLine endLine) sourceLines
132    ++ [finalLine]
133
134
135drawLine :: Bool -> Int -> Word16 -> Word16 -> (Word16, String) -> Doc
136drawLine addZigZag width startLine endLine (n, line) =
137  addLineNumber addZigZag width startLine endLine n (D.fromChars line)
138
139
140addLineNumber :: Bool -> Int -> Word16 -> Word16 -> Word16 -> Doc -> Doc
141addLineNumber addZigZag width start end n line =
142  let
143    number =
144      show n
145
146    lineNumber =
147      replicate (width - length number) ' ' ++ number ++ "|"
148
149    spacer =
150      if addZigZag && start <= n && n <= end then
151        D.red ">"
152      else
153        " "
154  in
155    D.fromChars lineNumber <> spacer <> line
156
157
158
159-- RENDER PAIR
160
161
162data CodePair
163  = OneLine Doc
164  | TwoChunks Doc Doc
165
166
167renderPair :: Source -> A.Region -> A.Region -> CodePair
168renderPair source@(Source sourceLines) region1 region2 =
169  let
170    (A.Region (A.Position startRow1 startCol1) (A.Position endRow1 endCol1)) = region1
171    (A.Region (A.Position startRow2 startCol2) (A.Position endRow2 endCol2)) = region2
172  in
173  if startRow1 == endRow1 && endRow1 == startRow2 && startRow2 == endRow2 then
174    let
175      lineNumber = show startRow1
176      spaces1 = replicate (fromIntegral startCol1 + length lineNumber + 1) ' '
177      zigzag1 = replicate (fromIntegral (endCol1 - startCol1)) '^'
178      spaces2 = replicate (fromIntegral (startCol2 - endCol1)) ' '
179      zigzag2 = replicate (fromIntegral (endCol2 - startCol2)) '^'
180
181      (Just line) = List.lookup startRow1 sourceLines
182    in
183    OneLine $
184      D.vcat
185        [ D.fromChars lineNumber <> "| " <> D.fromChars line
186        , D.fromChars spaces1 <> D.red (D.fromChars zigzag1) <>
187          D.fromChars spaces2 <> D.red (D.fromChars zigzag2)
188        ]
189
190  else
191    TwoChunks
192      (render source region1 Nothing)
193      (render source region2 Nothing)
194
195
196
197-- WHAT IS NEXT?
198
199
200data Next
201  = Keyword [Char]
202  | Operator [Char]
203  | Close [Char] Char
204  | Upper Char [Char]
205  | Lower Char [Char]
206  | Other (Maybe Char)
207
208
209whatIsNext :: Source -> Row -> Col -> Next
210whatIsNext (Source sourceLines) row col =
211  case List.lookup row sourceLines of
212    Nothing ->
213      Other Nothing
214
215    Just line ->
216      case drop (fromIntegral col - 1) line of
217        [] ->
218          Other Nothing
219
220        c:cs
221          | Char.isUpper c -> Upper c (takeWhile isInner cs)
222          | Char.isLower c -> detectKeywords c cs
223          | isSymbol c     -> Operator (c : takeWhile isSymbol cs)
224          | c == ')'       -> Close "parenthesis" ')'
225          | c == ']'       -> Close "square bracket" ']'
226          | c == '}'       -> Close "curly brace" '}'
227          | otherwise      -> Other (Just c)
228
229
230detectKeywords :: Char -> [Char] -> Next
231detectKeywords c rest =
232  let
233    cs = takeWhile isInner rest
234    name = c : cs
235  in
236  if Set.member (Name.fromChars name) reservedWords
237  then Keyword name
238  else Lower c name
239
240
241isInner :: Char -> Bool
242isInner char =
243  Char.isAlphaNum char || char == '_'
244
245
246isSymbol :: Char -> Bool
247isSymbol char =
248  IntSet.member (Char.ord char) binopCharSet
249
250
251startsWithKeyword :: [Char] -> [Char] -> Bool
252startsWithKeyword restOfLine keyword =
253  List.isPrefixOf keyword restOfLine
254  &&
255  case drop (length keyword) restOfLine of
256    [] ->
257      True
258
259    c:_ ->
260      not (isInner c)
261
262
263nextLineStartsWithKeyword :: [Char] -> Source -> Row -> Maybe (Row, Col)
264nextLineStartsWithKeyword keyword (Source sourceLines) row =
265  case List.lookup (row + 1) sourceLines of
266    Nothing ->
267      Nothing
268
269    Just line ->
270      if startsWithKeyword (dropWhile (==' ') line) keyword then
271        Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line)))
272      else
273        Nothing
274
275
276nextLineStartsWithCloseCurly :: Source -> Row -> Maybe (Row, Col)
277nextLineStartsWithCloseCurly (Source sourceLines) row =
278  case List.lookup (row + 1) sourceLines of
279    Nothing ->
280      Nothing
281
282    Just line ->
283      case dropWhile (==' ') line of
284        '}':_ ->
285          Just (row + 1, 1 + fromIntegral (length (takeWhile (==' ') line)))
286
287        _ ->
288          Nothing
289