git.iko.soy/elk
on master help sign in
elk/builder/src/Generate.hs
211 lines 6.6 kB history raw
1{-# LANGUAGE BangPatterns #-}
2module Generate
3 ( debug
4 , dev
5 , prod
6 , repl
7 )
8 where
11import Prelude hiding (cycle, print)
12import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13import Control.Monad (liftM2)
14import qualified Data.ByteString.Builder as B
15import Data.Map ((!))
16import qualified Data.Map as Map
17import qualified Data.Maybe as Maybe
18import qualified Data.Name as N
19import qualified Data.NonEmptyList as NE
21import qualified AST.Optimized as Opt
22import qualified Build
23import qualified Elm.Compiler.Type.Extract as Extract
24import qualified Elm.Details as Details
25import qualified Elm.Interface as I
26import qualified Elm.ModuleName as ModuleName
27import qualified Elm.Package as Pkg
28import qualified File
29import qualified Generate.JavaScript as JS
30import qualified Generate.Mode as Mode
31import qualified Nitpick.Debug as Nitpick
32import qualified Reporting.Exit as Exit
33import qualified Reporting.Task as Task
34import qualified Stuff
37-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38-- desireable to have Repl and Reactor to keep foreign objects in memory
39-- to make things a bit faster?
43-- GENERATORS
46type Task a =
47 Task.Task Exit.Generate a
50debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51debug root details (Build.Artifacts pkg ifaces roots modules) =
52 do loading <- loadObjects root details modules
53 types <- loadTypes root ifaces modules
54 objects <- finalizeObjects loading
55 let mode = Mode.Dev (Just types)
56 let graph = objectsToGlobalGraph objects
57 let mains = gatherMains pkg objects roots
58 return $ JS.generate mode graph mains
61dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62dev root details (Build.Artifacts pkg _ roots modules) =
63 do objects <- finalizeObjects =<< loadObjects root details modules
64 let mode = Mode.Dev Nothing
65 let graph = objectsToGlobalGraph objects
66 let mains = gatherMains pkg objects roots
67 return $ JS.generate mode graph mains
70prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71prod root details (Build.Artifacts pkg _ roots modules) =
72 do objects <- finalizeObjects =<< loadObjects root details modules
73 checkForDebugUses objects
74 let graph = objectsToGlobalGraph objects
75 let mode = Mode.Prod (Mode.shortenFieldNames graph)
76 let mains = gatherMains pkg objects roots
77 return $ JS.generate mode graph mains
80repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82 do objects <- finalizeObjects =<< loadObjects root details modules
83 let graph = objectsToGlobalGraph objects
84 return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
88-- CHECK FOR DEBUG
91checkForDebugUses :: Objects -> Task ()
92checkForDebugUses (Objects _ locals) =
93 case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94 [] -> return ()
95 m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
99-- GATHER MAINS
102gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103gatherMains pkg (Objects _ locals) roots =
104 Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
107lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108lookupMain pkg locals root =
109 let
110 toPair name (Opt.LocalGraph maybeMain _ _) =
111 (,) (ModuleName.Canonical pkg name) <$> maybeMain
112 in
113 case root of
114 Build.Inside name -> toPair name =<< Map.lookup name locals
115 Build.Outside name _ g -> toPair name g
119-- LOADING OBJECTS
122data LoadingObjects =
123 LoadingObjects
124 { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125 , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126 }
129loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130loadObjects root details modules =
131 Task.io $
132 do mvar <- Details.loadObjects root details
133 mvars <- traverse (loadObject root) modules
134 return $ LoadingObjects mvar (Map.fromList mvars)
137loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138loadObject root modul =
139 case modul of
140 Build.Fresh name _ graph ->
141 do mvar <- newMVar (Just graph)
142 return (name, mvar)
144 Build.Cached name _ _ ->
145 do mvar <- newEmptyMVar
146 _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147 return (name, mvar)
151-- FINALIZE OBJECTS
154data Objects =
155 Objects
156 { _foreign :: Opt.GlobalGraph
157 , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158 }
161finalizeObjects :: LoadingObjects -> Task Objects
162finalizeObjects (LoadingObjects mvar mvars) =
163 Task.eio id $
164 do result <- readMVar mvar
165 results <- traverse readMVar mvars
166 case liftM2 Objects result (sequence results) of
167 Just loaded -> return (Right loaded)
168 Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
171objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172objectsToGlobalGraph (Objects globals locals) =
173 foldr Opt.addLocalGraph globals locals
177-- LOAD TYPES
180loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181loadTypes root ifaces modules =
182 Task.eio id $
183 do mvars <- traverse (loadTypesHelp root) modules
184 let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185 results <- traverse readMVar mvars
186 case sequence results of
187 Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188 Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
191loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192loadTypesHelp root modul =
193 case modul of
194 Build.Fresh name iface _ ->
195 newMVar (Just (Extract.fromInterface name iface))
197 Build.Cached name _ ciMVar ->
198 do cachedInterface <- readMVar ciMVar
199 case cachedInterface of
200 Build.Unneeded ->
201 do mvar <- newEmptyMVar
202 _ <- forkIO $
203 do maybeIface <- File.readBinary (Stuff.elmi root name)
204 putMVar mvar (Extract.fromInterface name <$> maybeIface)
205 return mvar
207 Build.Loaded iface ->
208 newMVar (Just (Extract.fromInterface name iface))
210 Build.Corrupted ->
211 newMVar Nothing