git.iko.soy/elk
on master help sign in
provide draft of worker.elm-lang.org/repl endpoint
ecc5ca3Evan Czaplicki
builder/src/Reporting/Exit.hs−37
compare with master
unifiedsplit
@@ -8,7 +8,6 @@ module Reporting.Exit
8 , Publish(..), publishToReport
8 , Publish(..), publishToReport
9 , Install(..), installToReport
9 , Install(..), installToReport
10 , Reactor(..), reactorToReport
10 , Reactor(..), reactorToReport
11− , Worker(..), workerToReport
12 , newPackageOverview
11 , newPackageOverview
13 --
12 --
14 , Solver(..)
13 , Solver(..)
@@ -2070,39 +2069,3 @@ replToReport problem =
2070
2069
2071 ReplBlocked ->
2070 ReplBlocked ->
2072 corruptCacheReport
2071 corruptCacheReport
2073−
2074−
2075−
2076−-- WORKER
2077−
2078−
2079−data Worker
2080− = WorkerInputError Error.Module
2081− | WorkerNoMain
2082−
2083−
2084−workerToReport :: Worker -> Help.Report
2085−workerToReport problem =
2086− case problem of
2087− WorkerInputError err ->
2088− Help.compilerReport "/" err []
2089−
2090− WorkerNoMain ->
2091− Help.report "NO MAIN" Nothing
2092− (
2093− "Without a `main` value, I do not know what to show on screen!"
2094− )
2095− [ D.reflow $
2096− "Adding a `main` value can be as brief as:"
2097− , D.vcat
2098− [ D.fillSep [D.cyan "import","Html"]
2099− , ""
2100− , D.fillSep [D.green "main","="]
2101− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
2102− ]
2103− , D.reflow $
2104− "Try adding something like that!"
2105− , D.toSimpleNote $
2106− "I recommend looking through https://guide.elm-lang.org for more advice on\
2107− \ how to fill in `main` values."
2108− ]
compiler/src/Generate/JavaScript.hs+43−9
@@ -2,6 +2,7 @@
2module Generate.JavaScript
2module Generate.JavaScript
3 ( generate
3 ( generate
4 , generateForRepl
4 , generateForRepl
5+ , generateForReplEndpoint
5 )
6 )
6 where
7 where
7
8
@@ -82,7 +83,7 @@ generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonica
82generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
83generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
83 let
84 let
84 mode = Mode.Dev Nothing
85 mode = Mode.Dev Nothing
85− debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
86+ debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toAnsiString")
86 evalState = addGlobal mode graph debugState (Opt.Global home name)
87 evalState = addGlobal mode graph debugState (Opt.Global home name)
87 in
88 in
88 "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
89 "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
@@ -99,14 +100,47 @@ print ansi localizer home name tipe =
99 tipeDoc = RT.canToDoc localizer RT.None tipe
100 tipeDoc = RT.canToDoc localizer RT.None tipe
100 bool = if ansi then "true" else "false"
101 bool = if ansi then "true" else "false"
101 in
102 in
102− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
103+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
103− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
104+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
104− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
105+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
105− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
106+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
106− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
107+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
107− \} else {\n\
108+ \} else {\n\
108− \ _print(' : ' + _type);\n\
109+ \ _print(' : ' + _type);\n\
110+ \}\n"
111+
112+
113+
114+-- GENERATE FOR REPL ENDPOINT
115+
116+
117+generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118+generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119+ let
120+ name = maybe Name.replValueToPrint id maybeName
121+ mode = Mode.Dev Nothing
122+ debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toAnsiString")
123+ evalState = addGlobal mode graph debugState (Opt.Global home name)
124+ in
125+ Functions.functions
126+ <> stateToBuilder evalState
127+ <> postMessage localizer home maybeName tipe
128+
129+
130+postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131+postMessage localizer home maybeName tipe =
132+ let
133+ name = maybe Name.replValueToPrint id maybeName
134+ value = JsName.toBuilder (JsName.fromGlobal home name)
135+ toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136+ tipeDoc = RT.canToDoc localizer RT.None tipe
137+ toName n = "\"" <> Name.toBuilder n <> "\""
138+ in
139+ "self.postMessage({\n\
140+ \ name: " <> maybe "null" toName maybeName <> ",\n\
141+ \ value: " <> toString <> "(true, " <> value <> "),\n\
142+ \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
109− \}\n"
143+ \});\n"
110
144
111
145
112
146
terminal/src/Repl.hs+10
@@ -3,6 +3,16 @@
3module Repl
3module Repl
4 ( Flags(..)
4 ( Flags(..)
5 , run
5 , run
6+ --
7+ , Lines(..)
8+ , Input(..)
9+ , Prefill(..)
10+ , CategorizedInput(..)
11+ , categorize
12+ --
13+ , State(..)
14+ , Output(..)
15+ , toByteString
6 )
16 )
7 where
17 where
8
18
worker/elm.cabal+9
@@ -43,11 +43,17 @@ Executable worker
43 src
43 src
44 ../compiler/src
44 ../compiler/src
45 ../builder/src
45 ../builder/src
46+ ../terminal/src
46
47
47 Main-Is:
48 Main-Is:
48 Main.hs
49 Main.hs
49
50
50 other-modules:
51 other-modules:
52+ Artifacts
53+ Cors
54+ Endpoint.Compile
55+ Endpoint.Repl
56+
51 AST.Canonical
57 AST.Canonical
52 AST.Optimized
58 AST.Optimized
53 AST.Source
59 AST.Source
@@ -127,6 +133,7 @@ Executable worker
127 Parse.Type
133 Parse.Type
128 Parse.Variable
134 Parse.Variable
129 Paths_elm
135 Paths_elm
136+ Repl
130 Reporting
137 Reporting
131 Reporting.Annotation
138 Reporting.Annotation
132 Reporting.Doc
139 Reporting.Doc
@@ -173,6 +180,7 @@ Executable worker
173 filelock,
180 filelock,
174 filepath >= 1 && < 2.0,
181 filepath >= 1 && < 2.0,
175 ghc-prim >= 0.5.2,
182 ghc-prim >= 0.5.2,
183+ haskeline,
176 HTTP >= 4000.2.5 && < 4000.4,
184 HTTP >= 4000.2.5 && < 4000.4,
177 http-client >= 0.6 && < 0.7,
185 http-client >= 0.6 && < 0.7,
178 http-client-tls >= 0.3 && < 0.4,
186 http-client-tls >= 0.3 && < 0.4,
@@ -183,6 +191,7 @@ Executable worker
183 network >= 2.4 && < 2.7,
191 network >= 2.4 && < 2.7,
184 network-uri,
192 network-uri,
185 parsec,
193 parsec,
194+ process,
186 raw-strings-qq,
195 raw-strings-qq,
187 scientific,
196 scientific,
188 SHA,
197 SHA,
worker/elm.json → worker/outlines/compile/elm.jsonrenamed

The content is the same.

worker/outlines/repl/elm.jsonnew file+17
@@ -0,0 +1,17 @@
1+{
2+ "type": "application",
3+ "source-directories": [
4+ "src"
5+ ],
6+ "elm-version": "0.19.1",
7+ "dependencies": {
8+ "direct": {
9+ "elm/core": "1.0.2"
10+ },
11+ "indirect": {}
12+ },
13+ "test-dependencies": {
14+ "direct": {},
15+ "indirect": {}
16+ }
17+}
worker/src/Artifacts.hsnew file+91
@@ -0,0 +1,91 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Artifacts
3+ ( Artifacts(..)
4+ , loadCompile
5+ , loadRepl
6+ )
7+ where
8+
9+
10+import Control.Concurrent (readMVar)
11+import Control.Monad (liftM2)
12+import qualified Data.Map as Map
13+import qualified Data.OneOrMore as OneOrMore
14+import qualified System.Directory as Dir
15+import System.FilePath ((</>))
16+
17+import qualified AST.Optimized as Opt
18+import qualified BackgroundWriter as BW
19+import qualified Elm.Details as Details
20+import qualified Elm.Interface as I
21+import qualified Elm.ModuleName as ModuleName
22+import qualified Reporting
23+
24+
25+
26+-- ARTIFACTS
27+
28+
29+data Artifacts =
30+ Artifacts
31+ { _ifaces :: Map.Map ModuleName.Raw I.Interface
32+ , _graph :: Opt.GlobalGraph
33+ }
34+
35+
36+loadCompile :: IO Artifacts
37+loadCompile =
38+ load ("outlines" </> "compile")
39+
40+
41+loadRepl :: IO Artifacts
42+loadRepl =
43+ load ("outlines" </> "repl")
44+
45+
46+
47+-- LOAD
48+
49+
50+load :: FilePath -> IO Artifacts
51+load dir =
52+ BW.withScope $ \scope ->
53+ do style <- Reporting.terminal
54+ root <- fmap (</> dir) Dir.getCurrentDirectory
55+ result <- Details.load style scope root
56+ case result of
57+ Left _ ->
58+ error "Ran into some problem loading elm.json details"
59+
60+ Right details ->
61+ do omvar <- Details.loadObjects root details
62+ imvar <- Details.loadInterfaces root details
63+ mdeps <- readMVar imvar
64+ mobjs <- readMVar omvar
65+ case liftM2 (,) mdeps mobjs of
66+ Nothing ->
67+ error "Ran into some weird problem loading elm.json details"
68+
69+ Just (deps, objs) ->
70+ return $ Artifacts (toInterfaces deps) objs
71+
72+
73+toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
74+toInterfaces deps =
75+ Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
76+ Map.elems (Map.mapMaybeWithKey getPublic deps)
77+
78+
79+getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
80+getPublic (ModuleName.Canonical _ name) dep =
81+ case dep of
82+ I.Public iface -> Just (name, OneOrMore.one iface)
83+ I.Private _ _ _ -> Nothing
84+
85+
86+toUnique :: OneOrMore.OneOrMore a -> Maybe a
87+toUnique oneOrMore =
88+ case oneOrMore of
89+ OneOrMore.One value -> Just value
90+ OneOrMore.More _ _ -> Nothing
91+
worker/src/Cors.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Cors
3+ ( allow
4+ )
5+ where
6+
7+
8+import qualified Data.HashSet as HashSet
9+import Network.URI (parseURI)
10+import Snap.Core (Snap, Method, method)
11+import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)
12+
13+
14+
15+-- ALLOW
16+
17+
18+allow :: Method -> [String] -> Snap () -> Snap ()
19+allow method_ origins snap =
20+ applyCORS (toOptions method_ origins) $ method method_ $
21+ snap
22+
23+
24+
25+-- TO OPTIONS
26+
27+
28+toOptions :: (Monad m) => Method -> [String] -> CORSOptions m
29+toOptions method_ origins =
30+ let
31+ allowedOrigins = toOriginList origins
32+ allowedMethods = HashSet.singleton (HashableMethod method_)
33+ in
34+ CORSOptions
35+ { corsAllowOrigin = return allowedOrigins
36+ , corsAllowCredentials = return True
37+ , corsExposeHeaders = return HashSet.empty
38+ , corsAllowedMethods = return allowedMethods
39+ , corsAllowedHeaders = return
40+ }
41+
42+
43+toOriginList :: [String] -> OriginList
44+toOriginList origins =
45+ Origins $ mkOriginSet $
46+ case traverse parseURI origins of
47+ Just uris -> uris
48+ Nothing -> error "invalid entry given to toOriginList list"
worker/src/Endpoint/Compile.hsnew file+228
@@ -0,0 +1,228 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
3+module Endpoint.Compile
4+ ( endpoint
5+ , loadErrorJS
6+ )
7+ where
8+
9+
10+import qualified Data.ByteString as B
11+import qualified Data.ByteString.Builder as B
12+import qualified Data.ByteString.Lazy as LBS
13+import qualified Data.Map as Map
14+import qualified Data.Map.Utils as Map
15+import qualified Data.Name as N
16+import qualified Data.NonEmptyList as NE
17+import Snap.Core
18+import Snap.Util.FileUploads
19+import qualified System.Directory as Dir
20+import qualified System.IO.Streams as Stream
21+import Text.RawString.QQ (r)
22+
23+import qualified Artifacts as A
24+import qualified Cors
25+
26+import qualified AST.Source as Src
27+import qualified AST.Canonical as Can
28+import qualified AST.Optimized as Opt
29+import qualified BackgroundWriter as BW
30+import qualified Build
31+import qualified Compile
32+import qualified Elm.Details as Details
33+import qualified Elm.Interface as I
34+import qualified Elm.ModuleName as ModuleName
35+import qualified Elm.Package as Pkg
36+import qualified File
37+import qualified Generate
38+import qualified Generate.Html as Html
39+import qualified Generate.JavaScript as JS
40+import qualified Generate.Mode as Mode
41+import qualified Json.Encode as Encode
42+import qualified Parse.Module as Parse
43+import qualified Reporting
44+import qualified Reporting.Annotation as A
45+import Reporting.Doc ((<>))
46+import qualified Reporting.Doc as D
47+import qualified Reporting.Error as Error
48+import qualified Reporting.Error.Import as Import
49+import qualified Reporting.Exit as Exit
50+import qualified Reporting.Exit.Help as Help
51+import qualified Reporting.Task as Task
52+
53+
54+
55+-- ALLOWED ORIGINS
56+
57+
58+allowedOrigins :: [String]
59+allowedOrigins =
60+ [ "https://elm-lang.org"
61+ , "https://package.elm-lang.org"
62+ ]
63+
64+
65+
66+-- ENDPOINT
67+
68+
69+endpoint :: A.Artifacts -> Snap ()
70+endpoint 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
79+
80+ NoMain ->
81+ writeBuilder $ renderReport noMain
82+
83+ BadInput name err ->
84+ writeBuilder $ renderReport $
85+ Help.compilerReport "/" (Error.Module name "/try" File.zeroTime source err) []
86+
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>"
95+
96+
97+ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
98+ignoreFile _ _ count =
99+ return (count + 1)
100+
101+
102+
103+-- COMPILE
104+
105+
106+data Outcome
107+ = Success B.Builder
108+ | NoMain
109+ | BadInput ModuleName.Raw Error.Error
110+
111+
112+compile :: A.Artifacts -> B.ByteString -> Outcome
113+compile (A.Artifacts interfaces objects) source =
114+ case Parse.fromByteString Parse.Application source of
115+ Left err ->
116+ BadInput N._Main (Error.BadSyntax err)
117+
118+ Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
119+ case checkImports interfaces imports of
120+ Left err ->
121+ BadInput (Src.getName modul) (Error.BadImports err)
122+
123+ Right ifaces ->
124+ case Compile.compile Pkg.dummyName ifaces modul of
125+ Left err ->
126+ BadInput (Src.getName modul) err
127+
128+ Right (Compile.Artifacts canModule _ locals) ->
129+ case locals of
130+ Opt.LocalGraph Nothing _ _ ->
131+ NoMain
132+
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
142+
143+
144+checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
145+checkImports 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)
153+
154+ i:is ->
155+ let
156+ unimported =
157+ Map.keysSet (Map.difference interfaces importDict)
158+
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))
163+
164+
165+
166+-- RENDER REPORT
167+
168+
169+renderReport :: Help.Report -> B.Builder
170+renderReport 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>Elm.Errors.init({flags:|] <> Encode.encodeUgly (Exit.toJson report) <> [r|});</script>
180+</body>
181+</html>|]
182+
183+
184+
185+-- NO MAIN
186+
187+
188+noMain :: Help.Report
189+noMain =
190+ Help.report "NO MAIN" Nothing
191+ (
192+ "Without a `main` value, I do not know what to show on screen!"
193+ )
194+ [ D.reflow $
195+ "Adding a `main` value can be as brief as:"
196+ , D.vcat
197+ [ D.fillSep [D.cyan "import","Html"]
198+ , ""
199+ , D.fillSep [D.green "main","="]
200+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
201+ ]
202+ , D.reflow $
203+ "Try adding something like that!"
204+ , D.toSimpleNote $
205+ "I recommend looking through https://guide.elm-lang.org for more advice on\
206+ \ how to fill in `main` values."
207+ ]
208+
209+
210+
211+-- LOAD ERROR JS
212+
213+
214+loadErrorJS :: IO B.ByteString
215+loadErrorJS =
216+ let
217+ run work =
218+ do result <- work
219+ case result of
220+ Right a -> return a
221+ Left _ -> error "problem building reactor/src/Errors.elm"
222+ in
223+ Dir.withCurrentDirectory "../reactor" $ BW.withScope $ \scope ->
224+ do let root = "."
225+ details <- run $ Details.load Reporting.silent scope root
226+ artifacts <- run $ Build.fromMains Reporting.silent root details (NE.List "src/Errors.elm" [])
227+ javascript <- run $ Task.run $ Generate.prod root details artifacts
228+ return $ LBS.toStrict $ B.toLazyByteString javascript
worker/src/Endpoint/Repl.hsnew file+256
@@ -0,0 +1,256 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Endpoint.Repl
4+ ( endpoint
5+ )
6+ where
7+
8+
9+import qualified Data.ByteString.Builder as B
10+import qualified Data.ByteString.Internal as BS
11+import qualified Data.ByteString.Lazy as LBS
12+import qualified Data.ByteString.UTF8 as BS_UTF8
13+import Data.Map ((!))
14+import qualified Data.Map as Map
15+import qualified Data.Map.Utils as Map
16+import qualified Data.Name as N
17+import qualified Data.NonEmptyList as NE
18+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
19+import Foreign.Ptr (minusPtr)
20+import Snap.Core
21+
22+import qualified Artifacts as A
23+import qualified Cors
24+
25+import qualified AST.Source as Src
26+import qualified AST.Canonical as Can
27+import qualified AST.Optimized as Opt
28+import qualified Compile
29+import qualified Elm.Interface as I
30+import qualified Elm.ModuleName as ModuleName
31+import qualified Elm.Package as Pkg
32+import qualified File
33+import qualified Generate.JavaScript as JS
34+import qualified Json.Encode as Encode
35+import qualified Json.Decode as D
36+import qualified Parse.Module as Parse
37+import qualified Parse.Primitives as P
38+import qualified Parse.Variable as Var
39+import qualified Repl
40+import qualified Reporting.Annotation as A
41+import qualified Reporting.Error as Error
42+import qualified Reporting.Error.Import as Import
43+import qualified Reporting.Exit as Exit
44+import qualified Reporting.Exit.Help as Help
45+import qualified Reporting.Render.Type.Localizer as L
46+
47+
48+
49+-- ALLOWED ORIGINS
50+
51+
52+allowedOrigins :: [String]
53+allowedOrigins =
54+ [ "https://elm-lang.org"
55+ , "https://guide.elm-lang.org"
56+ ]
57+
58+
59+
60+-- ENDPOINT
61+
62+
63+endpoint :: A.Artifacts -> Snap ()
64+endpoint artifacts =
65+ Cors.allow POST allowedOrigins $
66+ do body <- LBS.toStrict <$> readRequestBody (64 * 1024)
67+ case D.fromByteString decoder body of
68+ Right (state, entry) ->
69+ serveOutcome (toOutcome artifacts state entry)
70+
71+ Left _ ->
72+ do modifyResponse $ setResponseStatus 400 "Bad Request"
73+ modifyResponse $ setContentType "text/html; charset=utf-8"
74+ writeBS "Received unexpected JSON body."
75+
76+
77+
78+-- TO OUTCOME
79+
80+
81+data Outcome
82+ = NewImport N.Name
83+ | NewType N.Name
84+ | NewWork B.Builder
85+ --
86+ | Reset
87+ | Skip
88+ | Indent
89+ | DefStart N.Name
90+ --
91+ | NoPorts
92+ | InvalidCommand
93+ | Failure BS.ByteString Error.Error
94+
95+
96+toOutcome :: A.Artifacts -> Repl.State -> BS.ByteString -> Outcome
97+toOutcome artifacts state entry =
98+ case reverse (lines (BS_UTF8.toString entry)) of
99+ [] ->
100+ Indent
101+
102+ prev : rev ->
103+ case Repl.categorize (Repl.Lines prev rev) of
104+ Repl.Done input ->
105+ case input of
106+ Repl.Import name src -> compile artifacts state (ImportEntry name src)
107+ Repl.Type name src -> compile artifacts state (TypeEntry name src)
108+ Repl.Decl name src -> compile artifacts state (DeclEntry name src)
109+ Repl.Expr src -> compile artifacts state (ExprEntry src)
110+ Repl.Port -> NoPorts
111+ Repl.Skip -> Skip
112+ Repl.Reset -> Reset
113+ Repl.Exit -> InvalidCommand
114+ Repl.Help _ -> InvalidCommand
115+
116+ Repl.Continue prefill ->
117+ case prefill of
118+ Repl.Indent -> Indent
119+ Repl.DefStart name -> DefStart name
120+
121+
122+
123+-- SERVE OUTCOME
124+
125+
126+serveOutcome :: Outcome -> Snap ()
127+serveOutcome outcome =
128+ let
129+ serveString = serveBuilder "text/plain"
130+ in
131+ case outcome of
132+ NewImport name -> serveString $ "add-import:" <> N.toBuilder name
133+ NewType name -> serveString $ "add-type:" <> N.toBuilder name
134+ NewWork js -> serveBuilder "application/javascript" js
135+ Reset -> serveString $ "reset"
136+ Skip -> serveString $ "skip"
137+ Indent -> serveString $ "indent"
138+ DefStart name -> serveString $ "def-start:" <> N.toBuilder name
139+ NoPorts -> serveString $ "no-ports"
140+ InvalidCommand -> serveString $ "invalid-command"
141+ Failure source err ->
142+ serveBuilder "application/json" $ Encode.encodeUgly $ Exit.toJson $
143+ Help.compilerReport "/" (Error.Module N.replModule "/repl" File.zeroTime source err) []
144+
145+
146+serveBuilder :: BS.ByteString -> B.Builder -> Snap ()
147+serveBuilder mime builder =
148+ do modifyResponse (setContentType mime)
149+ writeBuilder builder
150+
151+
152+
153+-- COMPILE
154+
155+
156+data EntryType
157+ = ImportEntry N.Name BS.ByteString
158+ | TypeEntry N.Name BS.ByteString
159+ | DeclEntry N.Name BS.ByteString
160+ | ExprEntry BS.ByteString
161+
162+
163+compile :: A.Artifacts -> Repl.State -> EntryType -> Outcome
164+compile (A.Artifacts interfaces objects) state entryType =
165+ let
166+ source =
167+ Repl.toByteString state $
168+ case entryType of
169+ ImportEntry _ _ -> Repl.OutputNothing
170+ TypeEntry _ _ -> Repl.OutputNothing
171+ DeclEntry name _ -> Repl.OutputDecl name
172+ ExprEntry src -> Repl.OutputExpr src
173+ in
174+ case
175+ do modul <- mapLeft Error.BadSyntax $ Parse.fromByteString Parse.Application source
176+ ifaces <- mapLeft Error.BadImports $ checkImports interfaces (Src._imports modul)
177+ artifacts <- Compile.compile Pkg.dummyName ifaces modul
178+ return ( modul, artifacts, objects )
179+ of
180+ Left err ->
181+ Failure source err
182+
183+ Right info ->
184+ case entryType of
185+ ImportEntry name _ -> NewImport name
186+ TypeEntry name _ -> NewType name
187+ DeclEntry name _ -> NewWork (toJavaScript info (Just name))
188+ ExprEntry _ -> NewWork (toJavaScript info Nothing)
189+
190+
191+toJavaScript :: (Src.Module, Compile.Artifacts, Opt.GlobalGraph) -> Maybe N.Name -> B.Builder
192+toJavaScript (modul, Compile.Artifacts canModule types locals, objects) maybeName =
193+ let
194+ localizer = L.fromModule modul
195+ graph = Opt.addLocalGraph locals objects
196+ home = Can._name canModule
197+ tipe = types ! maybe N.replValueToPrint id maybeName
198+ in
199+ JS.generateForReplEndpoint localizer graph home maybeName tipe
200+
201+
202+mapLeft :: (x -> y) -> Either x a -> Either y a
203+mapLeft func result =
204+ either (Left . func) Right result
205+
206+
207+checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
208+checkImports interfaces imports =
209+ let
210+ importDict = Map.fromValues Src.getImportName imports
211+ missing = Map.difference importDict interfaces
212+ in
213+ case Map.elems missing of
214+ [] ->
215+ Right (Map.intersection interfaces importDict)
216+
217+ i:is ->
218+ let
219+ unimported =
220+ Map.keysSet (Map.difference interfaces importDict)
221+
222+ toError (Src.Import (A.At region name) _ _) =
223+ Import.Error region name unimported Import.NotFound
224+ in
225+ Left (fmap toError (NE.List i is))
226+
227+
228+
229+-- DECODER
230+
231+
232+decoder :: D.Decoder () ( Repl.State, BS.ByteString )
233+decoder =
234+ let
235+ bail _ _ = ()
236+ upper = D.KeyDecoder (Var.upper bail) bail
237+ lower = D.KeyDecoder (Var.lower bail) bail
238+ bytes = D.customString bytesParser bail
239+ builder = B.byteString <$> bytes
240+ in
241+ do imports <- D.field "imports" (D.dict upper builder)
242+ types <- D.field "types" (D.dict upper builder)
243+ decls <- D.field "decls" (D.dict lower builder)
244+ entry <- D.field "entry" bytes
245+ return ( Repl.State imports types decls, entry )
246+
247+
248+bytesParser :: P.Parser x BS.ByteString
249+bytesParser =
250+ P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
251+ let
252+ off = minusPtr pos (unsafeForeignPtrToPtr src)
253+ len = minusPtr end pos
254+ newCol = col + fromIntegral len
255+ in
256+ cok (BS.PS src off len) (P.State src end end indent row newCol)
worker/src/Main.hs+17−268
@@ -1,54 +1,18 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2+{-# LANGUAGE OverloadedStrings #-}
3module Main
3module Main
4 ( main
4 ( main
5 )
5 )
6 where
6 where
7
7
8
8
9−import Control.Concurrent (readMVar)
9+import Control.Monad (msum)
10−import Control.Monad (liftM2, msum)
11−import qualified Data.ByteString as B
12−import qualified Data.ByteString.Builder as B
13−import qualified Data.ByteString.Lazy as LBS
14−import qualified Data.HashSet as HashSet
15−import qualified Data.Map as Map
16−import qualified Data.Map.Utils as Map
17−import qualified Data.Name as N
18−import qualified Data.NonEmptyList as NE
19−import qualified Data.OneOrMore as OneOrMore
20−import Network.URI (parseURI)
21import Snap.Core
10import Snap.Core
22import Snap.Http.Server
11import Snap.Http.Server
23−import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)
24−import Snap.Util.FileUploads
25−import qualified System.Directory as Dir
26−import qualified System.IO.Streams as Stream
27−import Text.RawString.QQ (r)
28
12
29−import qualified AST.Source as Src
13+import qualified Artifacts
30−import qualified AST.Canonical as Can
31−import qualified AST.Optimized as Opt
14+import qualified Endpoint.Compile as Compile
32−import qualified BackgroundWriter as BW
33−import qualified Build
34−import qualified Compile
35−import qualified Elm.Details as Details
15+import qualified Endpoint.Repl as Repl
36−import qualified Elm.Interface as I
37−import qualified Elm.ModuleName as ModuleName
38−import qualified Elm.Package as Pkg
39−import qualified File
40−import qualified Generate
41−import qualified Generate.Html as Html
42−import qualified Generate.JavaScript as Generate
43−import qualified Generate.Mode as Mode
44−import qualified Json.Encode as Encode
45−import qualified Parse.Module as Parse
46−import qualified Reporting
47−import qualified Reporting.Annotation as A
48−import qualified Reporting.Error as Error
49−import qualified Reporting.Error.Import as Import
50−import qualified Reporting.Exit as Exit
51−import qualified Reporting.Task as Task
52
16
53
17
54
18
@@ -57,10 +21,13 @@ import qualified Reporting.Task as Task
57
21
58main :: IO ()
22main :: IO ()
59main =
23main =
60− do artifacts <- loadArtifacts
24+ do rArtifacts <- Artifacts.loadRepl
61− errorJS <- compileErrorViewer
25+ cArtifacts <- Artifacts.loadCompile
26+ errorJS <- Compile.loadErrorJS
62 httpServe config $ msum $
27 httpServe config $ msum $
63− [ path "compile" $ compile artifacts
28+ [ ifTop $ status
29+ , path "repl" $ Repl.endpoint rArtifacts
30+ , path "compile" $ Compile.endpoint cArtifacts
64 , path "compile/errors.js" $ writeBS errorJS
31 , path "compile/errors.js" $ writeBS errorJS
65 , notFound
32 , notFound
66 ]
33 ]
@@ -68,235 +35,17 @@ main =
68
35
69config :: Config Snap a
36config :: Config Snap a
70config =
37config =
71− defaultConfig
72− |> setPort 8000
73− |> setAccessLog ConfigNoLog
38+ setPort 8000 $ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
74− |> setErrorLog ConfigNoLog
75
39
76
40
77−(|>) :: a -> (a -> b) -> b
41+status :: Snap ()
78−(|>) value func =
42+status =
79− func value
43+ do modifyResponse $ setContentType "text/plain"
80−
44+ writeBuilder "Status: OK"
81−
82−
83−-- NOT FOUND
84
45
85
46
86notFound :: Snap ()
47notFound :: Snap ()
87notFound =
48notFound =
88 do modifyResponse $ setResponseStatus 404 "Not Found"
49 do modifyResponse $ setResponseStatus 404 "Not Found"
89 modifyResponse $ setContentType "text/html; charset=utf-8"
50 modifyResponse $ setContentType "text/html; charset=utf-8"
90− writeBS "Not Found"
51+ writeBuilder "Not Found"
91−
92−
93−
94−-- COMPILE ENDPOINT
95−
96−
97−compile :: Artifacts -> Snap ()
98−compile artifacts =
99− applyCORS corsOptions $ method POST $
100− do result <- foldMultipart defaultUploadPolicy ignoreFile 0
101− case result of
102− ([("code",source)], 0) ->
103− do modifyResponse $ setContentType "text/html; charset=utf-8"
104− case compileToBuilder artifacts source of
105− Right builder -> writeBuilder builder
106− Left exit -> writeBuilder (exitToHtmlBuilder exit)
107−
108− _ ->
109− do modifyResponse $ setResponseStatus 400 "Bad Request"
110− modifyResponse $ setContentType "text/html; charset=utf-8"
111− writeBS
112− "<p>Unexpected request format. This should not be possible!</p>\
113− \<p>Please report this\
114− \ <a href=\"https://github.com/elm/compiler/issues\">here</a>\
115− \ along with the URL and your browser version.</p>"
116−
117−
118−ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int
119−ignoreFile _ _ count =
120− return (count + 1)
121−
122−
123−exitToHtmlBuilder :: Exit.Worker -> B.Builder
124−exitToHtmlBuilder exit =
125− let
126− json =
127− Encode.encodeUgly $ Exit.toJson $ Exit.workerToReport exit
128− in
129− [r|<!DOCTYPE HTML>
130−<html>
131−<head>
132− <meta charset="UTF-8">
133− <style>body { padding: 0; margin: 0; background-color: black; }</style>
134− <script src="https://worker.elm-lang.org/compile/errors.js"></script>
135−</head>
136−<body>
137− <script>Elm.Errors.init({flags:|] <> json <> [r|});</script>
138−</body>
139−</html>|]
140−
141−
142−
143−-- COMPILE TO BUILDER
144−
145−
146−compileToBuilder :: Artifacts -> B.ByteString -> Either Exit.Worker B.Builder
147−compileToBuilder (Artifacts interfaces objects) source =
148− case Parse.fromByteString Parse.Application source of
149− Left err ->
150− Left $ toInputError N._Main source (Error.BadSyntax err)
151−
152− Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
153− case checkImports interfaces imports of
154− Left err ->
155− Left $ toInputError (Src.getName modul) source (Error.BadImports err)
156−
157− Right ifaces ->
158− case Compile.compile Pkg.dummyName ifaces modul of
159− Left err ->
160− Left $ toInputError (Src.getName modul) source err
161−
162− Right (Compile.Artifacts canModule _ locals) ->
163− case locals of
164− Opt.LocalGraph Nothing _ _ ->
165− Left Exit.WorkerNoMain
166−
167− Opt.LocalGraph (Just main_) _ _ ->
168− let
169− mode = Mode.Dev Nothing
170− home = Can._name canModule
171− name = ModuleName._module home
172− mains = Map.singleton home main_
173− graph = Opt.addLocalGraph locals objects
174− in
175− Right $ Html.sandwich name $ Generate.generate mode graph mains
176−
177−
178−checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface)
179−checkImports interfaces imports =
180− let
181− importDict = Map.fromValues Src.getImportName imports
182− missing = Map.difference importDict interfaces
183− in
184− case Map.elems missing of
185− [] ->
186− Right (Map.intersection interfaces importDict)
187−
188− i:is ->
189− let
190− unimported = Map.keysSet (Map.difference interfaces importDict)
191− toError (Src.Import (A.At region name) _ _) =
192− Import.Error region name unimported Import.NotFound
193− in
194− Left (fmap toError (NE.List i is))
195−
196−
197−toInputError :: ModuleName.Raw -> B.ByteString -> Error.Error -> Exit.Worker
198−toInputError name source err =
199− Exit.WorkerInputError $
200− Error.Module name "/try" File.zeroTime source err
201−
202−
203−
204−-- COMPILE ERROR VIEWER
205−
206−
207−compileErrorViewer :: IO B.ByteString
208−compileErrorViewer =
209− let
210− run work =
211− do result <- work
212− case result of
213− Right a -> return a
214− Left _ -> error "problem building reactor/src/Errors.elm"
215− in
216− Dir.withCurrentDirectory "../reactor" $ BW.withScope $ \scope ->
217− do let root = "."
218− details <- run $ Details.load Reporting.silent scope root
219− artifacts <- run $ Build.fromMains Reporting.silent root details (NE.List "src/Errors.elm" [])
220− javascript <- run $ Task.run $ Generate.prod root details artifacts
221− return $ LBS.toStrict $ B.toLazyByteString javascript
222−
223−
224−
225−-- CORS OPTIONS
226−
227−
228−corsOptions :: (Monad m) => CORSOptions m
229−corsOptions =
230− let
231− allowedOrigins = toOriginList [ "https://elm-lang.org", "https://package.elm-lang.org" ]
232− allowedMethods = HashSet.singleton (HashableMethod POST)
233− in
234− CORSOptions
235− { corsAllowOrigin = return allowedOrigins
236− , corsAllowCredentials = return True
237− , corsExposeHeaders = return HashSet.empty
238− , corsAllowedMethods = return allowedMethods
239− , corsAllowedHeaders = return
240− }
241−
242−
243−toOriginList :: [String] -> OriginList
244−toOriginList origins =
245− Origins $ mkOriginSet $
246− case traverse parseURI origins of
247− Just uris -> uris
248− Nothing -> error "invalid entry given to toOriginList list"
249−
250−
251−
252−-- ARTIFACTS
253−
254−
255−data Artifacts =
256− Artifacts
257− { _ifaces :: Map.Map ModuleName.Raw I.Interface
258− , _graph :: Opt.GlobalGraph
259− }
260−
261−
262−loadArtifacts :: IO Artifacts
263−loadArtifacts =
264− BW.withScope $ \scope ->
265− do style <- Reporting.terminal
266− root <- Dir.getCurrentDirectory
267− result <- Details.load style scope root
268− case result of
269− Left _ ->
270− error "Ran into some problem loading elm.json details"
271−
272− Right details ->
273− do omvar <- Details.loadObjects root details
274− imvar <- Details.loadInterfaces root details
275− mdeps <- readMVar imvar
276− mobjs <- readMVar omvar
277− case liftM2 (,) mdeps mobjs of
278− Nothing ->
279− error "Ran into some weird problem loading elm.json details"
280−
281− Just (deps, objs) ->
282− return $ Artifacts (toInterfaces deps) objs
283−
284−
285−toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
286−toInterfaces deps =
287− Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
288− Map.elems (Map.mapMaybeWithKey getPublic deps)
289−
290−
291−getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
292−getPublic (ModuleName.Canonical _ name) dep =
293− case dep of
294− I.Public iface -> Just (name, OneOrMore.one iface)
295− I.Private _ _ _ -> Nothing
296−
297−
298−toUnique :: OneOrMore.OneOrMore a -> Maybe a
299−toUnique oneOrMore =
300− case oneOrMore of
301− OneOrMore.One value -> Just value
302− OneOrMore.More _ _ -> Nothing