Skip to content

Commit 1e9d2f3

Browse files
evanczevancz
committed
create an Errors.elm set up for "Jump to Problem" for /try
1 parent 5ab4b87 commit 1e9d2f3

File tree

3 files changed

+247
-4
lines changed

3 files changed

+247
-4
lines changed

‎worker/elm.json‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
{
2+
"type": "application",
3+
"source-directories": [
4+
"src"
5+
],
6+
"elm-version": "0.19.1",
7+
"dependencies": {
8+
"direct": {
9+
"elm/browser": "1.0.1",
10+
"elm/core": "1.0.2",
11+
"elm/html": "1.0.0",
12+
"elm/json": "1.1.3",
13+
"elm/project-metadata-utils": "1.0.0"
14+
},
15+
"indirect": {
16+
"elm/parser": "1.1.0",
17+
"elm/time": "1.0.0",
18+
"elm/url": "1.0.0",
19+
"elm/virtual-dom": "1.0.2"
20+
}
21+
},
22+
"test-dependencies": {
23+
"direct": {},
24+
"indirect": {}
25+
}
26+
}

‎worker/src/Endpoint/Compile.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -218,11 +218,11 @@ loadErrorJS =
218218
do result <- work
219219
case result of
220220
Right a -> return a
221-
Left _ -> error "problem building reactor/src/Errors.elm"
221+
Left _ -> error "problem building src/Errors.elm"
222222
in
223-
Dir.withCurrentDirectory "../reactor" $ BW.withScope $ \scope ->
224-
do let root = "."
223+
BW.withScope $ \scope ->
224+
do root <- Dir.getCurrentDirectory
225225
details <- run $ Details.load Reporting.silent scope root
226-
artifacts <- run $ Build.fromMains Reporting.silent root details (NE.List "src/Errors.elm" [])
226+
artifacts <- run $ Build.fromPaths Reporting.silent root details (NE.List "src/Errors.elm" [])
227227
javascript <- run $ Task.run $ Generate.prod root details artifacts
228228
return $ LBS.toStrict $ B.toLazyByteString javascript

‎worker/src/Errors.elm‎

Lines changed: 217 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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)"

0 commit comments

Comments
 (0)