@@ -53,9 +53,10 @@ import qualified Reporting.Render.Code as Code
5353main :: IO ()
5454main =
5555 do artifacts <- loadArtifacts
56+ errorHtml <- compileErrorViewer artifacts
5657 httpServe config $ msum $
5758 [ path "compile" $ compile artifacts
58− , path "compile/error.js" $ serveFile "error.js"
59+ , path "compile/error.js" $ writeBS errorHtml
5960 , notFound
6061 ]
6162
@@ -63,14 +64,14 @@ main =
6364config :: Config Snap a
6465config =
6566 defaultConfig
66− # setVerbose False
67− # setPort 8000
68− # setAccessLog ConfigNoLog
69− # setErrorLog ConfigNoLog
67+ |> setVerbose False
68+ |> setPort 8000
69+ |> setAccessLog ConfigNoLog
70+ |> setErrorLog ConfigNoLog
7071
7172
72−(#) :: a -> (a -> b) -> b
73−(#) value func =
73+(|>) :: a -> (a -> b) -> b
74+(|>) value func =
7475 func value
7576
7677
@@ -90,23 +91,17 @@ notFound =
9091
9192
9293compile :: Artifacts -> Snap ()
93−compile (Artifacts ifaces objs) =
94+compile artifacts =
9495 applyCORS corsOptions $ method POST $
9596 do parts <- handleMultipart defaultUploadPolicy handlePart
9697 case parts of
9798 [Just source] ->
98− case compileByteString ifaces source of
99+ case compileToBuilder artifacts source of
99100 Left err ->
100101 writeBuilder $ errorToHtmlBuilder source err
101102
102− Right (home, locals, main) ->
103− let
104− mode = Mode.Dev Nothing
105− name = ModuleName._module home
106− mains = Map.singleton home main
107− graph = Opt.addLocalGraph locals objs
108− in
109− writeBuilder $ Html.sandwich name $ Generate.generate mode graph mains
103+ Right builder ->
104+ writeBuilder builder
110105
111106 _ ->
112107 pass
@@ -119,8 +114,26 @@ handlePart info stream =
119114 else return Nothing
120115
121116
122−compileByteString :: Map.Map ModuleName.Raw I.Interface -> B.ByteString -> Either Error.Error (ModuleName.Canonical, Opt.LocalGraph, Opt.Main)
123−compileByteString interfaces source =
117+errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
118+errorToHtmlBuilder source err =
119+ let
120+ json = Encode.encodeUgly (Error.errorToJson (Code.toSource source) err)
121+ in
122+ [r|<!DOCTYPE HTML>
123+<html>
124+<head>
125+ <meta charset="UTF-8">
126+ <style>body { padding: 0; margin: 0; }</style>
127+ <script src="https://worker.elm-lang.org/compile/error.js"></script>
128+ <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
129+</head>
130+<body></body>
131+</html>|]
132+
133+
134+
135+compileToBuilder :: Artifacts -> B.ByteString -> Either Error.Error B.Builder
136+compileToBuilder (Artifacts interfaces objects) source =
124137 case Parse.fromByteString Pkg.dummyName source of
125138 Left err ->
126139 Left (Error.BadSyntax err)
@@ -137,8 +150,18 @@ compileByteString interfaces source =
137150
138151 Right artifacts@(Compile.Artifacts modul _ locals@(Opt.LocalGraph maybeMain _ _)) ->
139152 case maybeMain of
140− Just main -> Right (Can._name modul, locals, main)
141− Nothing -> Left (error "TODO no main")
153+ Nothing ->
154+ Left (error "TODO no main")
155+
156+ Just main ->
157+ let
158+ mode = Mode.Dev Nothing
159+ home = Can._name modul
160+ name = ModuleName._module home
161+ mains = Map.singleton home main
162+ graph = Opt.addLocalGraph locals objects
163+ in
164+ Right $ Html.sandwich name $ Generate.generate mode graph mains
142165
143166
144167checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either Error.Error (Map.Map ModuleName.Raw I.Interface)
@@ -160,21 +183,46 @@ checkImports interfaces imports =
160183 Left (Error.BadImports (fmap toError (NE.List i is)))
161184
162185
163−errorToHtmlBuilder :: B.ByteString -> Error.Error -> B.Builder
164−errorToHtmlBuilder source err =
186+
187+-- COMPILE ERROR VIEWER
188+
189+
190+compileErrorViewer :: Artifacts -> B.ByteString
191+compileErrorViewer artifacts =
192+ do source <- File.readUtf8 "src/Error.elm"
193+ case compileToBuilder artifacts source of
194+ Left err ->
195+ error "problem compiling src/Error.elm"
196+
197+ Right builder ->
198+ return (LBS.toStrict (B.toLazyByteString builder))
199+
200+
201+
202+-- CORS OPTIONS
203+
204+
205+corsOptions :: (Monad m) => CORSOptions m
206+corsOptions =
165207 let
166− json = Encode.encodeUgly (Error.errorToJson (Code.toSource source) err)
208+ allowedOrigins = toOriginList [ "https://elm-lang.org", "https://package.elm-lang.org" ]
209+ allowedMethods = HashSet.singleton (HashableMethod POST)
167210 in
168− [r|<!DOCTYPE HTML>
169−<html>
170−<head>
171− <meta charset="UTF-8">
172− <style>body { padding: 0; margin: 0; }</style>
173− <script src="https://worker.elm-lang.org/compile/error.js"></script>
174− <script>Elm.Error.init({flags:|] <> json <> [r|})</script>
175−</head>
176−<body></body>
177−</html>|]
211+ CORSOptions
212+ { corsAllowOrigin = return allowedOrigins
213+ , corsAllowCredentials = return True
214+ , corsExposeHeaders = return HashSet.empty
215+ , corsAllowedMethods = return allowedMethods
216+ , corsAllowedHeaders = return
217+ }
218+
219+
220+toOriginList :: [String] -> OriginList
221+toOriginList origins =
222+ Origins $ mkOriginSet $
223+ case traverse parseURI origins of
224+ Just uris -> uris
225+ Nothing -> error "invalid entry given to toOriginList list"
178226
179227
180228
@@ -228,39 +276,3 @@ toUnique oneOrMore =
228276 case oneOrMore of
229277 OneOrMore.One value -> Just value
230278 OneOrMore.More _ _ -> Nothing
231−
232−
233−
234−-- CORS
235−
236−
237−corsOptions :: (Monad m) => CORSOptions m
238−corsOptions =
239− CORSOptions
240− { corsAllowOrigin = return allowedOrigins
241− , corsAllowCredentials = return True
242− , corsExposeHeaders = return HashSet.empty
243− , corsAllowedMethods = return allowedMethods
244− , corsAllowedHeaders = return
245− }
246−
247−
248−{-# NOINLINE allowedMethods #-}
249−allowedMethods :: HashSet.HashSet HashableMethod
250−allowedMethods =
251− HashSet.singleton (HashableMethod POST)
252−
253−
254−{-# NOINLINE allowedOrigins #-}
255−allowedOrigins :: OriginList
256−allowedOrigins =
257− let
258− origins =
259− [ "https://elm-lang.org"
260− , "https://package.elm-lang.org"
261− ]
262− in
263− Origins $ mkOriginSet $
264− case traverse parseURI origins of
265− Just uris -> uris
266− Nothing -> error "Invalid entry in allowedOrigins list"