git.iko.soy/elk
on 2edbe13 help sign in
elk/worker/src/Endpoint/Compile.hs
233 lines 6.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
3module Endpoint.Compile
4 ( endpoint
5 , loadErrorJS
6 )
7 where
10import qualified Data.ByteString as B
11import qualified Data.ByteString.Builder as B
12import qualified Data.ByteString.Lazy as LBS
13import qualified Data.Map as Map
14import qualified Data.Map.Utils as Map
15import qualified Data.Name as N
16import qualified Data.NonEmptyList as NE
17import Snap.Core
18import Snap.Util.FileUploads
19import qualified System.Directory as Dir
20import qualified System.IO.Streams as Stream
21import Text.RawString.QQ (r)
23import qualified Artifacts as A
24import qualified Cors
26import qualified AST.Source as Src
27import qualified AST.Canonical as Can
28import qualified AST.Optimized as Opt
29import qualified BackgroundWriter as BW
30import qualified Build
31import qualified Compile
32import qualified Elm.Details as Details
33import qualified Elm.Interface as I
34import qualified Elm.ModuleName as ModuleName
35import qualified Elm.Package as Pkg
36import qualified File
37import qualified Generate
38import qualified Generate.Html as Html
39import qualified Generate.JavaScript as JS
40import qualified Generate.Mode as Mode
41import qualified Json.Encode as Encode
42import qualified Parse.Module as Parse
43import qualified Reporting
44import qualified Reporting.Annotation as A
45import Reporting.Doc ((<>))
46import qualified Reporting.Doc as D
47import qualified Reporting.Error as Error
48import qualified Reporting.Error.Import as Import
49import qualified Reporting.Exit as Exit
50import qualified Reporting.Exit.Help as Help
51import qualified Reporting.Task as Task
55-- ALLOWED ORIGINS
58allowedOrigins :: [String]
59allowedOrigins =
60 [ "https://elm-lang.org"
61 , "https://package.elm-lang.org"
62 ]
66-- ENDPOINT
69endpoint :: A.Artifacts -> Snap ()
70endpoint artifacts =
71 Cors.allow POST allowedOrigins $
72 do result <- foldMultipart defaultUploadPolicy ignoreFile 0
73 case result of
74 ([("code",source)], 0) ->
75 do modifyResponse $ setContentType "text/html; charset=utf-8"
76 case compile artifacts source of
77 Success builder ->
78 writeBuilder builder
80 NoMain ->
81 writeBuilder $ renderReport noMain
83 BadInput name err ->
84 writeBuilder $ renderReport $
85 Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []
87 _ ->
88 do modifyResponse $ setResponseStatus 400 "Bad Request"
89 modifyResponse $ setContentType "text/html; charset=utf-8"
90 writeBS
91 "<p>Unexpected request format. This should not be possible!</p>\
92 \<p>Please report this\
93 \ <a href=\"https://github.com/elm/compiler/issues\">here</a>\
94 \ along with the URL and your browser version.</p>"
97ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
98ignoreFile _ _ count =
99 return (count + 1)
103-- COMPILE
106data Outcome
107 = Success B.Builder
108 | NoMain
109 | BadInput ModuleName.Raw Error.Error
112compile :: A.Artifacts -> B.ByteString -> Outcome
113compile (A.Artifacts interfaces objects) source =
114 case Parse.fromByteString Parse.Application source of
115 Left err ->
116 BadInput N._Main (Error.BadSyntax err)
118 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
119 case checkImports interfaces imports of
120 Left err ->
121 BadInput (Src.getName modul) (Error.BadImports err)
123 Right ifaces ->
124 case Compile.compile Pkg.dummyName ifaces modul of
125 Left err ->
126 BadInput (Src.getName modul) err
128 Right (Compile.Artifacts canModule _ locals) ->
129 case locals of
130 Opt.LocalGraph Nothing _ _ ->
131 NoMain
133 Opt.LocalGraph (Just main_) _ _ ->
134 let
135 mode = Mode.Dev Nothing
136 home = Can._name canModule
137 name = ModuleName._module home
138 mains = Map.singleton home main_
139 graph = Opt.addLocalGraph locals objects
140 in
141 Success $ Html.sandwich name $ JS.generate mode graph mains
144checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
145checkImports interfaces imports =
146 let
147 importDict = Map.fromValues Src.getImportName imports
148 missing = Map.difference importDict interfaces
149 in
150 case Map.elems missing of
151 [] ->
152 Right (Map.intersection interfaces importDict)
154 i:is ->
155 let
156 unimported =
157 Map.keysSet (Map.difference interfaces importDict)
159 toError (Src.Import (A.At region name) _ _) =
160 Import.Error region name unimported Import.NotFound
161 in
162 Left (fmap toError (NE.List i is))
166-- RENDER REPORT
169renderReport :: Help.Report -> B.Builder
170renderReport report =
171 [r|<!DOCTYPE HTML>
172<html>
173<head>
174 <meta charset="UTF-8">
175 <style>body { padding: 0; margin: 0; background-color: black; }</style>
176 <script src="https://worker.elm-lang.org/compile/errors.js"></script>
177</head>
178<body>
179 <script>
180 var app = Elm.Errors.init({flags:|] <> Encode.encodeUgly (Exit.toJson report) <> [r|});
181 app.ports.jumpTo.subscribe(function(region) {
182 window.parent.postMessage(JSON.stringify(region), '*');
183 });
184 </script>
185</body>
186</html>|]
190-- NO MAIN
193noMain :: Help.Report
194noMain =
195 Help.report "NO MAIN" Nothing
196 (
197 "Without a `main` value, I do not know what to show on screen!"
198 )
199 [ D.reflow $
200 "Adding a `main` value can be as brief as:"
201 , D.vcat
202 [ D.fillSep [D.cyan "import","Html"]
203 , ""
204 , D.fillSep [D.green "main","="]
205 , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
206 ]
207 , D.reflow $
208 "Try adding something like that!"
209 , D.toSimpleNote $
210 "I recommend looking through https://guide.elm-lang.org for more advice on\
211 \ how to fill in `main` values."
212 ]
216-- LOAD ERROR JS
219loadErrorJS :: IO B.ByteString
220loadErrorJS =
221 let
222 run work =
223 do result <- work
224 case result of
225 Right a -> return a
226 Left _ -> error "problem building src/Errors.elm"
227 in
228 BW.withScope $ \scope ->
229 do root <- Dir.getCurrentDirectory
230 details <- run $ Details.load Reporting.silent scope root
231 artifacts <- run $ Build.fromPaths Reporting.silent root details (NE.List "src/Errors.elm" [])
232 javascript <- run $ Task.run $ Generate.prod root details artifacts
233 return $ LBS.toStrict $ B.toLazyByteString javascript