@@ -7,16 +7,16 @@ import Html exposing (..)
77import Html.Attributes exposing (..)
88import String
99import Json.Decode as D
10+import Elm.Error as Error
1011
1112
1213
1314-- MAIN
1415
1516
16−main : Program D.Value Model ()
1717main =
1818 Browser.fullscreen
19− { init = \env -> (D.decodeValue decodeExit env.flags, Cmd.none)
19+ { init = \env -> (D.decodeValue Error.decoder env.flags, Cmd.none)
2020 , update = \_ exit -> (exit, Cmd.none)
2121 , view = view
2222 , subscriptions = \_ -> Sub.none
@@ -25,26 +25,10 @@ main =
2525
2626
2727
28−-- MODEL
29−
30−
31−type alias Model =
32− Result D.Error Exit
33−
34−
35−type alias Exit = ()
36−
37−
38−decodeExit : D.Decoder Exit
39−decodeExit =
40− D.null ()
41−
42−
43−
4428-- VIEW
4529
4630
47−view : Model -> Browser.View msg
31+view : Result D.Error Error.Error -> Browser.View msg
4832view result =
4933 { title = "Problem!"
5034 , body =
@@ -52,13 +36,13 @@ view result =
5236 Err err ->
5337 [ text (D.errorToString err) ]
5438
55− Ok exit ->
56− [ viewExit exit ]
39+ Ok error ->
40+ [ viewError error ]
5741 }
5842
5943
60−viewExit : Exit -> Html msg
61−viewExit exit =
44+viewError : Error.Error -> Html msg
45+viewError error =
6246 div
6347 [ style "width" "100%"
6448 , style "min-height" "100%"
@@ -71,10 +55,114 @@ viewExit exit =
7155 ]
7256 [ div
7357 [ style "display" "block"
74− , style "white-space" "pre"
58+ , style "white-space" "pre-wrap"
7559 , style "background-color" "rgb(39, 40, 34)"
7660 , style "padding" "2em"
7761 ]
78− [ text "TODO"
79− ]
62+ (viewErrorHelp error)
8063 ]
64+
65+
66+viewErrorHelp : Error.Error -> List (Html msg)
67+viewErrorHelp error =
68+ case error of
69+ Error.GeneralProblem { path, title, message } ->
70+ [ text title ]
71+
72+ Error.ModuleProblems badModules ->
73+ List.map viewBadModule badModules
74+
75+
76+viewBadModule : Error.BadModule -> Html msg
77+viewBadModule { path, name, problems } =
78+ span [] (List.map (viewProblem path) problems)
79+
80+
81+viewProblem : String -> Error.Problem -> Html msg
82+viewProblem filePath problem =
83+ let
84+ leftover =
85+ 76 - String.length problem.title
86+
87+ header =
88+ "-- " ++ problem.title ++ " " ++ String.padLeft leftover '-' (" " ++ filePath) ++ "\n\n"
89+ in
90+ span []
91+ ( span [ style "color" "cyan" ] [ text header ]
92+ :: viewMessage problem.message
93+ )
94+
95+
96+
97+-- VIEW MESSAGE
98+
99+
100+viewMessage : List Error.Chunk -> List (Html msg)
101+viewMessage chunks =
102+ case chunks of
103+ [] ->
104+ []
105+
106+ chunk :: others ->
107+ let
108+ htmlChunk =
109+ case chunk of
110+ Error.Unstyled string ->
111+ text string
112+
113+ Error.Styled style string ->
114+ span (styleToAttrs style) [ text string ]
115+ in
116+ htmlChunk :: viewMessage others
117+
118+
119+styleToAttrs : Error.Style -> List (Attribute msg)
120+styleToAttrs { bold, underline, color } =
121+ addBold bold <| addUnderline underline <| addColor color []
122+
123+
124+addBold : Bool -> List (Attribute msg) -> List (Attribute msg)
125+addBold bool attrs =
126+ if bool then
127+ style "font-weight" "bold" :: attrs
128+ else
129+ attrs
130+
131+
132+addUnderline : Bool -> List (Attribute msg) -> List (Attribute msg)
133+addUnderline bool attrs =
134+ if bool then
135+ style "text-decoration" "underline" :: attrs
136+ else
137+ attrs
138+
139+
140+addColor : Maybe Error.Color -> List (Attribute msg) -> List (Attribute msg)
141+addColor maybeColor attrs =
142+ case maybeColor of
143+ Nothing ->
144+ attrs
145+
146+ Just color ->
147+ style "color" (colorToCss color) :: attrs
148+
149+
150+colorToCss : Error.Color -> String
151+colorToCss color =
152+ case color of
153+ Error.Red -> "red"
154+ Error.RED -> "red"
155+ Error.Magenta -> "magenta"
156+ Error.MAGENTA -> "magenta"
157+ Error.Yellow -> "yellow"
158+ Error.YELLOW -> "yellow"
159+ Error.Green -> "green"
160+ Error.GREEN -> "green"
161+ Error.Cyan -> "cyan"
162+ Error.CYAN -> "cyan"
163+ Error.Blue -> "blue"
164+ Error.BLUE -> "blue"
165+ Error.White -> "white"
166+ Error.WHITE -> "white"
167+ Error.Black -> "black"
168+ Error.BLACK -> "black"