@@ -0,0 +1,217 @@
1+port module Errors exposing (main)
2+
3+
4+import Browser
5+import Char
6+import Html exposing (..)
7+import Html.Attributes exposing (..)
8+import Html.Events exposing (onClick)
9+import String
10+import Json.Decode as D
11+import Elm.Error as Error
12+
13+
14+
15+-- PORTS
16+
17+
18+port jumpTo : Error.Region -> Cmd msg
19+
20+
21+
22+-- MAIN
23+
24+
25+main =
26+ Browser.document
27+ { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none)
28+ , update = \region result -> (result, jumpTo region)
29+ , view = view
30+ , subscriptions = \_ -> Sub.none
31+ }
32+
33+
34+type alias Msg = Error.Region
35+
36+
37+
38+-- VIEW
39+
40+
41+view : Result D.Error Error.Error -> Browser.Document Msg
42+view result =
43+ { title = "Problem!"
44+ , body =
45+ case result of
46+ Err err ->
47+ [ text (D.errorToString err) ]
48+
49+ Ok error ->
50+ [ viewError error ]
51+ }
52+
53+
54+viewError : Error.Error -> Html Msg
55+viewError error =
56+ div
57+ [ style "width" "calc(100% - 4em)"
58+ , style "min-height" "calc(100% - 4em)"
59+ , style "font-family" "monospace"
60+ , style "white-space" "pre-wrap"
61+ , style "background-color" "black"
62+ , style "color" "rgb(233,235,235)"
63+ , style "padding" "2em"
64+ ]
65+ (viewErrorHelp error)
66+
67+
68+viewErrorHelp : Error.Error -> List (Html Msg)
69+viewErrorHelp error =
70+ case error of
71+ Error.GeneralProblem { title, message } ->
72+ viewHeader title Nothing :: viewMessage message
73+
74+ Error.ModuleProblems badModules ->
75+ viewBadModules badModules
76+
77+
78+
79+-- VIEW HEADER
80+
81+
82+viewHeader : String -> Maybe Error.Region -> Html Msg
83+viewHeader title maybeRegion =
84+ case maybeRegion of
85+ Nothing ->
86+ span [ style "color" "rgb(51,187,200)" ]
87+ [ text <| "-- " ++ title ++ " "
88+ , text <| String.repeat (76 - String.length title) "-"
89+ , text <| "\n\n"
90+ ]
91+
92+ Just region ->
93+ span [ style "color" "rgb(51,187,200)" ]
94+ [ text <| "-- " ++ title ++ " "
95+ , text <| String.repeat (60 - String.length title) "-"
96+ , text " "
97+ , span
98+ [ style "cursor" "pointer"
99+ , style "text-decoration" "underline"
100+ , onClick region
101+ ]
102+ [ text "Jump To Problem"
103+ ]
104+ , text <| "\n\n"
105+ ]
106+
107+
108+
109+-- VIEW BAD MODULES
110+
111+
112+viewBadModules : List Error.BadModule -> List (Html Msg)
113+viewBadModules badModules =
114+ case badModules of
115+ [] ->
116+ []
117+
118+ [badModule] ->
119+ [viewBadModule badModule]
120+
121+ a :: b :: cs ->
122+ viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs)
123+
124+
125+viewBadModule : Error.BadModule -> Html Msg
126+viewBadModule { problems } =
127+ span [] (List.map viewProblem problems)
128+
129+
130+viewProblem : Error.Problem -> Html Msg
131+viewProblem problem =
132+ span [] (viewHeader problem.title (Just problem.region) :: viewMessage problem.message)
133+
134+
135+viewSeparator : String -> String -> Html msg
136+viewSeparator before after =
137+ span [ style "color" "rgb(211,56,211)" ]
138+ [ text <|
139+ String.padLeft 80 ' ' (before ++ " ↑ ") ++ "\n" ++
140+ "====o======================================================================o====\n" ++
141+ " ↓ " ++ after ++ "\n\n\n"
142+ ]
143+
144+
145+
146+-- VIEW MESSAGE
147+
148+
149+viewMessage : List Error.Chunk -> List (Html msg)
150+viewMessage chunks =
151+ case chunks of
152+ [] ->
153+ [ text "\n\n\n" ]
154+
155+ chunk :: others ->
156+ let
157+ htmlChunk =
158+ case chunk of
159+ Error.Unstyled string ->
160+ text string
161+
162+ Error.Styled style string ->
163+ span (styleToAttrs style) [ text string ]
164+ in
165+ htmlChunk :: viewMessage others
166+
167+
168+styleToAttrs : Error.Style -> List (Attribute msg)
169+styleToAttrs { bold, underline, color } =
170+ addBold bold <| addUnderline underline <| addColor color []
171+
172+
173+addBold : Bool -> List (Attribute msg) -> List (Attribute msg)
174+addBold bool attrs =
175+ if bool then
176+ style "font-weight" "bold" :: attrs
177+ else
178+ attrs
179+
180+
181+addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg)
182+addUnderline bool attrs =
183+ if bool then
184+ style "text-decoration" "underline" :: attrs
185+ else
186+ attrs
187+
188+
189+addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg)
190+addColor maybeColor attrs =
191+ case maybeColor of
192+ Nothing ->
193+ attrs
194+
195+ Just color ->
196+ style "color" (colorToCss color) :: attrs
197+
198+
199+colorToCss : Error.Color -> String
200+colorToCss color =
201+ case color of
202+ Error.Red -> "rgb(194,54,33)"
203+ Error.RED -> "rgb(252,57,31)"
204+ Error.Magenta -> "rgb(211,56,211)"
205+ Error.MAGENTA -> "rgb(249,53,248)"
206+ Error.Yellow -> "rgb(173,173,39)"
207+ Error.YELLOW -> "rgb(234,236,35)"
208+ Error.Green -> "rgb(37,188,36)"
209+ Error.GREEN -> "rgb(49,231,34)"
210+ Error.Cyan -> "rgb(51,187,200)"
211+ Error.CYAN -> "rgb(20,240,240)"
212+ Error.Blue -> "rgb(73,46,225)"
213+ Error.BLUE -> "rgb(88,51,255)"
214+ Error.White -> "rgb(203,204,205)"
215+ Error.WHITE -> "rgb(233,235,235)"
216+ Error.Black -> "rgb(0,0,0)"
217+ Error.BLACK -> "rgb(129,131,131)"