59 lines
1.9 KiB
Text
59 lines
1.9 KiB
Text
/-
|
||
Copyright (c) 2021 Mac Malone. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Mac Malone
|
||
-/
|
||
import Lake.Config.Monad
|
||
import Lake.Build.Context
|
||
import Lake.Util.EStateT
|
||
|
||
open System
|
||
|
||
namespace Lake
|
||
|
||
deriving instance Inhabited for BuildContext
|
||
|
||
def mkBuildContext (ws : Workspace) (oldMode : Bool) : IO BuildContext := do
|
||
let lean := ws.lakeEnv.lean
|
||
let leanTrace :=
|
||
if lean.githash.isEmpty then
|
||
mixTrace (← computeTrace lean.lean) (← computeTrace lean.sharedLib)
|
||
else
|
||
Hash.ofString lean.githash
|
||
return {opaqueWs := ws, leanTrace, oldMode}
|
||
|
||
@[inline] def getLeanTrace : BuildM BuildTrace :=
|
||
(·.leanTrace) <$> readThe BuildContext
|
||
|
||
@[inline] def getIsOldMode : BuildM Bool :=
|
||
(·.oldMode) <$> readThe BuildContext
|
||
|
||
def failOnBuildCycle [ToString k] : Except (List k) α → BuildM α
|
||
| Except.ok a => pure a
|
||
| Except.error cycle => do
|
||
let cycle := cycle.map (s!" {·}")
|
||
error s!"build cycle detected:\n{"\n".intercalate cycle}"
|
||
|
||
/--
|
||
Run the recursive build in the given build store.
|
||
If a cycle is encountered, log it and then fail.
|
||
-/
|
||
@[inline] def RecBuildM.runIn (store : BuildStore) (build : RecBuildM α) : BuildM (α × BuildStore) := do
|
||
let (res, store) ← EStateT.run store <| ReaderT.run build []
|
||
return (← failOnBuildCycle res, store)
|
||
|
||
/--
|
||
Run the recursive build in a fresh build store.
|
||
If a cycle is encountered, log it and then fail.
|
||
-/
|
||
@[inline] def RecBuildM.run (build : RecBuildM α) : BuildM α := do
|
||
(·.1) <$> build.runIn {}
|
||
|
||
/-- Run the given build function in the Workspace's context. -/
|
||
@[inline] def Workspace.runBuild (ws : Workspace) (build : BuildM α) (oldMode := false) : LogIO α := do
|
||
let ctx ← mkBuildContext ws oldMode
|
||
build.run ctx
|
||
|
||
/-- Run the given build function in the Lake monad's workspace. -/
|
||
@[inline] def runBuild (build : BuildM α) (oldMode := false) : LakeT LogIO α := do
|
||
(← getWorkspace).runBuild build oldMode
|