3e9455d · elk · git.iko.soy

1+{-# OPTIONS_GHC -Wall #-}

1{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}

2{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}

2module Main

3module Main

3 ( main

4 ( main

5 where

6 where

6

7

8

8−import Control.Applicative ((<|>))

9import Control.Concurrent (readMVar)

10import Control.Monad (liftM2, msum)

11import qualified Data.ByteString as B

20import Network.URI (parseURI)

21import Snap.Core

22import Snap.Http.Server

23−import Snap.Util.CORS

23+import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet)

24−import Snap.Util.FileServe (serveFile)

25import Snap.Util.FileUploads

24import Snap.Util.FileUploads

26import qualified System.Directory as Dir

25import qualified System.Directory as Dir

27−import qualified System.Exit as Exit

28import qualified System.IO.Streams as Stream

26import qualified System.IO.Streams as Stream

29import Text.RawString.QQ (r)

27import Text.RawString.QQ (r)

30

28

31import qualified AST.Source as Src

29import qualified AST.Source as Src

32import qualified AST.Canonical as Can

30import qualified AST.Canonical as Can

33import qualified AST.Optimized as Opt

31import qualified AST.Optimized as Opt

32+import qualified BackgroundWriter as BW

33+import qualified Build

34import qualified Compile

35import qualified Elm.Details as Details

36import qualified Elm.Interface as I

37import qualified Elm.ModuleName as ModuleName

38import qualified Elm.Package as Pkg

39import qualified File

40+import qualified Generate

40import qualified Generate.Html as Html

41import qualified Generate.Html as Html

41import qualified Generate.JavaScript as Generate

42import qualified Generate.JavaScript as Generate

42import qualified Generate.Mode as Mode

43import qualified Generate.Mode as Mode

47import qualified Reporting.Error as Error

48import qualified Reporting.Error as Error

48import qualified Reporting.Error.Import as Import

49import qualified Reporting.Error.Import as Import

49import qualified Reporting.Exit as Exit

50import qualified Reporting.Exit as Exit

51+import qualified Reporting.Task as Task

50

52

51

53

52

54

56main :: IO ()

58main :: IO ()

57main =

59main =

58 do artifacts <- loadArtifacts

60 do artifacts <- loadArtifacts

59− errorJS <- compileErrorViewer artifacts

61+ errorJS <- compileErrorViewer

60 httpServe config $ msum $

62 httpServe config $ msum $

61 [ path "compile" $ compile artifacts

63 [ path "compile" $ compile artifacts

62− , path "compile/error.js" $ writeBS errorJS

64+ , path "compile/errors.js" $ writeBS errorJS

63 , notFound

65 , notFound

64 ]

66 ]

65

67

67config :: Config Snap a

69config :: Config Snap a

68config =

70config =

69 defaultConfig

71 defaultConfig

70− |> setVerbose False

71 |> setPort 8000

72 |> setPort 8000

72 |> setAccessLog ConfigNoLog

73 |> setAccessLog ConfigNoLog

73 |> setErrorLog ConfigNoLog

74 |> setErrorLog ConfigNoLog

96compile :: Artifacts -> Snap ()

97compile :: Artifacts -> Snap ()

97compile artifacts =

98compile artifacts =

98 applyCORS corsOptions $ method POST $

99 applyCORS corsOptions $ method POST $

99− do parts <- handleMultipart defaultUploadPolicy handlePart

100+ do result <- foldMultipart defaultUploadPolicy ignoreFile 0

100− case parts of

101+ case result of

101− [Just source] ->

102+ ([("code",source)], 0) ->

103+ do modifyResponse $ setContentType "text/html; charset=utf-8"

102− case compileToBuilder artifacts source of

104+ case compileToBuilder artifacts source of

103− Right builder -> writeBuilder builder

105+ Right builder -> writeBuilder builder

104− Left exit -> writeBuilder (exitToHtmlBuilder exit)

106+ Left exit -> writeBuilder (exitToHtmlBuilder exit)

105

107

106 _ ->

108 _ ->

107− pass

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>"

108

116

109

117

110−handlePart :: PartInfo -> Stream.InputStream B.ByteString -> IO (Maybe B.ByteString)

118+ignoreFile :: PartInfo -> Stream.InputStream B.ByteString -> Int -> IO Int

111−handlePart info stream =

119+ignoreFile _ _ count =

112− if partFieldName info == "code" && partDisposition info == DispositionFormData

120+ return (count + 1)

113− then Just . LBS.toStrict <$> storeAsLazyByteString stream

114− else return Nothing

115

121

116

122

117exitToHtmlBuilder :: Exit.Worker -> B.Builder

123exitToHtmlBuilder :: Exit.Worker -> B.Builder

124<html>

130<html>

125<head>

131<head>

126 <meta charset="UTF-8">

132 <meta charset="UTF-8">

127− <style>body { padding: 0; margin: 0; }</style>

133+ <style>body { padding: 0; margin: 0; background-color: black; }</style>

128− <script src="https://worker.elm-lang.org/compile/error.js"></script>

134+ <script src="http://localhost:8000/compile/errors.js"></script>

129− <script>Elm.Error.init({flags:|] <> json <> [r|})</script>

130</head>

135</head>

131−<body></body>

136+<body>

137+ <script>Elm.Errors.init({flags:|] <> json <> [r|});</script>

138+</body>

132</html>|]

139</html>|]

133

140

134

141

152 Left err ->

159 Left err ->

153 Left $ toInputError (Src.getName modul) source err

160 Left $ toInputError (Src.getName modul) source err

154

161

155− Right artifacts@(Compile.Artifacts modul _ locals) ->

162+ Right (Compile.Artifacts canModule _ locals) ->

156 case locals of

163 case locals of

157 Opt.LocalGraph Nothing _ _ ->

164 Opt.LocalGraph Nothing _ _ ->

158 Left Exit.WorkerNoMain

165 Left Exit.WorkerNoMain

159

166

160− Opt.LocalGraph (Just main) _ _ ->

167+ Opt.LocalGraph (Just main_) _ _ ->

161 let

168 let

162 mode = Mode.Dev Nothing

169 mode = Mode.Dev Nothing

163− home = Can._name modul

170+ home = Can._name canModule

164 name = ModuleName._module home

171 name = ModuleName._module home

165− mains = Map.singleton home main

172+ mains = Map.singleton home main_

166 graph = Opt.addLocalGraph locals objects

173 graph = Opt.addLocalGraph locals objects

167 in

174 in

168 Right $ Html.sandwich name $ Generate.generate mode graph mains

175 Right $ Html.sandwich name $ Generate.generate mode graph mains

197-- COMPILE ERROR VIEWER

204-- COMPILE ERROR VIEWER

198

205

199

206

200−compileErrorViewer :: Artifacts -> IO B.ByteString

207+compileErrorViewer :: IO B.ByteString

201−compileErrorViewer artifacts =

208+compileErrorViewer =

202− do source <- File.readUtf8 "src/Error.elm"

209+ let

203− case compileToBuilder artifacts source of

210+ run work =

204− Left exit ->

211+ do result <- work

205− do putStrLn "Problem in src/Error.elm"

212+ case result of

206− Exit.toStderr (Exit.workerToReport exit)

213+ Right a -> return a

207− Exit.exitFailure

214+ Left _ -> error "problem building reactor/src/Errors.elm"

208−

215+ in

209− Right builder ->

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

210− return (LBS.toStrict (B.toLazyByteString builder))

221+ return $ LBS.toStrict $ B.toLazyByteString javascript

211

222

212

223

213

224

250

261

251loadArtifacts :: IO Artifacts

262loadArtifacts :: IO Artifacts

252loadArtifacts =

263loadArtifacts =

264+ BW.withScope $ \scope ->

253 do style <- Reporting.terminal

265 do style <- Reporting.terminal

254 root <- Dir.getCurrentDirectory

266 root <- Dir.getCurrentDirectory

255− result <- Details.load style root

267+ result <- Details.load style scope root

256 case result of

268 case result of

257 Left _ ->

269 Left _ ->

258 error "Ran into some problem loading elm.json details"

270 error "Ran into some problem loading elm.json details"