5222440 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

get reactor hooked up to new build/generate code

5222440Evan Czaplicki7 years ago

terminal/src/Develop.hs+56−77

compare with master

unifiedsplit

@@ -7,27 +7,30 @@ module Develop

9import Control.Applicative ((<|>))

10−import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)

11−import Control.Monad (guard, void)

10+import Control.Monad (guard)

12import Control.Monad.Trans (MonadIO(liftIO))

11import Control.Monad.Trans (MonadIO(liftIO))

13import qualified Data.ByteString.Builder as B

12import qualified Data.ByteString.Builder as B

14import qualified Data.ByteString as BS

13import qualified Data.ByteString as BS

15import qualified Data.HashMap.Strict as HashMap

14import qualified Data.HashMap.Strict as HashMap

16import Data.Monoid ((<>))

15import Data.Monoid ((<>))

16+import qualified Data.NonEmptyList as NE

17import qualified System.Directory as Dir

18import System.FilePath as FP

19−import Snap.Core

19+import Snap.Core hiding (path)

20import Snap.Http.Server

21import Snap.Util.FileServe

23−import qualified Elm.Project as Project

23+import qualified Build

24+import qualified Elm.Details as Details

24−import qualified Develop.Generate.Help as Generate

25+import qualified Develop.Generate.Help as Help

25import qualified Develop.Generate.Index as Index

26import qualified Develop.Generate.Index as Index

26import qualified Develop.StaticFiles as StaticFiles

27import qualified Develop.StaticFiles as StaticFiles

27−import qualified Generate.Output as Output

28+import qualified Generate.Html as Html

29+import qualified Generate

30+import qualified Reporting

28import qualified Reporting.Exit as Exit

31import qualified Reporting.Exit as Exit

29−import qualified Reporting.Progress as Progress

30import qualified Reporting.Task as Task

32import qualified Reporting.Task as Task

33+import qualified Stuff

@@ -42,31 +45,19 @@ data Flags =

43run :: () -> Flags -> IO ()

46run :: () -> Flags -> IO ()

44run () (Flags maybePort) =

47run () (Flags maybePort) =

45− let

46− port =

47− maybe 8000 id maybePort

48+ do let port = maybe 8000 id maybePort

48− in

49− do putStrLn $ "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."

49+ putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard."

50−

51− httpServe (config port) $

50+ httpServe (config port) $

52− serveFiles

51+ serveFiles

53− <|> serveDirectoryWith directoryConfig "."

52+ <|> serveDirectoryWith directoryConfig "."

54− <|> serveAssets

53+ <|> serveAssets

55− <|> error404

54+ <|> error404

58config :: Int -> Config Snap a

57config :: Int -> Config Snap a

59config port =

58config port =

60− defaultConfig

61− # setVerbose False

59+ setVerbose False $ setPort port $

62− # setPort port

63− # setAccessLog ConfigNoLog

60+ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig

64− # setErrorLog ConfigNoLog

65−

66−

67−(#) :: a -> (a -> b) -> b

68−(#) value func =

69− func value

@@ -75,18 +66,12 @@ config port =

76directoryConfig :: MonadSnap m => DirectoryConfig m

67directoryConfig :: MonadSnap m => DirectoryConfig m

77directoryConfig =

68directoryConfig =

78− let

69+ fancyDirectoryConfig

79− customGenerator pwd =

70+ { indexFiles = []

71+ , indexGenerator = \pwd ->

80− do modifyResponse $ setContentType "text/html; charset=utf-8"

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

81− html <- liftIO $

82− do root <- Dir.getCurrentDirectory

83− Index.get root pwd

84− writeBuilder html

73+ writeBuilder =<< liftIO (Index.generate pwd)

85− in

86− fancyDirectoryConfig

87− { indexFiles = []

88− , indexGenerator = customGenerator

89− }

74+ }

@@ -96,8 +81,8 @@ directoryConfig =

96error404 :: Snap ()

81error404 :: Snap ()

97error404 =

82error404 =

98 do modifyResponse $ setResponseStatus 404 "Not Found"

83 do modifyResponse $ setResponseStatus 404 "Not Found"

99− modifyResponse $ setContentType "text/html; charset=utf-8"

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

100− writeBuilder $ Generate.makePageHtml "NotFound" Nothing

85+ writeBuilder $ Help.makePageHtml "NotFound" Nothing

101

102

103

@@ -106,9 +91,9 @@ error404 =

106

107serveFiles :: Snap ()

92serveFiles :: Snap ()

108serveFiles =

93serveFiles =

109− do file <- getSafePath

94+ do path <- getSafePath

110− guard =<< liftIO (Dir.doesFileExist file)

95+ guard =<< liftIO (Dir.doesFileExist path)

111− serveElm file <|> serveFilePretty file

96+ serveElm path <|> serveFilePretty path

112

113

114

@@ -116,34 +101,33 @@ serveFiles =

116

101

117

102

118serveFilePretty :: FilePath -> Snap ()

103serveFilePretty :: FilePath -> Snap ()

119−serveFilePretty file =

104+serveFilePretty path =

120 let

105 let

121 possibleExtensions =

106 possibleExtensions =

122− getSubExts (takeExtensions file)

107+ getSubExts (takeExtensions path)

123 in

108 in

124 case mconcat (map lookupMimeType possibleExtensions) of

109 case mconcat (map lookupMimeType possibleExtensions) of

125 Nothing ->

110 Nothing ->

126− serveCode file

111+ serveCode path

127

112

128 Just mimeType ->

113 Just mimeType ->

129− serveFileAs mimeType file

114+ serveFileAs mimeType path

130

115

131

116

132getSubExts :: String -> [String]

117getSubExts :: String -> [String]

133getSubExts fullExtension =

118getSubExts fullExtension =

134 if null fullExtension then

119 if null fullExtension then

135 []

120 []

136−

137 else

121 else

138 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))

122 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))

139

123

140

124

141serveCode :: String -> Snap ()

125serveCode :: String -> Snap ()

142−serveCode file =

126+serveCode path =

143− do code <- liftIO (BS.readFile file)

127+ do code <- liftIO (BS.readFile path)

144 modifyResponse (setContentType "text/html")

128 modifyResponse (setContentType "text/html")

145 writeBuilder $

129 writeBuilder $

146− Generate.makeCodeHtml ('~' : '/' : file) (B.byteString code)

130+ Help.makeCodeHtml ('~' : '/' : path) (B.byteString code)

147

131

148

132

149

133

@@ -151,31 +135,27 @@ serveCode file =

151

135

152

136

153serveElm :: FilePath -> Snap ()

137serveElm :: FilePath -> Snap ()

154−serveElm file =

138+serveElm path =

155− do guard (takeExtension file == ".elm")

139+ do guard (takeExtension path == ".elm")

156 modifyResponse (setContentType "text/html")

140 modifyResponse (setContentType "text/html")

157− writeBuilder =<< liftIO (compileToHtmlBuilder file)

141+ result <- liftIO $ Task.run $ compile path

158−

142+ case result of

159−

143+ Right builder ->

160−compileToHtmlBuilder :: FilePath -> IO B.Builder

144+ writeBuilder builder

161−compileToHtmlBuilder file =

162− do mvar1 <- newEmptyMVar

163− mvar2 <- newEmptyMVar

164−

165− let reporter = Progress.Reporter (\_ -> return ()) (\_ -> return True) (putMVar mvar1)

166− let output = Just (Output.HtmlBuilder mvar2)

167

145

168− void $ Task.try reporter $

146+ Left exit ->

169− do summary <- Project.getRoot

147+ writeBuilder $ Help.makePageHtml "Errors" $ Just $

170− Project.compile Output.Dev Output.Client output summary [file]

148+ Exit.toJson $ Exit.reactorToReport exit

171

149

172− result <- takeMVar mvar1

173− case result of

174− Just exit ->

175− return $ Generate.makePageHtml "Errors" (Just (Exit.toJson exit))

176

150

177− Nothing ->

151+compile :: FilePath -> Task.Task Exit.Reactor B.Builder

178− takeMVar mvar2

152+compile path =

153+ do root <- Task.mio Exit.ReactorNoOutline Stuff.findRoot

154+ details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent root

155+ artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromMains Reporting.silent root details (NE.List path [])

156+ javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts

157+ let (NE.List name _) = Build.getMainNames artifacts

158+ return $ Html.sandwich name javascript

179

159

180

160

181

161

@@ -184,8 +164,8 @@ compileToHtmlBuilder file =

184

164

185serveAssets :: Snap ()

165serveAssets :: Snap ()

186serveAssets =

166serveAssets =

187− do file <- getSafePath

167+ do path <- getSafePath

188− case StaticFiles.lookup file of

168+ case StaticFiles.lookup path of

189 Nothing ->

169 Nothing ->

190 pass

170 pass

191

171

@@ -260,4 +240,3 @@ mimeTypeDict =

260 , ".xwd" ==> "image/x-xwindowdump"

240 , ".xwd" ==> "image/x-xwindowdump"

261 , ".zip" ==> "application/zip"

241 , ".zip" ==> "application/zip"

262 ]

242 ]

263−