git.iko.soy/elk
on master help sign in
move logic for loading object files into new builder/Generate module
4de92efEvan Czaplicki
builder/src/Generate.hsnew file+201
compare with master
unifiedsplit
@@ -0,0 +1,201 @@
1+{-# LANGUAGE BangPatterns #-}
2+module Generate
3+ ( debug
4+ , dev
5+ , prod
6+ )
7+ where
8+
9+
10+import Prelude hiding (cycle, print)
11+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
12+import Control.Monad (liftM2)
13+import qualified Data.ByteString.Builder as B
14+import qualified Data.Map as Map
15+import qualified Data.Maybe as Maybe
16+import qualified Data.NonEmptyList as NE
17+
18+import qualified AST.Optimized as Opt
19+import qualified Build
20+import qualified Elm.Compiler.Type.Extract as Extract
21+import qualified Elm.Details as Details
22+import qualified Elm.Interface as I
23+import qualified Elm.ModuleName as ModuleName
24+import qualified Elm.Package as Pkg
25+import qualified File
26+import qualified Generate.JavaScript as JS
27+import qualified Generate.Mode as Mode
28+import qualified Nitpick.Debug as Nitpick
29+import qualified Reporting.Exit as Exit
30+import qualified Reporting.Task as Task
31+import qualified Stuff
32+
33+
34+-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
35+-- desireable to have Repl and Reactor to keep foreign objects in memory
36+-- to make things a bit faster?
37+
38+
39+
40+-- GENERATORS
41+
42+
43+type Task a =
44+ Task.Task Exit.Generate a
45+
46+
47+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
48+debug root details (Build.Artifacts pkg ifaces roots modules) =
49+ do loading <- loadObjects root details modules
50+ types <- loadTypes root ifaces modules
51+ objects <- finalizeObjects loading
52+ let mode = Mode.Dev (Just types)
53+ let graph = objectsToGlobalGraph objects
54+ let mains = gatherMains pkg objects roots
55+ return $ JS.generate mode graph mains
56+
57+
58+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
59+dev root details (Build.Artifacts pkg _ roots modules) =
60+ do objects <- finalizeObjects =<< loadObjects root details modules
61+ let mode = Mode.Dev Nothing
62+ let graph = objectsToGlobalGraph objects
63+ let mains = gatherMains pkg objects roots
64+ return $ JS.generate mode graph mains
65+
66+
67+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
68+prod root details (Build.Artifacts pkg _ roots modules) =
69+ do objects <- finalizeObjects =<< loadObjects root details modules
70+ checkForDebugUses objects
71+ let graph = objectsToGlobalGraph objects
72+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
73+ let mains = gatherMains pkg objects roots
74+ return $ JS.generate mode graph mains
75+
76+
77+
78+-- CHECK FOR DEBUG
79+
80+
81+checkForDebugUses :: Objects -> Task ()
82+checkForDebugUses (Objects _ locals) =
83+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
84+ [] -> return ()
85+ m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
86+
87+
88+
89+-- GATHER MAINS
90+
91+
92+gatherMains :: Pkg.Name -> Objects -> NE.List Build.Main -> Map.Map ModuleName.Canonical Opt.Main
93+gatherMains pkg (Objects _ locals) buildMains =
94+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList buildMains)
95+
96+
97+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Main -> Maybe (ModuleName.Canonical, Opt.Main)
98+lookupMain pkg locals buildMain =
99+ let
100+ toPair name (Opt.LocalGraph maybeMain _ _) =
101+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
102+ in
103+ case buildMain of
104+ Build.Inside name -> toPair name =<< Map.lookup name locals
105+ Build.Outside name _ g -> toPair name g
106+
107+
108+
109+-- LOADING OBJECTS
110+
111+
112+data LoadingObjects =
113+ LoadingObjects
114+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
115+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
116+ }
117+
118+
119+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
120+loadObjects root details modules =
121+ Task.io $
122+ do mvar <- Details.loadObjects root details
123+ mvars <- traverse (loadObject root) modules
124+ return $ LoadingObjects mvar (Map.fromList mvars)
125+
126+
127+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
128+loadObject root modul =
129+ case modul of
130+ Build.Fresh name _ graph ->
131+ do mvar <- newMVar (Just graph)
132+ return (name, mvar)
133+
134+ Build.Cached name _ _ ->
135+ do mvar <- newEmptyMVar
136+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
137+ return (name, mvar)
138+
139+
140+
141+-- FINALIZE OBJECTS
142+
143+
144+data Objects =
145+ Objects
146+ { _foreign :: Opt.GlobalGraph
147+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
148+ }
149+
150+
151+finalizeObjects :: LoadingObjects -> Task Objects
152+finalizeObjects (LoadingObjects mvar mvars) =
153+ Task.eio id $
154+ do result <- readMVar mvar
155+ results <- traverse readMVar mvars
156+ case liftM2 Objects result (sequence results) of
157+ Just loaded -> return (Right loaded)
158+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
159+
160+
161+objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
162+objectsToGlobalGraph (Objects globals locals) =
163+ foldr Opt.addLocalGraph globals locals
164+
165+
166+
167+-- LOAD TYPES
168+
169+
170+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
171+loadTypes root ifaces modules =
172+ Task.eio id $
173+ do mvars <- traverse (loadTypesHelp root) modules
174+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
175+ results <- traverse readMVar mvars
176+ case sequence results of
177+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
178+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
179+
180+
181+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
182+loadTypesHelp root modul =
183+ case modul of
184+ Build.Fresh name iface _ ->
185+ newMVar (Just (Extract.fromInterface name iface))
186+
187+ Build.Cached name _ ciMVar ->
188+ do cachedInterface <- readMVar ciMVar
189+ case cachedInterface of
190+ Build.Unneeded ->
191+ do mvar <- newEmptyMVar
192+ _ <- forkIO $
193+ do maybeIface <- File.readBinary (Stuff.elmo root name)
194+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
195+ return mvar
196+
197+ Build.Loaded iface ->
198+ newMVar (Just (Extract.fromInterface name iface))
199+
200+ Build.Corrupted ->
201+ newMVar Nothing
terminal/src/Make.hs+10−175
@@ -1,4 +1,4 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
2module Make
2module Make
3 ( Flags(..)
3 ( Flags(..)
4 , Output(..)
4 , Output(..)
@@ -11,26 +11,18 @@ module Make
11 where
11 where
12
12
13
13
14−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
15−import Control.Monad (liftM2)
16import qualified Data.ByteString.Builder as B
14import qualified Data.ByteString.Builder as B
17−import qualified Data.Map as Map
18import qualified Data.Maybe as Maybe
15import qualified Data.Maybe as Maybe
19import qualified Data.NonEmptyList as NE
16import qualified Data.NonEmptyList as NE
20import qualified System.FilePath as FP
17import qualified System.FilePath as FP
21
18
22import qualified AST.Optimized as Opt
19import qualified AST.Optimized as Opt
23import qualified Build
20import qualified Build
24−import qualified Elm.Compiler.Type.Extract as Extract
25import qualified Elm.Details as Details
21import qualified Elm.Details as Details
26−import qualified Elm.Interface as I
27import qualified Elm.ModuleName as ModuleName
22import qualified Elm.ModuleName as ModuleName
28−import qualified Elm.Package as Pkg
29import qualified File
23import qualified File
24+import qualified Generate
30import qualified Generate.Html as Html
25import 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
34import qualified Reporting
26import qualified Reporting
35import qualified Reporting.Exit as Exit
27import qualified Reporting.Exit as Exit
36import qualified Reporting.Task as Task
28import qualified Reporting.Task as Task
@@ -105,7 +97,7 @@ run paths (Flags debug optimize maybeOutput report maybeDocs) =
105 case getNoMains artifacts of
97 case getNoMains artifacts of
106 [] ->
98 [] ->
107 do builder <- toBuilder root details desiredMode artifacts
99 do builder <- toBuilder root details desiredMode artifacts
108− generate style target builder (getMainNames artifacts)
100+ generate style target builder (Build.getMainNames artifacts)
109
101
110 name:names ->
102 name:names ->
111 Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
103 Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
@@ -133,10 +125,7 @@ getStyle report =
133
125
134getRoot :: Task FilePath
126getRoot :: Task FilePath
135getRoot =
127getRoot =
136− do maybeRoot <- Task.io Stuff.findRoot
128+ Task.mio Exit.MakeNoOutline Stuff.findRoot
137− case maybeRoot of
138− Nothing -> Task.throw Exit.MakeNeedsOutline
139− Just root -> return root
140
129
141
130
142getMode :: Bool -> Bool -> Task DesiredMode
131getMode :: Bool -> Bool -> Task DesiredMode
@@ -252,22 +241,6 @@ getNoMain modules main =
252
241
253
242
254
243
255−-- GET MAIN NAMES
256−
257−
258−getMainNames :: Build.Artifacts -> NE.List ModuleName.Raw
259−getMainNames (Build.Artifacts _ _ mains _) =
260− fmap getMainName mains
261−
262−
263−getMainName :: Build.Main -> ModuleName.Raw
264−getMainName main =
265− case main of
266− Build.Inside name -> name
267− Build.Outside name _ _ -> name
268−
269−
270−
271-- GENERATE
244-- GENERATE
272
245
273
246
@@ -286,150 +259,12 @@ data DesiredMode = Debug | Dev | Prod
286
259
287
260
288toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
261toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder
289−toBuilder root details desiredMode (Build.Artifacts pkg ifaces roots modules) =
262+toBuilder root details desiredMode artifacts =
263+ Task.mapError Exit.MakeBadGenerate $
290− case desiredMode of
264+ case desiredMode of
291− Debug ->
265+ Debug -> Generate.debug root details artifacts
292− do loading <- loadObjects root details modules
266+ Dev -> Generate.dev root details artifacts
293− types <- loadTypes root ifaces modules
267+ Prod -> Generate.prod root details artifacts
294− objects <- finalizeObjects loading
295− let mode = Mode.Dev (Just types)
296− let graph = toGlobalGraph objects
297− let mains = gatherMains pkg objects roots
298− return $ Generate.generate mode graph mains
299−
300− Dev ->
301− do objects <- finalizeObjects =<< loadObjects root details modules
302− let mode = Mode.Dev Nothing
303− let graph = toGlobalGraph objects
304− let mains = gatherMains pkg objects roots
305− return $ Generate.generate mode graph mains
306−
307− Prod ->
308− do objects <- finalizeObjects =<< loadObjects root details modules
309− checkForDebugUses objects
310− let graph = toGlobalGraph objects
311− let mode = Mode.Prod (Mode.shortenFieldNames graph)
312− let mains = gatherMains pkg objects roots
313− return $ Generate.generate mode graph mains
314−
315−
316−checkForDebugUses :: LoadedObjects -> Task ()
317−checkForDebugUses (LoadedObjects _ locals) =
318− case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
319− [] -> return ()
320− m:ms -> Task.throw (Exit.MakeCannotOptimizeDebugValues m ms)
321−
322−
323−toGlobalGraph :: LoadedObjects -> Opt.GlobalGraph
324−toGlobalGraph (LoadedObjects globals locals) =
325− foldr Opt.addLocalGraph globals locals
326−
327−
328−
329−-- LOAD OBJECTS
330−
331−
332−data LoadingObjects =
333− LoadingObjects
334− { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
335− , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
336− }
337−
338−
339−loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
340−loadObjects root details modules =
341− Task.io $
342− do mvar <- Details.loadObjects root details
343− mvars <- traverse (loadObject root) modules
344− return $ LoadingObjects mvar (Map.fromList mvars)
345−
346−
347−loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
348−loadObject root modul =
349− case modul of
350− Build.Fresh name _ graph ->
351− do mvar <- newMVar (Just graph)
352− return (name, mvar)
353−
354− Build.Cached name _ _ ->
355− do mvar <- newEmptyMVar
356− _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
357− return (name, mvar)
358−
359−
360−data LoadedObjects =
361− LoadedObjects
362− { _foreign :: Opt.GlobalGraph
363− , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
364− }
365−
366−
367−finalizeObjects :: LoadingObjects -> Task LoadedObjects
368−finalizeObjects (LoadingObjects mvar mvars) =
369− Task.eio id $
370− do result <- readMVar mvar
371− results <- traverse readMVar mvars
372− case liftM2 LoadedObjects result (sequence results) of
373− Just loaded -> return (Right loaded)
374− Nothing -> return (Left Exit.MakeCannotLoadArtifacts)
375−
376−
377−
378−-- LOAD TYPES
379−
380−
381−loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
382−loadTypes root ifaces modules =
383− Task.eio id $
384− do mvars <- traverse (loadTypesHelp root) modules
385− let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
386− results <- traverse readMVar mvars
387− case sequence results of
388− Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
389− Nothing -> return (Left Exit.MakeCannotLoadArtifacts)
390−
391−
392−loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
393−loadTypesHelp root modul =
394− case modul of
395− Build.Fresh name iface _ ->
396− newMVar (Just (Extract.fromInterface name iface))
397−
398− Build.Cached name _ ciMVar ->
399− do cachedInterface <- readMVar ciMVar
400− case cachedInterface of
401− Build.Unneeded ->
402− do mvar <- newEmptyMVar
403− _ <- forkIO $
404− do maybeIface <- File.readBinary (Stuff.elmo root name)
405− putMVar mvar (Extract.fromInterface name <$> maybeIface)
406− return mvar
407−
408− Build.Loaded iface ->
409− newMVar (Just (Extract.fromInterface name iface))
410−
411− Build.Corrupted ->
412− newMVar Nothing
413−
414−
415−
416−-- GATHER MAINS
417−
418−
419−gatherMains :: Pkg.Name -> LoadedObjects -> NE.List Build.Main -> Map.Map ModuleName.Canonical Opt.Main
420−gatherMains pkg (LoadedObjects _ locals) buildMains =
421− Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList buildMains)
422−
423−
424−lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Main -> Maybe (ModuleName.Canonical, Opt.Main)
425−lookupMain pkg locals buildMain =
426− let
427− toPair name (Opt.LocalGraph maybeMain _ _) =
428− (,) (ModuleName.Canonical pkg name) <$> maybeMain
429− in
430− case buildMain of
431− Build.Inside name -> toPair name =<< Map.lookup name locals
432− Build.Outside name _ g -> toPair name g
433
268
434
269
435
270