4de92ef · elk · git.iko.soy

git.iko.soy/elk

move logic for loading object files into new builder/Generate module

This code is not only used in Make. It is needed for Repl and Reactor at least. Maybe one day it would be kept in memory in those cases since they can detect file changes while the run, but not in 0.19.1!

commit4de92ef08a603082d8f6e67e80faa8e626c060a1 authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 18 Jun 2019, 11:01 (7 years ago) parentbfda254

2 files changed+211−175

compare with master

unifiedsplit

builder/src/Generate.hs+201 terminal/src/Make.hs+10−175

builder/src/Generate.hsnew file+201

@@ -0,0 +1,201 @@

1+{-# LANGUAGE BangPatterns #-}

2+module Generate

3+ ( debug

4+ , dev

5+ , prod

6+ )

7+ where

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 #-}

22module Make

33 ( Flags(..)

44 , Output(..)

@@ -11,26 +11,18 @@ module Make

1111 where

1212

1313

14−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)

15−import Control.Monad (liftM2)

1614import qualified Data.ByteString.Builder as B

17−import qualified Data.Map as Map

1815import qualified Data.Maybe as Maybe

1916import qualified Data.NonEmptyList as NE

2017import qualified System.FilePath as FP

2118

2219import qualified AST.Optimized as Opt

2320import qualified Build

24−import qualified Elm.Compiler.Type.Extract as Extract

2521import qualified Elm.Details as Details

26−import qualified Elm.Interface as I

2722import qualified Elm.ModuleName as ModuleName

28−import qualified Elm.Package as Pkg

2923import qualified File

24+import qualified Generate

3025import 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

3426import qualified Reporting

3527import qualified Reporting.Exit as Exit

3628import qualified Reporting.Task as Task

@@ -105,7 +97,7 @@ run paths (Flags debug optimize maybeOutput report maybeDocs) =

10597 case getNoMains artifacts of

10698 [] ->

10799 do builder <- toBuilder root details desiredMode artifacts

108− generate style target builder (getMainNames artifacts)

100+ generate style target builder (Build.getMainNames artifacts)

109101

110102 name:names ->

111103 Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)

@@ -133,10 +125,7 @@ getStyle report =

133125

134126getRoot :: Task FilePath

135127getRoot =

136− do maybeRoot <- Task.io Stuff.findRoot

137− case maybeRoot of

138− Nothing -> Task.throw Exit.MakeNeedsOutline

139− Just root -> return root

128+ Task.mio Exit.MakeNoOutline Stuff.findRoot

140129

141130

142131getMode :: Bool -> Bool -> Task DesiredMode

@@ -252,22 +241,6 @@ getNoMain modules main =

252241

253242

254243

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−

271244-- GENERATE

272245

273246

@@ -286,150 +259,12 @@ data DesiredMode = Debug | Dev | Prod

286259

287260

288261toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder

289−toBuilder root details desiredMode (Build.Artifacts pkg ifaces roots modules) =

290− case desiredMode of

291− Debug ->

292− do loading <- loadObjects root details modules

293− types <- loadTypes root ifaces modules

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

262+toBuilder root details desiredMode artifacts =

263+ Task.mapError Exit.MakeBadGenerate $

264+ case desiredMode of

265+ Debug -> Generate.debug root details artifacts

266+ Dev -> Generate.dev root details artifacts

267+ Prod -> Generate.prod root details artifacts

433268

434269

435270