@@ -7,27 +7,30 @@ module Develop
77
88
99import Control.Applicative ((<|>))
10−import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
11−import Control.Monad (guard, void)
10+import Control.Monad (guard)
1211import Control.Monad.Trans (MonadIO(liftIO))
1312import qualified Data.ByteString.Builder as B
1413import qualified Data.ByteString as BS
1514import qualified Data.HashMap.Strict as HashMap
1615import Data.Monoid ((<>))
16+import qualified Data.NonEmptyList as NE
1717import qualified System.Directory as Dir
1818import System.FilePath as FP
19−import Snap.Core
19+import Snap.Core hiding (path)
2020import Snap.Http.Server
2121import Snap.Util.FileServe
2222
23−import qualified Elm.Project as Project
24−import qualified Develop.Generate.Help as Generate
23+import qualified Build
24+import qualified Elm.Details as Details
25+import qualified Develop.Generate.Help as Help
2526import qualified Develop.Generate.Index as Index
2627import 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
2831import qualified Reporting.Exit as Exit
29−import qualified Reporting.Progress as Progress
3032import qualified Reporting.Task as Task
33+import qualified Stuff
3134
3235
3336
@@ -42,31 +45,19 @@ data Flags =
4245
4346run :: () -> Flags -> IO ()
4447run () (Flags maybePort) =
45− let
46− port =
47− maybe 8000 id maybePort
48− in
49− do putStrLn $ "Go to <http://localhost:" ++ show port ++ "> to see your project dashboard."
50−
51− httpServe (config port) $
52− serveFiles
53− <|> serveDirectoryWith directoryConfig "."
54− <|> serveAssets
55− <|> error404
48+ do let port = maybe 8000 id maybePort
49+ putStrLn $ "Go to http://localhost:" ++ show port ++ " to see your project dashboard."
50+ httpServe (config port) $
51+ serveFiles
52+ <|> serveDirectoryWith directoryConfig "."
53+ <|> serveAssets
54+ <|> error404
5655
5756
5857config :: Int -> Config Snap a
5958config port =
60− defaultConfig
61− # setVerbose False
62− # setPort port
63− # setAccessLog ConfigNoLog
64− # setErrorLog ConfigNoLog
65−
66−
67−(#) :: a -> (a -> b) -> b
68−(#) value func =
69− func value
59+ setVerbose False $ setPort port $
60+ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog $ defaultConfig
7061
7162
7263
@@ -75,18 +66,12 @@ config port =
7566
7667directoryConfig :: MonadSnap m => DirectoryConfig m
7768directoryConfig =
78− let
79− customGenerator pwd =
80− do modifyResponse $ setContentType "text/html; charset=utf-8"
81− html <- liftIO $
82− do root <- Dir.getCurrentDirectory
83− Index.get root pwd
84− writeBuilder html
85− in
86− fancyDirectoryConfig
87− { indexFiles = []
88− , indexGenerator = customGenerator
89− }
69+ fancyDirectoryConfig
70+ { indexFiles = []
71+ , indexGenerator = \pwd ->
72+ do modifyResponse $ setContentType "text/html;charset=utf-8"
73+ writeBuilder =<< liftIO (Index.generate pwd)
74+ }
9075
9176
9277
@@ -96,8 +81,8 @@ directoryConfig =
9681error404 :: Snap ()
9782error404 =
9883 do modifyResponse $ setResponseStatus 404 "Not Found"
99− modifyResponse $ setContentType "text/html; charset=utf-8"
100− writeBuilder $ Generate.makePageHtml "NotFound" Nothing
84+ modifyResponse $ setContentType "text/html;charset=utf-8"
85+ writeBuilder $ Help.makePageHtml "NotFound" Nothing
10186
10287
10388
@@ -106,9 +91,9 @@ error404 =
10691
10792serveFiles :: Snap ()
10893serveFiles =
109− do file <- getSafePath
110− guard =<< liftIO (Dir.doesFileExist file)
111− serveElm file <|> serveFilePretty file
94+ do path <- getSafePath
95+ guard =<< liftIO (Dir.doesFileExist path)
96+ serveElm path <|> serveFilePretty path
11297
11398
11499
@@ -116,34 +101,33 @@ serveFiles =
116101
117102
118103serveFilePretty :: FilePath -> Snap ()
119−serveFilePretty file =
104+serveFilePretty path =
120105 let
121106 possibleExtensions =
122− getSubExts (takeExtensions file)
107+ getSubExts (takeExtensions path)
123108 in
124109 case mconcat (map lookupMimeType possibleExtensions) of
125110 Nothing ->
126− serveCode file
111+ serveCode path
127112
128113 Just mimeType ->
129− serveFileAs mimeType file
114+ serveFileAs mimeType path
130115
131116
132117getSubExts :: String -> [String]
133118getSubExts fullExtension =
134119 if null fullExtension then
135120 []
136−
137121 else
138122 fullExtension : getSubExts (takeExtensions (drop 1 fullExtension))
139123
140124
141125serveCode :: String -> Snap ()
142−serveCode file =
143− do code <- liftIO (BS.readFile file)
126+serveCode path =
127+ do code <- liftIO (BS.readFile path)
144128 modifyResponse (setContentType "text/html")
145129 writeBuilder $
146− Generate.makeCodeHtml ('~' : '/' : file) (B.byteString code)
130+ Help.makeCodeHtml ('~' : '/' : path) (B.byteString code)
147131
148132
149133
@@ -151,31 +135,27 @@ serveCode file =
151135
152136
153137serveElm :: FilePath -> Snap ()
154−serveElm file =
155− do guard (takeExtension file == ".elm")
138+serveElm path =
139+ do guard (takeExtension path == ".elm")
156140 modifyResponse (setContentType "text/html")
157− writeBuilder =<< liftIO (compileToHtmlBuilder file)
158−
159−
160−compileToHtmlBuilder :: FilePath -> IO B.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)
141+ result <- liftIO $ Task.run $ compile path
142+ case result of
143+ Right builder ->
144+ writeBuilder builder
167145
168− void $ Task.try reporter $
169− do summary <- Project.getRoot
170− Project.compile Output.Dev Output.Client output summary [file]
146+ Left exit ->
147+ writeBuilder $ Help.makePageHtml "Errors" $ Just $
148+ Exit.toJson $ Exit.reactorToReport exit
171149
172− result <- takeMVar mvar1
173− case result of
174− Just exit ->
175− return $ Generate.makePageHtml "Errors" (Just (Exit.toJson exit))
176150
177− Nothing ->
178− takeMVar mvar2
151+compile :: FilePath -> Task.Task Exit.Reactor B.Builder
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
179159
180160
181161
@@ -184,8 +164,8 @@ compileToHtmlBuilder file =
184164
185165serveAssets :: Snap ()
186166serveAssets =
187− do file <- getSafePath
188− case StaticFiles.lookup file of
167+ do path <- getSafePath
168+ case StaticFiles.lookup path of
189169 Nothing ->
190170 pass
191171
@@ -260,4 +240,3 @@ mimeTypeDict =
260240 , ".xwd" ==> "image/x-xwindowdump"
261241 , ".zip" ==> "application/zip"
262242 ]
263−