git.iko.soy/elk
on master help sign in
Update Make for new build process
c911618Evan Czaplicki
terminal/src/Make.hs+421−41
compare with master
unifiedsplit
@@ -1,71 +1,435 @@
1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1module Make
2module Make
2 ( Flags(..)
3 ( Flags(..)
3− , run
4+ , Output(..)
4 , ReportType(..)
5 , ReportType(..)
6+ , run
5 , reportType
7 , reportType
6− , docsFile
8+ , output
7 )
9 )
8 where
10 where
9
11
10
12
13+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
14+import Control.Monad (liftM2)
15+import qualified Data.ByteString.Builder as B
16+import qualified Data.Map as Map
17+import qualified Data.Maybe as Maybe
18+import qualified Data.NonEmptyList as NE
11import qualified System.FilePath as FP
19import qualified System.FilePath as FP
12
20
13−import qualified Elm.Project as Project
21+import qualified AST.Optimized as Opt
22+import qualified Build
23+import qualified Elm.Compiler.Type.Extract as Extract
24+import qualified Elm.Details as Details
25+import qualified Elm.Interface as I
26+import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Outline as Outline
28+import qualified Elm.Package as Pkg
14−import qualified Generate.Output as Output
29+import qualified File
30+import qualified Generate.Html as Html
31+import qualified Generate.JavaScript as Generate
32+import qualified Generate.Mode as Mode
33+import qualified Nitpick.Debug as Nitpick
34+import qualified Reporting
15import qualified Reporting.Exit as Exit
35import qualified Reporting.Exit as Exit
16−import qualified Reporting.Exit.Make as E
17import qualified Reporting.Task as Task
36import qualified Reporting.Task as Task
18−import qualified Reporting.Progress as Progress
37+import qualified Stuff
19−import qualified Reporting.Progress.Json as Json
20−import qualified Reporting.Progress.Terminal as Terminal
21import Terminal.Args (Parser(..))
38import Terminal.Args (Parser(..))
22
39
23
40
24
41
25−-- RUN
42+-- FLAGS
26
43
27
44
28data Flags =
45data Flags =
29 Flags
46 Flags
30 { _debug :: Bool
47 { _debug :: Bool
31 , _optimize :: Bool
48 , _optimize :: Bool
32− , _output :: Maybe Output.Output
49+ , _output :: Maybe Output
33 , _report :: Maybe ReportType
50 , _report :: Maybe ReportType
34− , _docs :: Maybe FilePath
35 }
51 }
36
52
37
53
54+data Output
55+ = JS FilePath
56+ | Html FilePath
57+ | DevNull
58+
59+
60+data ReportType
61+ = Json
62+
63+
64+
65+-- RUN
66+
67+
68+type Task a = Task.Task Exit.Make a
69+
70+
38run :: [FilePath] -> Flags -> IO ()
71run :: [FilePath] -> Flags -> IO ()
39−run paths (Flags debug optimize output report _docs) =
72+run paths (Flags debug optimize maybeOutput report) =
40− do reporter <- toReporter report
73+ do style <- getStyle report
41− Task.run reporter $
74+ Reporting.attemptWithStyle style Exit.makeToReport $ Task.run $
42− do mode <- toMode debug optimize
43− summary <- Project.getRoot
75+ do root <- getRoot
44− Project.compile mode Output.Client output summary paths
76+ desiredMode <- getMode debug optimize
77+ details <- getDetails style root
78+ case paths of
79+ [] ->
80+ do exposed <- getExposed details
81+ _ <- buildExposed style root details exposed
82+ return ()
45
83
84+ p:ps ->
85+ do artifacts <- buildPaths style root details (NE.List p ps)
86+ case maybeOutput of
87+ Nothing ->
88+ case getMains artifacts of
89+ [] ->
90+ return ()
46
91
47−toMode :: Bool -> Bool -> Task.Task Output.Mode
92+ [name] ->
48−toMode debug optimize =
93+ do builder <- toBuilder root details desiredMode artifacts
49− case (debug, optimize) of
94+ generate style "index.html" (Html.sandwich name builder) (NE.List name [])
50− (True , True ) -> Task.throw $ Exit.Make E.CannotOptimizeAndDebug
95+
51− (False, True ) -> return Output.Prod
96+ name:names ->
52− (False, False) -> return Output.Dev
97+ do builder <- toBuilder root details desiredMode artifacts
53− (True , False) -> return Output.Debug
98+ generate style "elm.js" builder (NE.List name names)
54
99
100+ Just DevNull ->
101+ return ()
55
102
103+ Just (JS target) ->
104+ case getNoMains artifacts of
105+ [] ->
106+ do builder <- toBuilder root details desiredMode artifacts
107+ generate style target builder (getMainNames artifacts)
108+
109+ name:names ->
110+ Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
111+
112+ Just (Html target) ->
113+ case hasOneMain artifacts of
114+ Just name ->
115+ do builder <- toBuilder root details desiredMode artifacts
116+ generate style target (Html.sandwich name builder) (NE.List name [])
117+
118+ Nothing ->
119+ Task.throw Exit.MakeMultipleFilesIntoHtml
120+
121+
122+
123+-- GET INFORMATION
124+
125+
56−toReporter :: Maybe ReportType -> IO Progress.Reporter
126+getStyle :: Maybe ReportType -> IO Reporting.Style
57−toReporter report =
127+getStyle report =
58 case report of
128 case report of
59− Nothing -> Terminal.create
129+ Nothing -> Reporting.terminal
60− Just Json -> return Json.reporter
130+ Just Json -> return Reporting.json
61
131
62
132
133+getRoot :: Task FilePath
134+getRoot =
135+ do maybeRoot <- Task.io Stuff.findRoot
136+ case maybeRoot of
137+ Nothing -> Task.throw Exit.MakeNeedsOutline
138+ Just root -> return root
63
139
64−-- REPORT
65
140
141+getMode :: Bool -> Bool -> Task DesiredMode
142+getMode debug optimize =
143+ case (debug, optimize) of
144+ (True , True ) -> Task.throw Exit.MakeCannotOptimizeAndDebug
145+ (True , False) -> return Debug
146+ (False, False) -> return Dev
147+ (False, True ) -> return Prod
148+
149+
150+getDetails :: Reporting.Style -> FilePath -> Task Details.Details
151+getDetails style root =
152+ Task.eio Exit.MakeBlockedByDetailsProblem (Details.load style root)
153+
154+
155+getExposed :: Details.Details -> Task (NE.List ModuleName.Raw)
156+getExposed (Details.Details _ validOutline _ _ _) =
157+ case validOutline of
158+ Details.ValidApp _ ->
159+ Task.throw Exit.MakeAppNeedsFileNames
160+
161+ Details.ValidPkg (Outline.PkgOutline _ _ _ _ exposed _ _ _) _ ->
162+ case Outline.flattenExposed exposed of
163+ [] -> Task.throw Exit.MakePkgNeedsExposing
164+ m:ms -> return (NE.List m ms)
165+
166+
167+
168+-- BUILD PROJECTS
169+
170+
171+buildExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> Task ()
172+buildExposed style root details exposed =
173+ Task.eio Exit.MakeCannotBuild $
174+ Build.fromExposed style root details exposed
175+
176+
177+buildPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> Task Build.Artifacts
178+buildPaths style root details paths =
179+ Task.eio Exit.MakeCannotBuild $
180+ Build.fromMains style root details paths
181+
182+
183+
184+-- GET MAINS
185+
186+
187+getMains :: Build.Artifacts -> [ModuleName.Raw]
188+getMains (Build.Artifacts _ _ mains modules) =
189+ Maybe.mapMaybe (getMain modules) (NE.toList mains)
190+
191+
192+getMain :: [Build.Module] -> Build.Main -> Maybe ModuleName.Raw
193+getMain modules main =
194+ case main of
195+ Build.Inside name ->
196+ if any (isMain name) modules
197+ then Just name
198+ else Nothing
199+
200+ Build.Outside name _ (Opt.LocalGraph maybeMain _ _) ->
201+ case maybeMain of
202+ Just _ -> Just name
203+ Nothing -> Nothing
204+
205+
206+isMain :: ModuleName.Raw -> Build.Module -> Bool
207+isMain targetName modul =
208+ case modul of
209+ Build.Fresh name _ (Opt.LocalGraph maybeMain _ _) ->
210+ Maybe.isJust maybeMain && name == targetName
211+
212+ Build.Cached name mainIsDefined _ ->
213+ mainIsDefined && name == targetName
214+
215+
216+
217+-- HAS ONE MAIN
218+
219+
220+hasOneMain :: Build.Artifacts -> Maybe ModuleName.Raw
221+hasOneMain (Build.Artifacts _ _ mains modules) =
222+ case mains of
223+ NE.List main [] -> getMain modules main
224+ NE.List _ (_:_) -> Nothing
225+
226+
227+
228+-- GET MAINLESS
229+
230+
231+getNoMains :: Build.Artifacts -> [ModuleName.Raw]
232+getNoMains (Build.Artifacts _ _ mains modules) =
233+ Maybe.mapMaybe (getNoMain modules) (NE.toList mains)
234+
235+
236+getNoMain :: [Build.Module] -> Build.Main -> Maybe ModuleName.Raw
237+getNoMain modules main =
238+ case main of
239+ Build.Inside name ->
240+ if any (isMain name) modules
241+ then Nothing
242+ else Just name
243+
244+ Build.Outside name _ (Opt.LocalGraph maybeMain _ _) ->
245+ case maybeMain of
246+ Just _ -> Nothing
247+ Nothing -> Just name
248+
249+
250+
251+-- GET MAIN NAMES
66
252
67−data ReportType
253+
68− = Json
254+getMainNames :: Build.Artifacts -> NE.List ModuleName.Raw
255+getMainNames (Build.Artifacts _ _ mains _) =
256+ fmap getMainName mains
257+
258+
259+getMainName :: Build.Main -> ModuleName.Raw
260+getMainName main =
261+ case main of
262+ Build.Inside name -> name
263+ Build.Outside name _ _ -> name
264+
265+
266+
267+-- GENERATE
268+
269+
270+generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task ()
271+generate style target builder names =
272+ Task.io $
273+ do File.writeBuilder target builder
274+ Reporting.reportGenerate style names target
275+
276+
277+
278+-- TO BUILDER
279+
280+
281+data DesiredMode = Debug | Dev | Prod
282+
283+
284+toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
285+toBuilder root details desiredMode (Build.Artifacts pkg ifaces roots modules) =
286+ case desiredMode of
287+ Debug ->
288+ do loading <- loadObjects root details modules
289+ types <- loadTypes root ifaces modules
290+ objects <- finalizeObjects loading
291+ let mode = Mode.Dev (Just types)
292+ let graph = toGlobalGraph objects
293+ let mains = gatherMains pkg objects roots
294+ return $ Generate.generate mode graph mains
295+
296+ Dev ->
297+ do objects <- finalizeObjects =<< loadObjects root details modules
298+ let mode = Mode.Dev Nothing
299+ let graph = toGlobalGraph objects
300+ let mains = gatherMains pkg objects roots
301+ return $ Generate.generate mode graph mains
302+
303+ Prod ->
304+ do objects <- finalizeObjects =<< loadObjects root details modules
305+ checkForDebugUses objects
306+ let graph = toGlobalGraph objects
307+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
308+ let mains = gatherMains pkg objects roots
309+ return $ Generate.generate mode graph mains
310+
311+
312+checkForDebugUses :: LoadedObjects -> Task ()
313+checkForDebugUses (LoadedObjects _ locals) =
314+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
315+ [] -> return ()
316+ m:ms -> Task.throw (Exit.MakeCannotOptimizeDebugValues m ms)
317+
318+
319+toGlobalGraph :: LoadedObjects -> Opt.GlobalGraph
320+toGlobalGraph (LoadedObjects globals locals) =
321+ foldr Opt.addLocalGraph globals locals
322+
323+
324+
325+-- LOAD OBJECTS
326+
327+
328+data LoadingObjects =
329+ LoadingObjects
330+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
331+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
332+ }
333+
334+
335+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
336+loadObjects root details modules =
337+ Task.io $
338+ do mvar <- Details.loadObjects root details
339+ mvars <- traverse (loadObject root) modules
340+ return $ LoadingObjects mvar (Map.fromList mvars)
341+
342+
343+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
344+loadObject root modul =
345+ case modul of
346+ Build.Fresh name _ graph ->
347+ do mvar <- newMVar (Just graph)
348+ return (name, mvar)
349+
350+ Build.Cached name _ _ ->
351+ do mvar <- newEmptyMVar
352+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
353+ return (name, mvar)
354+
355+
356+data LoadedObjects =
357+ LoadedObjects
358+ { _foreign :: Opt.GlobalGraph
359+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
360+ }
361+
362+
363+finalizeObjects :: LoadingObjects -> Task LoadedObjects
364+finalizeObjects (LoadingObjects mvar mvars) =
365+ Task.eio id $
366+ do result <- readMVar mvar
367+ results <- traverse readMVar mvars
368+ case liftM2 LoadedObjects result (sequence results) of
369+ Just loaded -> return (Right loaded)
370+ Nothing -> return (Left Exit.MakeCannotLoadArtifacts)
371+
372+
373+
374+-- LOAD TYPES
375+
376+
377+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
378+loadTypes root ifaces modules =
379+ Task.eio id $
380+ do mvars <- traverse (loadTypesHelp root) modules
381+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
382+ results <- traverse readMVar mvars
383+ case sequence results of
384+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
385+ Nothing -> return (Left Exit.MakeCannotLoadArtifacts)
386+
387+
388+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
389+loadTypesHelp root modul =
390+ case modul of
391+ Build.Fresh name iface _ ->
392+ newMVar (Just (Extract.fromInterface name iface))
393+
394+ Build.Cached name _ ciMVar ->
395+ do cachedInterface <- readMVar ciMVar
396+ case cachedInterface of
397+ Build.Unneeded ->
398+ do mvar <- newEmptyMVar
399+ _ <- forkIO $
400+ do maybeIface <- File.readBinary (Stuff.elmo root name)
401+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
402+ return mvar
403+
404+ Build.Loaded iface ->
405+ newMVar (Just (Extract.fromInterface name iface))
406+
407+ Build.Corrupted ->
408+ newMVar Nothing
409+
410+
411+
412+-- GATHER MAINS
413+
414+
415+gatherMains :: Pkg.Name -> LoadedObjects -> NE.List Build.Main -> Map.Map ModuleName.Canonical Opt.Main
416+gatherMains pkg (LoadedObjects _ locals) buildMains =
417+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList buildMains)
418+
419+
420+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Main -> Maybe (ModuleName.Canonical, Opt.Main)
421+lookupMain pkg locals buildMain =
422+ let
423+ toPair name (Opt.LocalGraph maybeMain _ _) =
424+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
425+ in
426+ case buildMain of
427+ Build.Inside name -> toPair name =<< Map.lookup name locals
428+ Build.Outside name _ g -> toPair name g
429+
430+
431+
432+-- PARSERS
69
433
70
434
71reportType :: Parser ReportType
435reportType :: Parser ReportType
@@ -79,16 +443,32 @@ reportType =
79 }
443 }
80
444
81
445
82−
446+output :: Parser Output
83−-- DOCS
447+output =
84−
85−
86−docsFile :: Parser FilePath
87−docsFile =
88 Parser
448 Parser
89− { _singular = "json file"
449+ { _singular = "output file"
90− , _plural = "json files"
450+ , _plural = "output files"
91− , _parser = \string -> if FP.takeExtension string == ".json" then Just string else Nothing
451+ , _parser = parseOutput
92 , _suggest = \_ -> return []
452 , _suggest = \_ -> return []
93− , _examples = \_ -> return ["docs.json","documentation.json"]
453+ , _examples = exampleOutput
94 }
454 }
455+
456+
457+parseOutput :: String -> Maybe Output
458+parseOutput string =
459+ if string == "/dev/null" || string == "NUL" || string == "$null" then
460+ Just DevNull
461+
462+ else if FP.takeExtension string == ".html" && length string > 5 then
463+ Just (Html string)
464+
465+ else if FP.takeExtension string == ".js" && length string > 3 then
466+ Just (JS string)
467+
468+ else
469+ Nothing
470+
471+
472+exampleOutput :: String -> IO [String]
473+exampleOutput _ =
474+ return [ "elm.js", "index.html", "/dev/null" ]