git.iko.soy/elk
on 4de92ef help sign in
elk/builder/src/Generate.hs
201 lines 6.2 kB history raw
1{-# LANGUAGE BangPatterns #-}
2module Generate
3 ( debug
4 , dev
5 , prod
6 )
7 where
10import Prelude hiding (cycle, print)
11import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
12import Control.Monad (liftM2)
13import qualified Data.ByteString.Builder as B
14import qualified Data.Map as Map
15import qualified Data.Maybe as Maybe
16import qualified Data.NonEmptyList as NE
18import qualified AST.Optimized as Opt
19import qualified Build
20import qualified Elm.Compiler.Type.Extract as Extract
21import qualified Elm.Details as Details
22import qualified Elm.Interface as I
23import qualified Elm.ModuleName as ModuleName
24import qualified Elm.Package as Pkg
25import qualified File
26import qualified Generate.JavaScript as JS
27import qualified Generate.Mode as Mode
28import qualified Nitpick.Debug as Nitpick
29import qualified Reporting.Exit as Exit
30import qualified Reporting.Task as Task
31import qualified Stuff
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?
40-- GENERATORS
43type Task a =
44 Task.Task Exit.Generate a
47debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
48debug 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
58dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
59dev 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
67prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
68prod 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
78-- CHECK FOR DEBUG
81checkForDebugUses :: Objects -> Task ()
82checkForDebugUses (Objects _ locals) =
83 case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
84 [] -> return ()
85 m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
89-- GATHER MAINS
92gatherMains :: Pkg.Name -> Objects -> NE.List Build.Main -> Map.Map ModuleName.Canonical Opt.Main
93gatherMains pkg (Objects _ locals) buildMains =
94 Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList buildMains)
97lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Main -> Maybe (ModuleName.Canonical, Opt.Main)
98lookupMain 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
109-- LOADING OBJECTS
112data LoadingObjects =
113 LoadingObjects
114 { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
115 , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
116 }
119loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
120loadObjects 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)
127loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
128loadObject root modul =
129 case modul of
130 Build.Fresh name _ graph ->
131 do mvar <- newMVar (Just graph)
132 return (name, mvar)
134 Build.Cached name _ _ ->
135 do mvar <- newEmptyMVar
136 _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
137 return (name, mvar)
141-- FINALIZE OBJECTS
144data Objects =
145 Objects
146 { _foreign :: Opt.GlobalGraph
147 , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
148 }
151finalizeObjects :: LoadingObjects -> Task Objects
152finalizeObjects (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)
161objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
162objectsToGlobalGraph (Objects globals locals) =
163 foldr Opt.addLocalGraph globals locals
167-- LOAD TYPES
170loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
171loadTypes 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)
181loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
182loadTypesHelp root modul =
183 case modul of
184 Build.Fresh name iface _ ->
185 newMVar (Just (Extract.fromInterface name iface))
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
197 Build.Loaded iface ->
198 newMVar (Just (Extract.fromInterface name iface))
200 Build.Corrupted ->
201 newMVar Nothing