chore: merge Lake into src/lake

This commit is contained in:
Sebastian Ullrich 2023-07-17 10:38:20 +02:00
commit bf76eca0cd
239 changed files with 10595 additions and 0 deletions

1
src/lake/.envrc Normal file
View file

@ -0,0 +1 @@
use flake

1
src/lake/.gitattributes vendored Normal file
View file

@ -0,0 +1 @@
*.sh text eol=lf

72
src/lake/.github/workflows/ci.yml vendored Normal file
View file

@ -0,0 +1,72 @@
name: CI
on: [ push, pull_request ]
jobs:
skip_check:
name: Skip Check
continue-on-error: true
runs-on: ubuntu-latest
outputs:
should_skip: ${{ steps.skip_check.outputs.should_skip }}
steps:
- id: skip_check
uses: fkirc/skip-duplicate-actions@v4
with:
concurrent_skipping: 'same_content_newer'
paths_ignore: '["README.md", "LICENSE"]'
build:
needs: skip_check
name: ${{ matrix.name || 'Build' }}
if: ${{ needs.skip_check.outputs.should_skip != 'true' }}
runs-on: ${{ matrix.os }}
defaults:
run:
shell: ${{ matrix.shell || 'sh' }}
strategy:
matrix:
include:
- name: Ubuntu
os: ubuntu-latest
- name: MacOS
os: macos-latest
- name: Windows
os: windows-latest
shell: msys2 {0}
# complete all jobs
fail-fast: false
steps:
- name: Install MSYS2 (Windows)
if: matrix.os == 'windows-latest'
uses: msys2/setup-msys2@v2
with:
path-type: inherit
install: curl unzip make diffutils mingw-w64-x86_64-gcc mingw-w64-x86_64-gmp
- name: Install Elan
shell: bash -euo pipefail {0}
run: |
curl -sSfL https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh | sh -s -- -y --default-toolchain none
echo "$HOME/.elan/bin" >> $GITHUB_PATH
- name: Checkout
uses: actions/checkout@v2
- name: Check Lean
run: lean --version
- name: Build & Time
run: ./time.sh -j4
- name: Upload Build
continue-on-error: true
uses: actions/upload-artifact@v2
with:
name: ${{ matrix.os }}
path: build
- name: Check Lake
run: make check-lake
- name: Test Lake
run: make test-ci
- name: Time Bootstrap
run: make time-bootstrap
- name: Check Bootstrap
run: make check-bootstrap
- name: Test Bootstrapped Lake
run: make test-bootstrapped -j4

5
src/lake/.gitignore vendored Normal file
View file

@ -0,0 +1,5 @@
/build
produced.out
result*
# Do not commit the flake lockfile to avoid having to maintain it
flake.lock

70
src/lake/LICENSE Normal file
View file

@ -0,0 +1,70 @@
Apache License 2.0 (Apache)
Apache License
Version 2.0, January 2004
http://www.apache.org/licenses/
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
1. Definitions.
"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document.
"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License.
"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity.
"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License.
"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files.
"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types.
"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below).
"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof.
"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution."
"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work.
2. Grant of Copyright License.
Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form.
3. Grant of Patent License.
Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed.
4. Redistribution.
You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions:
1. You must give any other recipients of the Work or Derivative Works a copy of this License; and
2. You must cause any modified files to carry prominent notices stating that You changed the files; and
3. You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and
4. If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License.
You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License.
5. Submission of Contributions.
Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions.
6. Trademarks.
This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file.
7. Disclaimer of Warranty.
Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License.
8. Limitation of Liability.
In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages.
9. Accepting Warranty or Additional Liability.
While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability.

10
src/lake/Lake.lean Normal file
View file

@ -0,0 +1,10 @@
/-
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.Build
import Lake.Config
import Lake.DSL
import Lake.Version
import Lake.CLI.Actions

12
src/lake/Lake/Build.lean Normal file
View file

@ -0,0 +1,12 @@
/-
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.Build.Monad
import Lake.Build.Actions
import Lake.Build.Index
import Lake.Build.Module
import Lake.Build.Package
import Lake.Build.Library
import Lake.Build.Imports

View file

@ -0,0 +1,123 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake.Util.Proc
import Lake.Util.NativeLib
import Lake.Build.Context
namespace Lake
open System
def createParentDirs (path : FilePath) : IO Unit := do
if let some dir := path.parent then IO.FS.createDirAll dir
def compileLeanModule (name : String) (leanFile : FilePath)
(oleanFile? ileanFile? cFile? : Option FilePath)
(leanPath : SearchPath := []) (rootDir : FilePath := ".")
(dynlibs : Array FilePath := #[]) (dynlibPath : SearchPath := {})
(leanArgs : Array String := #[]) (lean : FilePath := "lean")
: BuildM Unit := do
logStep s!"Building {name}"
let mut args := leanArgs ++
#[leanFile.toString, "-R", rootDir.toString]
if let some oleanFile := oleanFile? then
createParentDirs oleanFile
args := args ++ #["-o", oleanFile.toString]
if let some ileanFile := ileanFile? then
createParentDirs ileanFile
args := args ++ #["-i", ileanFile.toString]
if let some cFile := cFile? then
createParentDirs cFile
args := args ++ #["-c", cFile.toString]
for dynlib in dynlibs do
args := args.push s!"--load-dynlib={dynlib}"
proc {
args
cmd := lean.toString
env := #[
("LEAN_PATH", leanPath.toString),
(sharedLibPathEnvVar, (← getSearchPath sharedLibPathEnvVar) ++ dynlibPath |>.toString)
]
}
def compileO (name : String) (oFile srcFile : FilePath)
(moreArgs : Array String := #[]) (compiler : FilePath := "cc") : BuildM Unit := do
logStep s!"Compiling {name}"
createParentDirs oFile
proc {
cmd := compiler.toString
args := #["-c", "-o", oFile.toString, srcFile.toString] ++ moreArgs
}
def compileStaticLib (name : String) (libFile : FilePath)
(oFiles : Array FilePath) (ar : FilePath := "ar") : BuildM Unit := do
logStep s!"Creating {name}"
createParentDirs libFile
proc {
cmd := ar.toString
args := #["rcs", libFile.toString] ++ oFiles.map toString
}
def compileSharedLib (name : String) (libFile : FilePath)
(linkArgs : Array String) (linker : FilePath := "cc") : BuildM Unit := do
logStep s!"Linking {name}"
createParentDirs libFile
proc {
cmd := linker.toString
args := #["-shared", "-o", libFile.toString] ++ linkArgs
}
def compileExe (name : String) (binFile : FilePath) (linkFiles : Array FilePath)
(linkArgs : Array String := #[]) (linker : FilePath := "cc") : BuildM Unit := do
logStep s!"Linking {name}"
createParentDirs binFile
proc {
cmd := linker.toString
args := #["-o", binFile.toString] ++ linkFiles.map toString ++ linkArgs
}
/-- Download a file using `curl`, clobbering any existing file. -/
def download (name : String) (url : String) (file : FilePath) : LogIO PUnit := do
logInfo s!"Downloading {name}"
if (← file.pathExists) then
IO.FS.removeFile file
else
createParentDirs file
let args :=
if (← getIsVerbose) then #[] else #["-s"]
proc (quiet := true) {
cmd := "curl"
args := args ++ #["-f", "-o", file.toString, "-L", url]
}
/-- Unpack an archive `file` using `tar` into the directory `dir`. -/
def untar (name : String) (file : FilePath) (dir : FilePath) (gzip := true) : LogIO PUnit := do
logInfo s!"Unpacking {name}"
let mut opts := "-x"
if (← getIsVerbose) then
opts := opts.push 'v'
if gzip then
opts := opts.push 'z'
proc {
cmd := "tar",
args := #[opts, "-f", file.toString, "-C", dir.toString]
}
/-- Pack a directory `dir` using `tar` into the archive `file`. -/
def tar (name : String) (dir : FilePath) (file : FilePath)
(gzip := true) (excludePaths : Array FilePath := #[]) : LogIO PUnit := do
logInfo s!"Packing {name}"
createParentDirs file
let mut args := #["-c"]
if gzip then
args := args.push "-z"
if (← getIsVerbose) then
args := args.push "-v"
for path in excludePaths do
args := args.push s!"--exclude={path}"
proc {
cmd := "tar"
args := args ++ #["-f", file.toString, "-C", dir.toString, "."]
}

View file

@ -0,0 +1,118 @@
/-
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.Build.Job
import Lake.Build.Actions
import Lake.Build.Monad
open System
namespace Lake
/-! # General Utilities -/
@[inline] def inputFile (path : FilePath) : SchedulerM (BuildJob FilePath) :=
Job.async <| (path, ·) <$> computeTrace path
@[inline] def buildUnlessUpToDate [CheckExists ι] [GetMTime ι] (info : ι)
(depTrace : BuildTrace) (traceFile : FilePath) (build : JobM PUnit) : JobM PUnit := do
let isOldMode ← getIsOldMode
let upToDate ←
if isOldMode then
depTrace.checkAgainstTime info
else
depTrace.checkAgainstFile info traceFile
unless upToDate do
build
unless isOldMode do
depTrace.writeToFile traceFile
@[inline] def buildFileUnlessUpToDate (file : FilePath)
(depTrace : BuildTrace) (build : BuildM PUnit) : BuildM BuildTrace := do
let traceFile := FilePath.mk <| file.toString ++ ".trace"
buildUnlessUpToDate file depTrace traceFile build
computeTrace file
@[inline] def buildFileAfterDep
(file : FilePath) (dep : BuildJob α) (build : α → BuildM PUnit)
(extraDepTrace : BuildM _ := pure BuildTrace.nil) : SchedulerM (BuildJob FilePath) :=
dep.bindSync fun depInfo depTrace => do
let depTrace := depTrace.mix (← extraDepTrace)
let trace ← buildFileUnlessUpToDate file depTrace <| build depInfo
return (file, trace)
@[inline] def buildFileAfterDepList
(file : FilePath) (deps : List (BuildJob α)) (build : List α → BuildM PUnit)
(extraDepTrace : BuildM _ := pure BuildTrace.nil) : SchedulerM (BuildJob FilePath) := do
buildFileAfterDep file (← BuildJob.collectList deps) build extraDepTrace
@[inline] def buildFileAfterDepArray
(file : FilePath) (deps : Array (BuildJob α)) (build : Array α → BuildM PUnit)
(extraDepTrace : BuildM _ := pure BuildTrace.nil) : SchedulerM (BuildJob FilePath) := do
buildFileAfterDep file (← BuildJob.collectArray deps) build extraDepTrace
/-! # Common Builds -/
def buildO (name : String)
(oFile : FilePath) (srcJob : BuildJob FilePath)
(args : Array String := #[]) (compiler : FilePath := "cc") : SchedulerM (BuildJob FilePath) :=
buildFileAfterDep oFile srcJob (extraDepTrace := computeHash args) fun srcFile => do
compileO name oFile srcFile args compiler
def buildLeanO (name : String)
(oFile : FilePath) (srcJob : BuildJob FilePath)
(args : Array String := #[]) : SchedulerM (BuildJob FilePath) :=
buildFileAfterDep oFile srcJob (extraDepTrace := computeHash args) fun srcFile => do
compileO name oFile srcFile args (← getLeanc)
def buildStaticLib (libFile : FilePath)
(oFileJobs : Array (BuildJob FilePath)) : SchedulerM (BuildJob FilePath) :=
let name := libFile.fileName.getD libFile.toString
buildFileAfterDepArray libFile oFileJobs fun oFiles => do
compileStaticLib name libFile oFiles (← getLeanAr)
def buildLeanSharedLib
(libFile : FilePath) (linkJobs : Array (BuildJob FilePath))
(linkArgs : Array String := #[]) : SchedulerM (BuildJob FilePath) :=
let name := libFile.fileName.getD libFile.toString
buildFileAfterDepArray libFile linkJobs
(extraDepTrace := computeHash linkArgs) fun links => do
compileSharedLib name libFile (links.map toString ++ linkArgs) (← getLeanc)
def buildLeanExe
(exeFile : FilePath) (linkJobs : Array (BuildJob FilePath))
(linkArgs : Array String := #[]) : SchedulerM (BuildJob FilePath) :=
let name := exeFile.fileName.getD exeFile.toString
buildFileAfterDepArray exeFile linkJobs
(extraDepTrace := computeHash linkArgs) fun links => do
compileExe name exeFile links linkArgs (← getLeanc)
def buildLeanSharedLibOfStatic (staticLibJob : BuildJob FilePath)
(linkArgs : Array String := #[]) : SchedulerM (BuildJob FilePath) :=
staticLibJob.bindSync fun staticLib staticTrace => do
let dynlib := staticLib.withExtension sharedLibExt
let baseArgs :=
if System.Platform.isOSX then
#[s!"-Wl,-force_load,{staticLib}"]
else
#["-Wl,--whole-archive", staticLib.toString, "-Wl,--no-whole-archive"]
let args := baseArgs ++ linkArgs
let depTrace := staticTrace.mix (← computeHash args)
let trace ← buildFileUnlessUpToDate dynlib depTrace do
let name := dynlib.fileName.getD dynlib.toString
compileSharedLib name dynlib args (← getLeanc)
return (dynlib, trace)
def computeDynlibOfShared
(sharedLibTarget : BuildJob FilePath) : SchedulerM (BuildJob Dynlib) :=
sharedLibTarget.bindSync fun sharedLib trace => do
if let some stem := sharedLib.fileStem then
if Platform.isWindows then
return ({path := sharedLib, name := stem}, trace)
else if stem.startsWith "lib" then
return ({path := sharedLib, name := stem.drop 3}, trace)
else
error s!"shared library `{sharedLib}` does not start with `lib`; this is not supported on Unix"
else
error s!"shared library `{sharedLib}` has no file name"

View file

@ -0,0 +1,58 @@
/-
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.Util.Log
import Lake.Util.Task
import Lake.Util.Error
import Lake.Util.OptionIO
import Lake.Config.Context
import Lake.Build.Trace
import Lake.Build.Store
import Lake.Build.Topological
open System
namespace Lake
/-- A Lake context with some additional caching for builds. -/
structure BuildContext extends Context where
leanTrace : BuildTrace
oldMode : Bool := false
startedBuilds : IO.Ref Nat
finishedBuilds : IO.Ref Nat
/-- A transformer to equip a monad with a `BuildContext`. -/
abbrev BuildT := ReaderT BuildContext
/-- The monad for the Lake build manager. -/
abbrev SchedulerM := BuildT <| LogT BaseIO
/-- The core monad for Lake builds. -/
abbrev BuildM := BuildT LogIO
/-- A transformer to equip a monad with a Lake build store. -/
abbrev BuildStoreT := StateT BuildStore
/-- A Lake build cycle. -/
abbrev BuildCycle := Cycle BuildKey
/-- A transformer for monads that may encounter a build cycle. -/
abbrev BuildCycleT := CycleT BuildKey
/-- A recursive build of a Lake build store that may encounter a cycle. -/
abbrev RecBuildM := BuildCycleT <| BuildStoreT BuildM
instance [Pure m] : MonadLift LakeM (BuildT m) where
monadLift x := fun ctx => pure <| x.run ctx.toContext
@[inline] def BuildM.run (ctx : BuildContext) (self : BuildM α) : LogIO α :=
self ctx
def BuildM.catchFailure (f : Unit → BaseIO α) (self : BuildM α) : SchedulerM α :=
fun ctx logMethods => self ctx logMethods |>.catchFailure f
def logStep (message : String) : BuildM Unit := do
let done ← (← read).finishedBuilds.get
let started ← (← read).startedBuilds.get
logInfo s!"[{done}/{started}] {message}"

View file

@ -0,0 +1,131 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Key
import Lake.Util.Family
open Lean
namespace Lake
--------------------------------------------------------------------------------
/-! ## Build Data Subtypes -/
--------------------------------------------------------------------------------
/--
The open type family which maps a module facet's name to its build data
in the Lake build store. For example, a transitive × direct import pair
for the `lean.imports` facet or an active build target for `lean.c`.
It is an open type, meaning additional mappings can be add lazily
as needed (via `module_data`).
-/
opaque ModuleData (facet : Name) : Type
/--
The open type family which maps a package facet's name to its build data
in the Lake build store. For example, a transitive dependencies of the package
for the facet `deps`.
It is an open type, meaning additional mappings can be add lazily
as needed (via `package_data`).
-/
opaque PackageData (facet : Name) : Type
/--
The open type family which maps a (builtin) Lake target's (e.g., `extern_lib`)
facet to its associated build data. For example, an active build target for
the `externLib.static` facet.
It is an open type, meaning additional mappings can be add lazily
as needed (via `target_data`).
-/
opaque TargetData (facet : Name) : Type
/-
The open type family which maps a library facet's name to its build data
in the Lake build store. For example, an active build target for the `static`
facet.
It is an open type, meaning additional mappings can be add lazily
as needed (via `library_data`).
-/
abbrev LibraryData (facet : Name) := TargetData (`leanLib ++ facet)
instance [h : FamilyOut LibraryData facet α] : FamilyDef TargetData (`leanLib ++ facet) α :=
⟨by simp [h.family_key_eq_type]⟩
instance [h : FamilyOut TargetData (`leanLib ++ facet) α] : FamilyDef LibraryData facet α :=
⟨h.family_key_eq_type⟩
/--
The open type family which maps a custom target (package × target name) to
its build data in the Lake build store.
It is an open type, meaning additional mappings can be add lazily
as needed (via `custom_data`).
-/
opaque CustomData (target : Name × Name) : Type
--------------------------------------------------------------------------------
/-! ## Build Data -/
--------------------------------------------------------------------------------
/--
A mapping between a build key and its associated build data in the store.
It is a simple type function composed of the separate open type families for
modules facets, package facets, Lake target facets, and custom targets.
-/
abbrev BuildData : BuildKey → Type
| .moduleFacet _ f => ModuleData f
| .packageFacet _ f => PackageData f
| .targetFacet _ _ f => TargetData f
| .customTarget p t => CustomData (p, t)
instance (priority := low) : FamilyDef BuildData (.moduleFacet m f) (ModuleData f) := ⟨rfl⟩
instance (priority := low) : FamilyDef BuildData (.packageFacet p f) (PackageData f) := ⟨rfl⟩
instance (priority := low) : FamilyDef BuildData (.targetFacet p t f) (TargetData f) := ⟨rfl⟩
instance (priority := low) : FamilyDef BuildData (.customTarget p t) (CustomData (p,t)) := ⟨rfl⟩
--------------------------------------------------------------------------------
/-! ## Macros for Declaring Build Data -/
--------------------------------------------------------------------------------
/-- Macro for declaring new `PackageData`. -/
scoped macro (name := packageDataDecl) doc?:optional(Parser.Command.docComment)
"package_data " id:ident " : " ty:term : command => do
let dty := mkCIdentFrom (← getRef) ``PackageData
let key := Name.quoteFrom id id.getId
`($[$doc?]? family_def $id : $dty $key := $ty)
/-- Macro for declaring new `ModuleData`. -/
scoped macro (name := moduleDataDecl) doc?:optional(Parser.Command.docComment)
"module_data " id:ident " : " ty:term : command => do
let dty := mkCIdentFrom (← getRef) ``ModuleData
let key := Name.quoteFrom id id.getId
`($[$doc?]? family_def $id : $dty $key := $ty)
/-- Macro for declaring new `TargetData` for libraries. -/
scoped macro (name := libraryDataDecl) doc?:optional(Parser.Command.docComment)
"library_data " id:ident " : " ty:term : command => do
let dty := mkCIdentFrom (← getRef) ``TargetData
let key := Name.quoteFrom id id.getId
let id := mkIdentFrom id <| id.getId.modifyBase (`leanLib ++ ·)
`($[$doc?]? family_def $id : $dty (`leanLib ++ $key) := $ty)
/-- Macro for declaring new `TargetData`. -/
scoped macro (name := targetDataDecl) doc?:optional(Parser.Command.docComment)
"target_data " id:ident " : " ty:term : command => do
let dty := mkCIdentFrom (← getRef) ``TargetData
let key := Name.quoteFrom id id.getId
`($[$doc?]? family_def $id : $dty $key := $ty)
/-- Macro for declaring new `CustomData`. -/
scoped macro (name := customDataDecl) doc?:optional(Parser.Command.docComment)
"custom_data " pkg:ident tgt:ident " : " ty:term : command => do
let dty := mkCIdentFrom (← getRef) ``CustomData
let id := mkIdentFrom tgt (pkg.getId ++ tgt.getId)
let pkg := Name.quoteFrom pkg pkg.getId
let tgt := Name.quoteFrom pkg tgt.getId
`($[$doc?]? family_def $id : $dty ($pkg, $tgt) := $ty)

View file

@ -0,0 +1,34 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Common
namespace Lake
/-- Get the Lean executable in the workspace with the configuration's name. -/
@[inline] def LeanExeConfig.get (self : LeanExeConfig)
[Monad m] [MonadError m] [MonadLake m] : m LeanExe := do
let some exe ← findLeanExe? self.name
| error "Lean executable '{self.name}' does not exist in the workspace"
return exe
/-- Fetch the build of the Lean executable. -/
@[inline] def LeanExeConfig.fetch
(self : LeanExeConfig) : IndexBuildM (BuildJob FilePath) := do
(← self.get).exe.fetch
/-! # Build Executable -/
protected def LeanExe.recBuildExe
(self : LeanExe) : IndexBuildM (BuildJob FilePath) := do
let imports ← self.root.transImports.fetch
let mut linkJobs := #[← self.root.o.fetch]
for mod in imports do for facet in mod.nativeFacets do
linkJobs := linkJobs.push <| ← fetch <| mod.facet facet.name
let deps := (← fetch <| self.pkg.facet `deps).push self.pkg
for dep in deps do for lib in dep.externLibs do
linkJobs := linkJobs.push <| ← lib.static.fetch
buildLeanExe self.file linkJobs self.linkArgs

View file

@ -0,0 +1,126 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Job
import Lake.Build.Data
/-!
# Simple Builtin Facet Declarations
This module contains the definitions of most of the builtin facets.
The others are defined `Build.Info`. The facets there require configuration
definitions (e.g., `Module`), and some of the facets here are used in said
definitions.
-/
namespace Lake
export System (SearchPath FilePath)
/-- A dynamic/shared library for linking. -/
structure Dynlib where
/-- Library file path. -/
path : FilePath
/-- Library name without platform-specific prefix/suffix (for `-l`). -/
name : String
/-- Optional library directory (for `-L`). -/
def Dynlib.dir? (self : Dynlib) : Option FilePath :=
self.path.parent
/-! ## Module Facets -/
/-- A module facet name along with proof of its data type. -/
structure ModuleFacet (α) where
/-- The name of the module facet. -/
name : Name
/-- Proof that module's facet build result is of type α. -/
data_eq : ModuleData name = α
deriving Repr
instance (facet : ModuleFacet α) : FamilyDef ModuleData facet.name α :=
⟨facet.data_eq⟩
instance [FamilyOut ModuleData facet α] : CoeDep Name facet (ModuleFacet α) :=
⟨facet, FamilyOut.family_key_eq_type⟩
/--
The facet which builds all of a module's dependencies
(i.e., transitive local imports and `--load-dynlib` shared libraries).
Returns the list of shared libraries to load along with their search path.
-/
abbrev Module.depsFacet := `deps
module_data deps : BuildJob (SearchPath × Array FilePath)
/--
The core compilation / elaboration of the Lean file via `lean`,
which produce the Lean binaries of the module (i.e., `olean`, `ilean`, `c`).
Its trace just includes its dependencies.
-/
abbrev Module.leanBinFacet := `bin
module_data bin : BuildJob Unit
/--
The `leanBinFacet` combined with the module's trace
(i.e., the trace of its `olean` and `ilean`).
It is the facet used for building a Lean import of a module.
-/
abbrev Module.importBinFacet := `importBin
module_data importBin : BuildJob Unit
/-- The `olean` file produced by `lean` -/
abbrev Module.oleanFacet := `olean
module_data olean : BuildJob FilePath
/-- The `ilean` file produced by `lean` -/
abbrev Module.ileanFacet := `ilean
module_data ilean : BuildJob FilePath
/-- The C file built from the Lean file via `lean` -/
abbrev Module.cFacet := `c
module_data c : BuildJob FilePath
/-- The object file built from `lean.c` -/
abbrev Module.oFacet := `o
module_data o : BuildJob FilePath
/-! ## Package Facets -/
/-- The package's cloud build release. -/
abbrev Package.releaseFacet := `release
package_data release : BuildJob Unit
/-- The package's `extraDepTarget` mixed with its transitive dependencies'. -/
abbrev Package.extraDepFacet := `extraDep
package_data extraDep : BuildJob Unit
/-! ## Target Facets -/
/-- A Lean library's Lean libraries. -/
abbrev LeanLib.leanFacet := `lean
library_data lean : BuildJob Unit
/-- A Lean library's static binary. -/
abbrev LeanLib.staticFacet := `static
library_data static : BuildJob FilePath
/-- A Lean library's shared binary. -/
abbrev LeanLib.sharedFacet := `shared
library_data shared : BuildJob FilePath
/-- A Lean binary executable. -/
abbrev LeanExe.exeFacet := `leanExe
target_data leanExe : BuildJob FilePath
/-- A external library's static binary. -/
abbrev ExternLib.staticFacet := `externLib.static
target_data externLib.static : BuildJob FilePath
/-- A external library's shared binary. -/
abbrev ExternLib.sharedFacet := `externLib.shared
target_data externLib.shared : BuildJob FilePath
/-- A external library's dynlib. -/
abbrev ExternLib.dynlibFacet := `externLib.dynlib
target_data externLib.dynlib : BuildJob Dynlib

View file

@ -0,0 +1,70 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Index
/-!
Definitions to support `lake print-paths` builds.
-/
open System
namespace Lake
/--
Construct an `Array` of `Module`s for the workspace-local modules of
a `List` of import strings.
-/
def Workspace.processImportList
(imports : List String) (self : Workspace) : Array Module := Id.run do
let mut localImports := #[]
for imp in imports do
if let some mod := self.findModule? imp.toName then
localImports := localImports.push mod
return localImports
/--
Recursively build a set of imported modules and return their build jobs,
the build jobs of their precompiled modules and the build jobs of said modules'
external libraries.
-/
def recBuildImports (imports : Array Module)
: IndexBuildM (Array (BuildJob Unit) × Array (BuildJob Dynlib) × Array (BuildJob Dynlib)) := do
let mut modJobs := #[]
let mut precompileImports := OrdModuleSet.empty
for mod in imports do
if mod.shouldPrecompile then
precompileImports := precompileImports.appendArray (← mod.transImports.fetch) |>.insert mod
else
precompileImports := precompileImports.appendArray (← mod.precompileImports.fetch)
modJobs := modJobs.push <| ← mod.leanBin.fetch
let pkgs := precompileImports.foldl (·.insert ·.pkg) OrdPackageSet.empty |>.toArray
let externJobs ← pkgs.concatMapM (·.externLibs.mapM (·.dynlib.fetch))
let precompileJobs ← precompileImports.toArray.mapM (·.dynlib.fetch)
return (modJobs, precompileJobs, externJobs)
/--
Builds the workspace-local modules of list of imports.
Used by `lake print-paths` to build modules for the Lean server.
Returns the set of module dynlibs built (so they can be loaded by the server).
Builds only module `.olean` and `.ilean` files if the package is configured
as "Lean-only". Otherwise, also builds `.c` files.
-/
def buildImportsAndDeps (imports : List String) : BuildM (Array FilePath) := do
let ws ← getWorkspace
if imports.isEmpty then
-- build the package's (and its dependencies') `extraDepTarget`
ws.root.extraDep.build >>= (·.materialize)
return #[]
else
-- build local imports from list
let mods := ws.processImportList imports
let (modJobs, precompileJobs, externLibJobs) ←
recBuildImports mods |>.run.run
modJobs.forM (·.await)
let modLibs ← precompileJobs.mapM (·.await <&> (·.path))
let externLibs ← externLibJobs.mapM (·.await <&> (·.path))
-- NOTE: Lean wants the external library symbols before module symbols
return externLibs ++ modLibs

View file

@ -0,0 +1,108 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Executable
import Lake.Build.Topological
/-!
# The Lake Build Index
The Lake build index is the complete map of Lake build keys to
Lake build functions, which is used by Lake to build any Lake build info.
This module leverages the index to perform topologically-based recursive builds.
-/
open Lean
namespace Lake
/--
Converts a conveniently typed target facet build function into its
dynamically typed equivalent.
-/
@[macro_inline] def mkTargetFacetBuild (facet : Name) (build : IndexBuildM α)
[h : FamilyOut TargetData facet α] : IndexBuildM (TargetData facet) :=
cast (by rw [← h.family_key_eq_type]) build
def ExternLib.recBuildStatic (lib : ExternLib) : IndexBuildM (BuildJob FilePath) := do
lib.config.getJob <$> fetch (lib.pkg.target lib.staticTargetName)
def ExternLib.recBuildShared (lib : ExternLib) : IndexBuildM (BuildJob FilePath) := do
buildLeanSharedLibOfStatic (← lib.static.fetch) lib.linkArgs
def ExternLib.recComputeDynlib (lib : ExternLib) : IndexBuildM (BuildJob Dynlib) := do
computeDynlibOfShared (← lib.shared.fetch)
/-!
## Topologically-based Recursive Build Using the Index
-/
/-- Recursive build function for anything in the Lake build index. -/
def recBuildWithIndex : (info : BuildInfo) → IndexBuildM (BuildData info.key)
| .moduleFacet mod facet => do
if let some config := (← getWorkspace).findModuleFacetConfig? facet then
config.build mod
else
error s!"do not know how to build module facet `{facet}`"
| .packageFacet pkg facet => do
if let some config := (← getWorkspace).findPackageFacetConfig? facet then
config.build pkg
else
error s!"do not know how to build package facet `{facet}`"
| .target pkg target =>
if let some config := pkg.findTargetConfig? target then
config.build pkg
else
error s!"could not build `{target}` of `{pkg.name}` -- target not found"
| .libraryFacet lib facet => do
if let some config := (← getWorkspace).findLibraryFacetConfig? facet then
config.build lib
else
error s!"do not know how to build library facet `{facet}`"
| .leanExe exe =>
mkTargetFacetBuild LeanExe.exeFacet exe.recBuildExe
| .staticExternLib lib =>
mkTargetFacetBuild ExternLib.staticFacet lib.recBuildStatic
| .sharedExternLib lib =>
mkTargetFacetBuild ExternLib.sharedFacet lib.recBuildShared
| .dynlibExternLib lib =>
mkTargetFacetBuild ExternLib.dynlibFacet lib.recComputeDynlib
/--
Run the given recursive build using the Lake build index
and a topological / suspending scheduler.
-/
def IndexBuildM.run (build : IndexBuildM α) : RecBuildM α :=
build <| recFetchMemoize BuildInfo.key recBuildWithIndex
/--
Recursively build the given info using the Lake build index
and a topological / suspending scheduler.
-/
def buildIndexTop' (info : BuildInfo) : RecBuildM (BuildData info.key) :=
recFetchMemoize BuildInfo.key recBuildWithIndex info
/--
Recursively build the given info using the Lake build index
and a topological / suspending scheduler and return the dynamic result.
-/
@[macro_inline] def buildIndexTop (info : BuildInfo)
[FamilyOut BuildData info.key α] : RecBuildM α := do
cast (by simp) <| buildIndexTop' info
/-- Build the given Lake target in a fresh build store. -/
@[inline] def BuildInfo.build
(self : BuildInfo) [FamilyOut BuildData self.key α] : BuildM α :=
buildIndexTop self |>.run
export BuildInfo (build)
/-! ### Lean Executable Builds -/
@[inline] protected def LeanExe.build (self : LeanExe) : BuildM (BuildJob FilePath) :=
self.exe.build
@[inline] protected def LeanExe.fetch (self : LeanExe) : IndexBuildM (BuildJob FilePath) :=
self.exe.fetch

View file

@ -0,0 +1,269 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Config.LeanExe
import Lake.Config.ExternLib
import Lake.Build.Facets
import Lake.Util.EquipT
/-!
# Build Info
This module defines the Lake build info type and related utilities.
Build info is what is the data passed to a Lake build function to facilitate
the build.
-/
namespace Lake
/-- The type of Lake's build info. -/
inductive BuildInfo
| moduleFacet (module : Module) (facet : Name)
| packageFacet (package : Package) (facet : Name)
| libraryFacet (lib : LeanLib) (facet : Name)
| leanExe (exe : LeanExe)
| staticExternLib (lib : ExternLib)
| sharedExternLib (lib : ExternLib)
| dynlibExternLib (lib : ExternLib)
| target (package : Package) (target : Name)
--------------------------------------------------------------------------------
/-! ## Build Info & Keys -/
--------------------------------------------------------------------------------
/-! ### Build Key Helper Constructors -/
abbrev Module.facetBuildKey (facet : Name) (self : Module) : BuildKey :=
.moduleFacet self.keyName facet
abbrev Package.facetBuildKey (facet : Name) (self : Package) : BuildKey :=
.packageFacet self.name facet
abbrev Package.targetBuildKey (target : Name) (self : Package) : BuildKey :=
.customTarget self.name target
abbrev LeanLib.facetBuildKey (self : LeanLib) (facet : Name) : BuildKey :=
.targetFacet self.pkg.name self.name (`leanLib ++ facet)
abbrev LeanExe.buildKey (self : LeanExe) : BuildKey :=
.targetFacet self.pkg.name self.name exeFacet
abbrev ExternLib.staticBuildKey (self : ExternLib) : BuildKey :=
.targetFacet self.pkg.name self.name staticFacet
abbrev ExternLib.sharedBuildKey (self : ExternLib) : BuildKey :=
.targetFacet self.pkg.name self.name sharedFacet
abbrev ExternLib.dynlibBuildKey (self : ExternLib) : BuildKey :=
.targetFacet self.pkg.name self.name dynlibFacet
/-! ### Build Info to Key -/
/-- The key that identifies the build in the Lake build store. -/
abbrev BuildInfo.key : (self : BuildInfo) → BuildKey
| moduleFacet m f => m.facetBuildKey f
| packageFacet p f => p.facetBuildKey f
| libraryFacet l f => l.facetBuildKey f
| leanExe x => x.buildKey
| staticExternLib l => l.staticBuildKey
| sharedExternLib l => l.sharedBuildKey
| dynlibExternLib l => l.dynlibBuildKey
| target p t => p.targetBuildKey t
/-! ### Instances for deducing data types of `BuildInfo` keys -/
instance [FamilyOut ModuleData f α]
: FamilyDef BuildData (BuildInfo.key (.moduleFacet m f)) α where
family_key_eq_type := by unfold BuildData; simp
instance [FamilyOut PackageData f α]
: FamilyDef BuildData (BuildInfo.key (.packageFacet p f)) α where
family_key_eq_type := by unfold BuildData; simp
instance (priority := low) {p : NPackage n} : FamilyDef BuildData
(.customTarget p.toPackage.name t) (CustomData (n,t)) := ⟨by simp⟩
instance {p : NPackage n} [FamilyOut CustomData (n, t) α]
: FamilyDef BuildData (BuildInfo.key (.target p.toPackage t)) α where
family_key_eq_type := by unfold BuildData; simp
instance [FamilyOut TargetData (`leanLib ++ f) α]
: FamilyDef BuildData (BuildInfo.key (.libraryFacet l f)) α where
family_key_eq_type := by unfold BuildData; simp
instance [FamilyOut TargetData LeanExe.exeFacet α]
: FamilyDef BuildData (BuildInfo.key (.leanExe x)) α where
family_key_eq_type := by unfold BuildData; simp
instance [FamilyOut TargetData ExternLib.staticFacet α]
: FamilyDef BuildData (BuildInfo.key (.staticExternLib l)) α where
family_key_eq_type := by unfold BuildData; simp
instance [FamilyOut TargetData ExternLib.sharedFacet α]
: FamilyDef BuildData (BuildInfo.key (.sharedExternLib l)) α where
family_key_eq_type := by unfold BuildData; simp
instance [FamilyOut TargetData ExternLib.dynlibFacet α]
: FamilyDef BuildData (BuildInfo.key (.dynlibExternLib l)) α where
family_key_eq_type := by unfold BuildData; simp
--------------------------------------------------------------------------------
/-! ## Recursive Building -/
--------------------------------------------------------------------------------
/-- A build function for any element of the Lake build index. -/
abbrev IndexBuildFn (m : Type → Type v) :=
-- `DBuildFn BuildInfo (BuildData ·.key) m` with less imports
(info : BuildInfo) → m (BuildData info.key)
/-- A transformer to equip a monad with a build function for the Lake index. -/
abbrev IndexT (m : Type → Type v) := EquipT (IndexBuildFn m) m
/-- The monad for build functions that are part of the index. -/
abbrev IndexBuildM := IndexT RecBuildM
/-- Fetch the result associated with the info using the Lake build index. -/
@[inline] def BuildInfo.fetch (self : BuildInfo) [FamilyOut BuildData self.key α] : IndexBuildM α :=
fun build => cast (by simp) <| build self
export BuildInfo (fetch)
--------------------------------------------------------------------------------
/-! ## Build Info & Facets -/
--------------------------------------------------------------------------------
/-!
### Complex Builtin Facet Declarations
Additional builtin facets missing from `Build.Facets`.
These are defined here because they need configuration definitions
(e.g., `Module`), whereas the facets there are needed by the configuration
definitions.
-/
/-- The direct local imports of the Lean module. -/
abbrev Module.importsFacet := `lean.imports
module_data lean.imports : Array Module
/-- The transitive local imports of the Lean module. -/
abbrev Module.transImportsFacet := `lean.transImports
module_data lean.transImports : Array Module
/-- The transitive local imports of the Lean module. -/
abbrev Module.precompileImportsFacet := `lean.precompileImports
module_data lean.precompileImports : Array Module
/-- Shared library for `--load-dynlib`. -/
abbrev Module.dynlibFacet := `dynlib
module_data dynlib : BuildJob Dynlib
/-- A Lean library's Lean modules. -/
abbrev LeanLib.modulesFacet := `modules
library_data modules : Array Module
/-- The package's complete array of transitive dependencies. -/
abbrev Package.depsFacet := `deps
package_data deps : Array Package
/-!
### Facet Build Info Helper Constructors
Definitions to easily construct `BuildInfo` values for module, package,
and target facets.
-/
namespace Module
/-- Build info for the module's specified facet. -/
abbrev facet (facet : Name) (self : Module) : BuildInfo :=
.moduleFacet self facet
@[inherit_doc importsFacet] abbrev imports (self : Module) :=
self.facet importsFacet
@[inherit_doc transImportsFacet] abbrev transImports (self : Module) :=
self.facet transImportsFacet
@[inherit_doc precompileImportsFacet] abbrev precompileImports (self : Module) :=
self.facet precompileImportsFacet
@[inherit_doc depsFacet] abbrev deps (self : Module) :=
self.facet depsFacet
@[inherit_doc leanBinFacet] abbrev leanBin (self : Module) :=
self.facet leanBinFacet
@[inherit_doc importBinFacet] abbrev importBin (self : Module) :=
self.facet importBinFacet
@[inherit_doc oleanFacet] abbrev olean (self : Module) :=
self.facet oleanFacet
@[inherit_doc ileanFacet] abbrev ilean (self : Module) :=
self.facet ileanFacet
@[inherit_doc cFacet] abbrev c (self : Module) :=
self.facet cFacet
@[inherit_doc oFacet] abbrev o (self : Module) :=
self.facet oFacet
@[inherit_doc dynlibFacet] abbrev dynlib (self : Module) :=
self.facet dynlibFacet
end Module
/-- Build info for the package's specified facet. -/
abbrev Package.facet (facet : Name) (self : Package) : BuildInfo :=
.packageFacet self facet
@[inherit_doc releaseFacet]
abbrev Package.release (self : Package) : BuildInfo :=
self.facet releaseFacet
@[inherit_doc extraDepFacet]
abbrev Package.extraDep (self : Package) : BuildInfo :=
self.facet extraDepFacet
/-- Build info for a custom package target. -/
abbrev Package.target (target : Name) (self : Package) : BuildInfo :=
.target self target
/-- Build info of the Lean library's Lean binaries. -/
abbrev LeanLib.facet (self : LeanLib) (facet : Name) : BuildInfo :=
.libraryFacet self facet
@[inherit_doc modulesFacet]
abbrev LeanLib.modules (self : LeanLib) : BuildInfo :=
self.facet modulesFacet
@[inherit_doc leanFacet]
abbrev LeanLib.lean (self : LeanLib) : BuildInfo :=
self.facet leanFacet
@[inherit_doc staticFacet]
abbrev LeanLib.static (self : LeanLib) : BuildInfo :=
self.facet staticFacet
@[inherit_doc sharedFacet]
abbrev LeanLib.shared (self : LeanLib) : BuildInfo :=
self.facet sharedFacet
/-- Build info of the Lean executable. -/
abbrev LeanExe.exe (self : LeanExe) : BuildInfo :=
.leanExe self
/-- Build info of the external library's static binary. -/
abbrev ExternLib.static (self : ExternLib) : BuildInfo :=
.staticExternLib self
/-- Build info of the external library's shared binary. -/
abbrev ExternLib.shared (self : ExternLib) : BuildInfo :=
.sharedExternLib self
/-- Build info of the external library's dynlib. -/
abbrev ExternLib.dynlib (self : ExternLib) : BuildInfo :=
.dynlibExternLib self

View file

@ -0,0 +1,112 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.Async
import Lake.Build.Trace
import Lake.Build.Context
open System
namespace Lake
/-- A Lake job. -/
abbrev Job α := OptionIOTask α
/-- The monad of Lake jobs. -/
abbrev JobM := BuildM
/-- The monad of a finished Lake job. -/
abbrev ResultM := OptionIO
namespace Job
@[inline] def nil : Job Unit :=
pure ()
@[inline] protected def async (act : JobM α) : SchedulerM (Job α) :=
async act
@[inline] protected def await (self : Job α) : ResultM α :=
await self
@[inline] protected def bindSync
(self : Job α) (f : α → JobM β) (prio := Task.Priority.default) : SchedulerM (Job β) :=
bindSync prio self f
@[inline] protected def bindAsync
(self : Job α) (f : α → SchedulerM (Job β)) : SchedulerM (Job β) :=
bindAsync self f
end Job
/-- A Lake build job. -/
abbrev BuildJob α := Job (α × BuildTrace)
namespace BuildJob
@[inline] def mk (job : Job (α × BuildTrace)) : BuildJob α :=
job
@[inline] def ofJob (self : Job BuildTrace) : BuildJob Unit :=
mk <| ((), ·) <$> self
@[inline] def toJob (self : BuildJob α) : Job (α × BuildTrace) :=
self
@[inline] def nil : BuildJob Unit :=
mk <| pure ((), nilTrace)
@[inline] protected def pure (a : α) : BuildJob α :=
mk <| pure (a, nilTrace)
instance : Pure BuildJob := ⟨BuildJob.pure⟩
@[inline] protected def map (f : α → β) (self : BuildJob α) : BuildJob β :=
mk <| (fun (a,t) => (f a,t)) <$> self.toJob
instance : Functor BuildJob where
map := BuildJob.map
@[inline] def mapWithTrace (f : α → BuildTrace → β × BuildTrace) (self : BuildJob α) : BuildJob β :=
mk <| (fun (a,t) => f a t) <$> self.toJob
@[inline] protected def bindSync
(self : BuildJob α) (f : α → BuildTrace → JobM β)
(prio : Task.Priority := .default) : SchedulerM (Job β) :=
self.toJob.bindSync (prio := prio) fun (a, t) => f a t
@[inline] protected def bindAsync
(self : BuildJob α) (f : α → BuildTrace → SchedulerM (Job β)) : SchedulerM (Job β) :=
self.toJob.bindAsync fun (a, t) => f a t
@[inline] protected def await (self : BuildJob α) : ResultM α :=
(·.1) <$> await self.toJob
instance : Await BuildJob ResultM := ⟨BuildJob.await⟩
@[inline] def materialize (self : BuildJob α) : ResultM Unit :=
discard <| await self.toJob
def mix (t1 : BuildJob α) (t2 : BuildJob β) : BaseIO (BuildJob Unit) :=
mk <$> seqWithAsync (fun (_,t) (_,t') => ((), mixTrace t t')) t1.toJob t2.toJob
def mixList (jobs : List (BuildJob α)) : BaseIO (BuildJob Unit) := ofJob <$> do
jobs.foldrM (init := pure nilTrace) fun j a =>
seqWithAsync (fun (_,t') t => mixTrace t t') j.toJob a
def mixArray (jobs : Array (BuildJob α)) : BaseIO (BuildJob Unit) := ofJob <$> do
jobs.foldlM (init := pure nilTrace) fun a j =>
seqWithAsync (fun t (_,t') => mixTrace t t') a j.toJob
protected def seqWithAsync
(f : α → β → γ) (t1 : BuildJob α) (t2 : BuildJob β) : BaseIO (BuildJob γ) :=
mk <$> seqWithAsync (fun (a,t) (b,t') => (f a b, mixTrace t t')) t1.toJob t2.toJob
instance : SeqWithAsync BaseIO BuildJob := ⟨BuildJob.seqWithAsync⟩
def collectList (jobs : List (BuildJob α)) : BaseIO (BuildJob (List α)) :=
jobs.foldrM (seqWithAsync List.cons) (pure [])
def collectArray (jobs : Array (BuildJob α)) : BaseIO (BuildJob (Array α)) :=
jobs.foldlM (seqWithAsync Array.push) (pure #[])

View file

@ -0,0 +1,104 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.Name
namespace Lake
/-- The type of keys in the Lake build store. -/
inductive BuildKey
| moduleFacet (module : Name) (facet : Name)
| packageFacet (package : Name) (facet : Name)
| targetFacet (package : Name) (target : Name) (facet : Name)
| customTarget (package : Name) (target : Name)
deriving Inhabited, Repr, DecidableEq, Hashable
namespace BuildKey
def toString : (self : BuildKey) → String
| moduleFacet m f => s!"+{m}:{f}"
| packageFacet p f => s!"@{p}:{f}"
| targetFacet p t f => s!"{p}/{t}:{f}"
| customTarget p t => s!"{p}/{t}"
instance : ToString BuildKey := ⟨(·.toString)⟩
def quickCmp (k k' : BuildKey) : Ordering :=
match k with
| moduleFacet m f =>
match k' with
| moduleFacet m' f' =>
match m.quickCmp m' with
| .eq => f.quickCmp f'
| ord => ord
| _ => .lt
| packageFacet p f =>
match k' with
| moduleFacet .. => .gt
| packageFacet p' f' =>
match p.quickCmp p' with
| .eq => f.quickCmp f'
| ord => ord
| _ => .lt
| targetFacet p t f =>
match k' with
| customTarget .. => .lt
| targetFacet p' t' f' =>
match p.quickCmp p' with
| .eq =>
match t.quickCmp t' with
| .eq => f.quickCmp f'
| ord => ord
| ord => ord
| _=> .gt
| customTarget p t =>
match k' with
| customTarget p' t' =>
match p.quickCmp p' with
| .eq => t.quickCmp t'
| ord => ord
| _ => .gt
theorem eq_of_quickCmp {k k' : BuildKey} :
quickCmp k k' = Ordering.eq → k = k' := by
unfold quickCmp
cases k with
| moduleFacet m f =>
cases k'
case moduleFacet m' f' =>
dsimp only; split
next m_eq => intro f_eq; rw [eq_of_cmp m_eq, eq_of_cmp f_eq]
next => intro; contradiction
all_goals (intro; contradiction)
| packageFacet p f =>
cases k'
case packageFacet p' f' =>
dsimp only; split
next p_eq => intro f_eq; rw [eq_of_cmp p_eq, eq_of_cmp f_eq]
next => intro; contradiction
all_goals (intro; contradiction)
| targetFacet p t f =>
cases k'
case targetFacet p' t' f' =>
dsimp only; split
next p_eq =>
split
next t_eq =>
intro f_eq
rw [eq_of_cmp p_eq, eq_of_cmp t_eq, eq_of_cmp f_eq]
next => intro; contradiction
next => intro; contradiction
all_goals (intro; contradiction)
| customTarget p t =>
cases k'
case customTarget p' t' =>
dsimp only; split
next p_eq => intro t_eq; rw [eq_of_cmp p_eq, eq_of_cmp t_eq]
next => intro; contradiction
all_goals (intro; contradiction)
instance : LawfulCmpEq BuildKey quickCmp where
eq_of_cmp := eq_of_quickCmp
cmp_rfl {k} := by cases k <;> simp [quickCmp]

View file

@ -0,0 +1,111 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Common
namespace Lake
/-- Get the Lean library in the workspace with the configuration's name. -/
@[inline] def LeanLibConfig.get (self : LeanLibConfig)
[Monad m] [MonadError m] [MonadLake m] : m LeanLib := do
let some lib ← findLeanLib? self.name
| error "Lean library '{self.name}' does not exist in the workspace"
return lib
/-- Fetch the build result of a library facet. -/
@[inline] protected def LibraryFacetDecl.fetch (lib : LeanLib)
(self : LibraryFacetDecl) [FamilyOut LibraryData self.name α] : IndexBuildM α := do
fetch <| lib.facet self.name
/-- Fetch the build job of a library facet. -/
def LibraryFacetConfig.fetchJob (lib : LeanLib)
(self : LibraryFacetConfig name) : IndexBuildM (BuildJob Unit) := do
let some getJob := self.getJob?
| error "library facet '{self.name}' has no associated build job"
return getJob <| ← fetch <| lib.facet self.name
/-- Fetch the build job of a library facet. -/
def LeanLib.fetchFacetJob
(name : Name) (self : LeanLib) : IndexBuildM (BuildJob Unit) := do
let some config := (← getWorkspace).libraryFacetConfigs.find? name
| error "library facet '{name}' does not exist in workspace"
inline <| config.fetchJob self
/-! # Build Lean & Static Lib -/
/--
Collect the local modules of a library.
That is, the modules from `getModuleArray` plus their local transitive imports.
-/
partial def LeanLib.recCollectLocalModules (self : LeanLib) : IndexBuildM (Array Module) := do
let mut mods := #[]
let mut modSet := ModuleSet.empty
for mod in (← self.getModuleArray) do
(mods, modSet) ← go mod mods modSet
return mods
where
go root mods modSet := do
let mut mods := mods
let mut modSet := modSet
unless modSet.contains root do
modSet := modSet.insert root
let imps ← root.imports.fetch
for mod in imps do
if self.isLocalModule mod.name then
(mods, modSet) ← go mod mods modSet
mods := mods.push root
return (mods, modSet)
/-- The `LibraryFacetConfig` for the builtin `modulesFacet`. -/
def LeanLib.modulesFacetConfig : LibraryFacetConfig modulesFacet :=
mkFacetConfig LeanLib.recCollectLocalModules
protected def LeanLib.recBuildLean
(self : LeanLib) : IndexBuildM (BuildJob Unit) := do
let mods ← self.modules.fetch
mods.foldlM (init := BuildJob.nil) fun job mod => do
job.mix <| ← mod.leanBin.fetch
/-- The `LibraryFacetConfig` for the builtin `leanFacet`. -/
def LeanLib.leanFacetConfig : LibraryFacetConfig leanFacet :=
mkFacetJobConfigSmall LeanLib.recBuildLean
protected def LeanLib.recBuildStatic
(self : LeanLib) : IndexBuildM (BuildJob FilePath) := do
let mods ← self.modules.fetch
let oJobs ← mods.concatMapM fun mod =>
mod.nativeFacets.mapM fun facet => fetch <| mod.facet facet.name
buildStaticLib self.staticLibFile oJobs
/-- The `LibraryFacetConfig` for the builtin `staticFacet`. -/
def LeanLib.staticFacetConfig : LibraryFacetConfig staticFacet :=
mkFacetJobConfig LeanLib.recBuildStatic
/-! # Build Shared Lib -/
protected def LeanLib.recBuildShared
(self : LeanLib) : IndexBuildM (BuildJob FilePath) := do
let mods ← self.modules.fetch
let oJobs ← mods.concatMapM fun mod =>
mod.nativeFacets.mapM fun facet => fetch <| mod.facet facet.name
let pkgs := mods.foldl (·.insert ·.pkg) OrdPackageSet.empty |>.toArray
let externJobs ← pkgs.concatMapM (·.externLibs.mapM (·.shared.fetch))
buildLeanSharedLib self.sharedLibFile (oJobs ++ externJobs) self.linkArgs
/-- The `LibraryFacetConfig` for the builtin `sharedFacet`. -/
def LeanLib.sharedFacetConfig : LibraryFacetConfig sharedFacet :=
mkFacetJobConfig LeanLib.recBuildShared
open LeanLib in
/--
A library facet name to build function map that contains builders for
the initial set of Lake library facets (e.g., `lean`, `static`, and `shared`).
-/
def initLibraryFacetConfigs : DNameMap LibraryFacetConfig :=
DNameMap.empty
|>.insert modulesFacet modulesFacetConfig
|>.insert leanFacet leanFacetConfig
|>.insert staticFacet staticFacetConfig
|>.insert sharedFacet sharedFacetConfig

View file

@ -0,0 +1,255 @@
/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich, Mac Malone
-/
import Lake.Util.OrdHashSet
import Lean.Elab.ParseImportsFast
import Lake.Build.Common
open System
namespace Lake
/-- Fetch the build result of a module facet. -/
@[inline] protected def ModuleFacetDecl.fetch (mod : Module)
(self : ModuleFacetDecl) [FamilyOut ModuleData self.name α] : IndexBuildM α := do
fetch <| mod.facet self.name
/-- Fetch the build job of a module facet. -/
def ModuleFacetConfig.fetchJob (mod : Module)
(self : ModuleFacetConfig name) : IndexBuildM (BuildJob Unit) := do
let some getJob := self.getJob?
| error "module facet '{self.name}' has no associated build job"
return getJob <| ← fetch <| mod.facet self.name
/-- Fetch the build job of a module facet. -/
def Module.fetchFacetJob
(name : Name) (self : Module) : IndexBuildM (BuildJob Unit) := do
let some config := (← getWorkspace).moduleFacetConfigs.find? name
| error "library facet '{name}' does not exist in workspace"
inline <| config.fetchJob self
def Module.buildUnlessUpToDate (mod : Module)
(dynlibPath : SearchPath) (dynlibs : Array FilePath)
(depTrace : BuildTrace) : BuildM PUnit := do
let isOldMode ← getIsOldMode
let argTrace : BuildTrace := pureHash mod.leanArgs
let srcTrace : BuildTrace ← computeTrace { path := mod.leanFile : TextFilePath }
let modTrace := (← getLeanTrace).mix <| argTrace.mix <| srcTrace.mix depTrace
let modUpToDate ← do
if isOldMode then
srcTrace.checkAgainstTime mod
else
modTrace.checkAgainstFile mod mod.traceFile
let name := mod.name.toString
unless modUpToDate do
compileLeanModule name mod.leanFile mod.oleanFile mod.ileanFile mod.cFile
(← getLeanPath) mod.rootDir dynlibs dynlibPath (mod.leanArgs ++ mod.weakLeanArgs) (← getLean)
unless isOldMode do
modTrace.writeToFile mod.traceFile
/-- Compute library directories and build external library Jobs of the given packages. -/
def recBuildExternDynlibs (pkgs : Array Package)
: IndexBuildM (Array (BuildJob Dynlib) × Array FilePath) := do
let mut libDirs := #[]
let mut jobs : Array (BuildJob Dynlib) := #[]
for pkg in pkgs do
libDirs := libDirs.push pkg.nativeLibDir
jobs := jobs.append <| ← pkg.externLibs.mapM (·.dynlib.fetch)
return (jobs, libDirs)
/--
Build the dynlibs of the transitive imports that want precompilation
and the dynlibs of *their* imports.
-/
partial def recBuildPrecompileDynlibs (imports : Array Module)
: IndexBuildM (Array (BuildJob Dynlib) × Array (BuildJob Dynlib) × Array FilePath) := do
let (pkgs, _, jobs) ←
go imports OrdPackageSet.empty ModuleSet.empty #[] false
return (jobs, ← recBuildExternDynlibs pkgs.toArray)
where
go imports pkgs modSet jobs shouldPrecompile := do
let mut pkgs := pkgs
let mut modSet := modSet
let mut jobs := jobs
for mod in imports do
if modSet.contains mod then
continue
modSet := modSet.insert mod
let shouldPrecompile := shouldPrecompile || mod.shouldPrecompile
if shouldPrecompile then
pkgs := pkgs.insert mod.pkg
jobs := jobs.push <| (← mod.dynlib.fetch)
let recImports ← mod.imports.fetch
(pkgs, modSet, jobs) ← go recImports pkgs modSet jobs shouldPrecompile
return (pkgs, modSet, jobs)
variable [MonadLiftT BuildM m]
/--
Recursively parse the Lean files of a module and its imports
building an `Array` product of its direct local imports.
-/
def Module.recParseImports (mod : Module) : IndexBuildM (Array Module) := do
let contents ← IO.FS.readFile mod.leanFile
let imports ← Lean.parseImports' contents mod.leanFile.toString
let mods ← imports.foldlM (init := OrdModuleSet.empty) fun set imp =>
findModule? imp.module <&> fun | some mod => set.insert mod | none => set
return mods.toArray
/-- The `ModuleFacetConfig` for the builtin `importsFacet`. -/
def Module.importsFacetConfig : ModuleFacetConfig importsFacet :=
mkFacetConfig (·.recParseImports)
/-- Recursively compute a module's transitive imports. -/
def Module.recComputeTransImports (mod : Module) : IndexBuildM (Array Module) := do
(·.toArray) <$> (← mod.imports.fetch).foldlM (init := OrdModuleSet.empty) fun set imp => do
return set.appendArray (← imp.transImports.fetch) |>.insert imp
/-- The `ModuleFacetConfig` for the builtin `transImportsFacet`. -/
def Module.transImportsFacetConfig : ModuleFacetConfig transImportsFacet :=
mkFacetConfig (·.recComputeTransImports)
/-- Recursively compute a module's precompiled imports. -/
def Module.recComputePrecompileImports (mod : Module) : IndexBuildM (Array Module) := do
(·.toArray) <$> (← mod.imports.fetch).foldlM (init := OrdModuleSet.empty) fun set imp => do
if imp.shouldPrecompile then
return set.appendArray (← imp.transImports.fetch) |>.insert imp
else
return set.appendArray (← imp.precompileImports.fetch)
/-- The `ModuleFacetConfig` for the builtin `precompileImportsFacet`. -/
def Module.precompileImportsFacetConfig : ModuleFacetConfig precompileImportsFacet :=
mkFacetConfig (·.recComputePrecompileImports)
/-- Recursively build a module's transitive local imports and shared library dependencies. -/
def Module.recBuildDeps (mod : Module) : IndexBuildM (BuildJob (SearchPath × Array FilePath)) := do
let imports ← mod.imports.fetch
let extraDepJob ← mod.pkg.extraDep.fetch
let precompileImports ← mod.precompileImports.fetch
let modJobs ← precompileImports.mapM (·.dynlib.fetch)
let pkgs := precompileImports.foldl (·.insert ·.pkg)
OrdPackageSet.empty |>.insert mod.pkg |>.toArray
let (externJobs, libDirs) ← recBuildExternDynlibs pkgs
let importJob ← BuildJob.mixArray <| ← imports.mapM (·.importBin.fetch)
let externDynlibsJob ← BuildJob.collectArray externJobs
let modDynlibsJob ← BuildJob.collectArray modJobs
extraDepJob.bindAsync fun _ _ => do
importJob.bindAsync fun _ importTrace => do
modDynlibsJob.bindAsync fun modDynlibs modTrace => do
return externDynlibsJob.mapWithTrace fun externDynlibs externTrace =>
let depTrace := importTrace.mix <| modTrace.mix externTrace
/-
Requirements:
* Lean wants the external library symbols before module symbols.
* Unix requires the file extension of the dynlib.
* For some reason, building from the Lean server requires full paths.
Everything else loads fine with just the augmented library path.
* Linux still needs the augmented path to resolve nested dependencies in dynlibs.
-/
let dynlibPath := libDirs ++ externDynlibs.filterMap (·.dir?) |>.toList
let dynlibs := externDynlibs.map (·.path) ++ modDynlibs.map (·.path)
((dynlibPath, dynlibs), depTrace)
/-- The `ModuleFacetConfig` for the builtin `depsFacet`. -/
def Module.depsFacetConfig : ModuleFacetConfig depsFacet :=
mkFacetJobConfigSmall (·.recBuildDeps)
/-- Recursively build a module and its dependencies. -/
def Module.recBuildLeanCore (mod : Module) : IndexBuildM (BuildJob Unit) := do
(← mod.deps.fetch).bindSync fun (dynlibPath, dynlibs) depTrace => do
mod.buildUnlessUpToDate dynlibPath dynlibs depTrace
return ((), depTrace)
/-- The `ModuleFacetConfig` for the builtin `leanBinFacet`. -/
def Module.leanBinFacetConfig : ModuleFacetConfig leanBinFacet :=
mkFacetJobConfig (·.recBuildLeanCore)
/-- The `ModuleFacetConfig` for the builtin `importBinFacet`. -/
def Module.importBinFacetConfig : ModuleFacetConfig importBinFacet :=
mkFacetJobConfigSmall fun mod => do
(← mod.leanBin.fetch).bindSync fun _ depTrace =>
return ((), mixTrace (← computeTrace mod) depTrace)
/-- The `ModuleFacetConfig` for the builtin `oleanFacet`. -/
def Module.oleanFacetConfig : ModuleFacetConfig oleanFacet :=
mkFacetJobConfigSmall fun mod => do
(← mod.leanBin.fetch).bindSync fun _ depTrace =>
return (mod.oleanFile, mixTrace (← computeTrace mod.oleanFile) depTrace)
/-- The `ModuleFacetConfig` for the builtin `ileanFacet`. -/
def Module.ileanFacetConfig : ModuleFacetConfig ileanFacet :=
mkFacetJobConfigSmall fun mod => do
(← mod.leanBin.fetch).bindSync fun _ depTrace =>
return (mod.ileanFile, mixTrace (← computeTrace mod.ileanFile) depTrace)
/-- The `ModuleFacetConfig` for the builtin `cFacet`. -/
def Module.cFacetConfig : ModuleFacetConfig cFacet :=
mkFacetJobConfigSmall fun mod => do
(← mod.leanBin.fetch).bindSync fun _ _ =>
-- do content-aware hashing so that we avoid recompiling unchanged C files
return (mod.cFile, ← computeTrace mod.cFile)
/-- Recursively build the module's object file from its C file produced by `lean`. -/
def Module.recBuildLeanO (self : Module) : IndexBuildM (BuildJob FilePath) := do
buildLeanO self.name.toString self.oFile (← self.c.fetch) self.leancArgs
/-- The `ModuleFacetConfig` for the builtin `oFacet`. -/
def Module.oFacetConfig : ModuleFacetConfig oFacet :=
mkFacetJobConfig Module.recBuildLeanO
-- TODO: Return `BuildJob OrdModuleSet × OrdPackageSet` or `OrdRBSet Dynlib`
/-- Recursively build the shared library of a module (e.g., for `--load-dynlib`). -/
def Module.recBuildDynlib (mod : Module) : IndexBuildM (BuildJob Dynlib) := do
-- Compute dependencies
let transImports ← mod.transImports.fetch
let modJobs ← transImports.mapM (·.dynlib.fetch)
let pkgs := transImports.foldl (·.insert ·.pkg)
OrdPackageSet.empty |>.insert mod.pkg |>.toArray
let (externJobs, pkgLibDirs) ← recBuildExternDynlibs pkgs
let linkJobs ← mod.nativeFacets.mapM (fetch <| mod.facet ·.name)
-- Collect Jobs
let linksJob ← BuildJob.collectArray linkJobs
let modDynlibsJob ← BuildJob.collectArray modJobs
let externDynlibsJob ← BuildJob.collectArray externJobs
-- Build dynlib
show SchedulerM _ from do
linksJob.bindAsync fun links oTrace => do
modDynlibsJob.bindAsync fun modDynlibs libTrace => do
externDynlibsJob.bindSync fun externDynlibs externTrace => do
let libNames := modDynlibs.map (·.name) ++ externDynlibs.map (·.name)
let libDirs := pkgLibDirs ++ externDynlibs.filterMap (·.dir?)
let depTrace := oTrace.mix <| libTrace.mix externTrace
let trace ← buildFileUnlessUpToDate mod.dynlibFile depTrace do
let args := links.map toString ++
libDirs.map (s!"-L{·}") ++ libNames.map (s!"-l{·}")
compileSharedLib mod.name.toString mod.dynlibFile args (← getLeanc)
return (⟨mod.dynlibFile, mod.dynlibName⟩, trace)
/-- The `ModuleFacetConfig` for the builtin `dynlibFacet`. -/
def Module.dynlibFacetConfig : ModuleFacetConfig dynlibFacet :=
mkFacetJobConfig Module.recBuildDynlib
open Module in
/--
A name-configuration map for the initial set of
Lake module facets (e.g., `lean.{imports, c, o, dynlib]`).
-/
def initModuleFacetConfigs : DNameMap ModuleFacetConfig :=
DNameMap.empty
|>.insert importsFacet importsFacetConfig
|>.insert transImportsFacet transImportsFacetConfig
|>.insert precompileImportsFacet precompileImportsFacetConfig
|>.insert depsFacet depsFacetConfig
|>.insert leanBinFacet leanBinFacetConfig
|>.insert importBinFacet importBinFacetConfig
|>.insert oleanFacet oleanFacetConfig
|>.insert ileanFacet ileanFacetConfig
|>.insert cFacet cFacetConfig
|>.insert oFacet oFacetConfig
|>.insert dynlibFacet dynlibFacetConfig

View file

@ -0,0 +1,57 @@
/-
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
def mkBuildContext (ws : Workspace) (oldMode : Bool) : IO BuildContext := do
let lean := ws.lakeEnv.lean
let leanTrace := Hash.ofString lean.githash
return {
opaqueWs := ws, leanTrace, oldMode
startedBuilds := ← IO.mkRef 0
finishedBuilds := ← IO.mkRef 0
}
@[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

View file

@ -0,0 +1,122 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.Sugar
import Lake.Build.Common
open System
namespace Lake
/-- Fetch the build job of the specified package target. -/
def Package.fetchTargetJob (self : Package)
(target : Name) : IndexBuildM (Option (BuildJob Unit)) := do
let some config := self.findTargetConfig? target
| error s!"package '{self.name}' has no target '{target}'"
return config.getJob (← fetch <| self.target target)
/-- Fetch the build result of a target. -/
protected def TargetDecl.fetch (self : TargetDecl)
[FamilyDef CustomData (self.pkg, self.name) α] : IndexBuildM α := do
let some pkg ← findPackage? self.pkg
| error s!"package '{self.pkg}' of target '{self.name}' does not exist in workspace"
fetch <| pkg.target self.name
/-- Fetch the build job of the target. -/
def TargetDecl.fetchJob (self : TargetDecl) : IndexBuildM (BuildJob Unit) := do
let some pkg ← findPackage? self.pkg
| error s!"package '{self.pkg}' of target '{self.name}' does not exist in workspace"
return self.config.getJob (← fetch <| pkg.target self.name)
/-- Fetch the build result of a package facet. -/
@[inline] protected def PackageFacetDecl.fetch (pkg : Package)
(self : PackageFacetDecl) [FamilyOut PackageData self.name α] : IndexBuildM α := do
fetch <| pkg.facet self.name
/-- Fetch the build job of a package facet. -/
def PackageFacetConfig.fetchJob (pkg : Package)
(self : PackageFacetConfig name) : IndexBuildM (BuildJob Unit) := do
let some getJob := self.getJob?
| error "package facet '{pkg.name}' has no associated build job"
return getJob <| ← fetch <| pkg.facet self.name
/-- Fetch the build job of a library facet. -/
def Package.fetchFacetJob
(name : Name) (self : Package) : IndexBuildM (BuildJob Unit) := do
let some config := (← getWorkspace).packageFacetConfigs.find? name
| error "package facet '{name}' does not exist in workspace"
inline <| config.fetchJob self
/-- Compute a topological ordering of the package's transitive dependencies. -/
def Package.recComputeDeps (self : Package) : IndexBuildM (Array Package) := do
let mut deps := #[]
let mut depSet := PackageSet.empty
for dep in self.deps do
for depDep in (← fetch <| dep.facet `deps) do
unless depSet.contains depDep do
deps := deps.push depDep
depSet := depSet.insert depDep
unless depSet.contains dep do
deps := deps.push dep
depSet := depSet.insert dep
return deps
/-- The `PackageFacetConfig` for the builtin `depsFacet`. -/
def Package.depsFacetConfig : PackageFacetConfig depsFacet :=
mkFacetConfig Package.recComputeDeps
/--
Build the `extraDepTarget` for the package and its transitive dependencies.
Also fetch pre-built releases for the package's' dependencies.
-/
def Package.recBuildExtraDepTargets (self : Package) : IndexBuildM (BuildJob Unit) := do
let mut job := BuildJob.nil
-- Build dependencies' extra dep targets
for dep in self.deps do
job ← job.mix <| ← dep.extraDep.fetch
-- Fetch pre-built release if desired and this package is a dependency
if self.name ≠ (← getWorkspace).root.name ∧ self.preferReleaseBuild then
job ← job.mix <| ← self.release.fetch
-- Build this package's extra dep targets
for target in self.extraDepTargets do
if let some config := self.findTargetConfig? target then
job ← job.mix <| config.getJob <| ← fetch <| self.target target
else
error s!"unknown target `{target}`"
return job
/-- The `PackageFacetConfig` for the builtin `dynlibFacet`. -/
def Package.extraDepFacetConfig : PackageFacetConfig extraDepFacet :=
mkFacetJobConfigSmall Package.recBuildExtraDepTargets
/-- Download and unpack the package's prebuilt release archive (from GitHub). -/
def Package.fetchRelease (self : Package) : SchedulerM (BuildJob Unit) := Job.async do
let some (repoUrl, tag) := self.release? | do
logWarning "wanted prebuilt release, but release repository and tag was not known"
return ((), .nil)
let url := s!"{repoUrl}/releases/download/{tag}/{self.buildArchive}"
let logName := s!"{self.name}/{tag}/{self.buildArchive}"
try
let depTrace := Hash.ofString url
let trace ← buildFileUnlessUpToDate self.buildArchiveFile depTrace do
download logName url self.buildArchiveFile
untar logName self.buildArchiveFile self.buildDir
return ((), trace)
else
return ((), .nil)
/-- The `PackageFacetConfig` for the builtin `releaseFacet`. -/
def Package.releaseFacetConfig : PackageFacetConfig releaseFacet :=
mkFacetJobConfig (·.fetchRelease)
open Package in
/--
A package facet name to build function map that contains builders for
the initial set of Lake package facets (e.g., `extraDep`).
-/
def initPackageFacetConfigs : DNameMap PackageFacetConfig :=
DNameMap.empty
|>.insert depsFacet depsFacetConfig
|>.insert extraDepFacet extraDepFacetConfig
|>.insert releaseFacet releaseFacetConfig

View file

@ -0,0 +1,88 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Data
import Lake.Util.StoreInsts
/-!
# The Lake Build Store
The Lake build store is the map of Lake build keys to build task and/or
build results that is slowly filled during a recursive build (e.g., via
topological-based build of an initial key's dependencies).
-/
namespace Lake
/-- A monad equipped with a Lake build store. -/
abbrev MonadBuildStore (m) := MonadDStore BuildKey BuildData m
/-- The type of the Lake build store. -/
abbrev BuildStore :=
DRBMap BuildKey BuildData BuildKey.quickCmp
@[inline] def BuildStore.empty : BuildStore := DRBMap.empty
namespace BuildStore
-- Linter reports false positives on the `v` variables below
set_option linter.unusedVariables false
/-- Derive an array of built module facets from the store. -/
def collectModuleFacetArray (self : BuildStore)
(facet : Name) [FamilyOut ModuleData facet α] : Array α := Id.run do
let mut res : Array α := #[]
for ⟨k, v⟩ in self do
match k with
| .moduleFacet m f =>
if h : f = facet then
have of_data := by unfold BuildData; simp [h]
res := res.push <| cast of_data v
| _ => pure ()
return res
/-- Derive a map of module names to built facets from the store. -/
def collectModuleFacetMap (self : BuildStore)
(facet : Name) [FamilyOut ModuleData facet α] : NameMap α := Id.run do
let mut res := Lean.mkNameMap α
for ⟨k, v⟩ in self do
match k with
| .moduleFacet m f =>
if h : f = facet then
have of_data := by unfold BuildData; simp [h]
res := res.insert m <| cast of_data v
| _ => pure ()
return res
/-- Derive an array of built package facets from the store. -/
def collectPackageFacetArray (self : BuildStore)
(facet : Name) [FamilyOut PackageData facet α] : Array α := Id.run do
let mut res : Array α := #[]
for ⟨k, v⟩ in self do
match k with
| .packageFacet _ f =>
if h : f = facet then
have of_data := by unfold BuildData; simp [h]
res := res.push <| cast of_data v
| _ => pure ()
return res
/-- Derive an array of built target facets from the store. -/
def collectTargetFacetArray (self : BuildStore)
(facet : Name) [FamilyOut TargetData facet α] : Array α := Id.run do
let mut res : Array α := #[]
for ⟨k, v⟩ in self do
match k with
| .targetFacet _ _ f =>
if h : f = facet then
have of_data := by unfold BuildData; simp [h]
res := res.push <| cast of_data v
| _ => pure ()
return res
/-- Derive an array of built external shared libraries from the store. -/
def collectSharedExternLibs (self : BuildStore)
[FamilyOut TargetData `externLib.shared α] : Array α :=
self.collectTargetFacetArray `externLib.shared

View file

@ -0,0 +1,139 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.Cycle
import Lake.Util.Store
import Lake.Util.EquipT
/-!
# Topological / Suspending Recursive Builder
This module defines a recursive build function that topologically
(ι.e., via a depth-first search with memoization) builds the elements of
a build store.
This is called a suspending scheduler in *Build systems à la carte*.
-/
namespace Lake
/-!
## Recursive Fetching
In this section, we define the primitives that make up a builder.
-/
/--
A dependently typed monadic *fetch* function.
That is, a function within the monad `m` and takes an input `a : α`
describing what to fetch and and produces some output `b : β a` (dependently
typed) or `b : B` (not) describing what was fetched. All build functions are
fetch functions, but not all fetch functions need build something.
-/
abbrev DFetchFn (α : Type u) (β : α → Type v) (m : Type v → Type w) :=
(a : α) → m (β a)
/-!
In order to nest builds / fetches within one another,
we equip the monad `m` with a fetch function of its own.
-/
/-- A transformer that equips a monad with a `DFetchFn`. -/
abbrev DFetchT (α : Type u) (β : α → Type v) (m : Type v → Type w) :=
EquipT (DFetchFn α β m) m
/-- A `DFetchT` that is not dependently typed. -/
abbrev FetchT (α : Type u) (β : Type v) (m : Type v → Type w) :=
DFetchT α (fun _ => β) m
/-!
We can then use the such a monad as the basis for a fetch function itself.
-/
/-
A `DFetchFn` that utilizes another `DFetchFn` equipped to the monad to
fetch values. It is thus usually implemented recursively via some variation
of the `recFetch` function below, hence the "rec" in both names.
-/
abbrev DRecFetchFn (α : Type u) (β : α → Type v) (m : Type v → Type w) :=
DFetchFn α β (DFetchT α β m)
/-- A `DRecFetchFn` that is not dependently typed. -/
abbrev RecFetchFn (α : Type u) (β : Type v) (m : Type v → Type w) :=
α → FetchT α β m β
/-- A `DFetchFn` that provides its base `DRecFetchFn` with itself. -/
@[specialize] partial def recFetch
[(α : Type u) → Nonempty (m α)] (fetch : DRecFetchFn α β m) : DFetchFn α β m :=
fun a => fetch a (recFetch fetch)
/-!
The basic `recFetch` can fail to terminate in a variety of ways,
it can even cycle (i.e., `a` fetches `b` which fetches `a`). Thus, we
define the `acyclicRecFetch` below to guard against such cases.
-/
/--
A `recFetch` augmented by a `CycleT` to guard against recursive cycles.
If the set of visited keys is finite, this function should provably terminate.
We use `keyOf` to the derive the unique key of a fetch from its descriptor
`a : α`. We do this because descriptors may not be comparable and/or contain
more information than necessary to determine uniqueness.
-/
@[inline] partial def recFetchAcyclic [BEq κ] [Monad m]
(keyOf : α → κ) (fetch : DRecFetchFn α β (CycleT κ m)) : DFetchFn α β (CycleT κ m) :=
recFetch fun a recurse =>
/-
NOTE: We provide the stack directly to `recurse` rather than
get it through `ReaderT` to prevent it being overridden by the `fetch`
function (and thereby potentially produce a cycle).
-/
guardCycle (keyOf a) fun stack => fetch a (recurse · stack) stack
/-!
When building, we usually do not want to build the same thing twice during
a single build pass. At the same time, separate builds may both wish to fetch
the same thing. Thus, we need to store past build results to return them upon
future fetches. This is what `recFetchMemoize` below does.
-/
/--
`recFetchAcyclic` augmented with a `MonadDStore` to
memoize fetch results and thus avoid computing the same result twice.
-/
@[inline] def recFetchMemoize [BEq κ] [Monad m] [MonadDStore κ β m]
(keyOf : α → κ) (fetch : DRecFetchFn α (fun a => β (keyOf a)) (CycleT κ m))
: DFetchFn α (fun a => β (keyOf a)) (CycleT κ m) :=
recFetchAcyclic keyOf fun a recurse =>
fetchOrCreate (keyOf a) do fetch a recurse
/-!
## Building
In this section, we use the abstractions we have just created to define
the desired topological recursive build function (a.k.a. a suspending scheduler).
-/
/-- Recursively builds objects for the keys `κ`, avoiding cycles. -/
@[inline] def buildAcyclic [BEq κ] [Monad m]
(keyOf : α → κ) (a : α) (build : RecFetchFn α β (CycleT κ m)) : ExceptT (Cycle κ) m β :=
recFetchAcyclic (β := fun _ => β) keyOf build a []
/-- Dependently typed version of `buildTop`. -/
@[inline] def buildDTop (β) [BEq κ] [Monad m] [MonadDStore κ β m]
(keyOf : α → κ) (a : α) (build : DRecFetchFn α (fun a => β (keyOf a)) (CycleT κ m))
: ExceptT (Cycle κ) m (β (keyOf a)) :=
recFetchMemoize keyOf build a []
/--
Recursively fills a `MonadStore` of key-object pairs by
building objects topologically (ι.e., depth-first with memoization).
If a cycle is detected, the list of keys traversed is thrown.
-/
@[inline] def buildTop [BEq κ] [Monad m] [MonadStore κ β m]
(keyOf : α → κ) (a : α) (build : RecFetchFn α β (CycleT κ m)) : ExceptT (Cycle κ) m β :=
recFetchMemoize (β := fun _ => β) keyOf build a []

View file

@ -0,0 +1,273 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
open System
namespace Lake
--------------------------------------------------------------------------------
/-! # Utilities -/
--------------------------------------------------------------------------------
class CheckExists.{u} (i : Type u) where
/-- Check whether there already exists an artifact for the given target info. -/
checkExists : i → BaseIO Bool
export CheckExists (checkExists)
instance : CheckExists FilePath where
checkExists := FilePath.pathExists
--------------------------------------------------------------------------------
/-! # Trace Abstraction -/
--------------------------------------------------------------------------------
class ComputeTrace.{u,v,w} (i : Type u) (m : outParam $ Type v → Type w) (t : Type v) where
/-- Compute the trace of some target info using information from the monadic context. -/
computeTrace : i → m t
def computeTrace [ComputeTrace i m t] [MonadLiftT m n] (info : i) : n t :=
liftM <| ComputeTrace.computeTrace info
class NilTrace.{u} (t : Type u) where
/-- The nil trace. Should not unduly clash with a proper trace. -/
nilTrace : t
export NilTrace (nilTrace)
instance [NilTrace t] : Inhabited t := ⟨nilTrace⟩
class MixTrace.{u} (t : Type u) where
/-- Combine two traces. The result should be dirty if either of the inputs is dirty. -/
mixTrace : t → t → t
export MixTrace (mixTrace)
def mixTraceM [MixTrace t] [Pure m] (t1 t2 : t) : m t :=
pure <| mixTrace t1 t2
section
variable [MixTrace t] [NilTrace t]
def mixTraceList (traces : List t) : t :=
traces.foldl mixTrace nilTrace
def mixTraceArray (traces : Array t) : t :=
traces.foldl mixTrace nilTrace
variable [ComputeTrace i m t]
def computeListTrace [MonadLiftT m n] [Monad n] (artifacts : List i) : n t :=
mixTraceList <$> artifacts.mapM computeTrace
instance [Monad m] : ComputeTrace (List i) m t := ⟨computeListTrace⟩
def computeArrayTrace [MonadLiftT m n] [Monad n] (artifacts : Array i) : n t :=
mixTraceArray <$> artifacts.mapM computeTrace
instance [Monad m] : ComputeTrace (Array i) m t := ⟨computeArrayTrace⟩
end
--------------------------------------------------------------------------------
/-! # Hash Trace -/
--------------------------------------------------------------------------------
/--
A content hash.
TODO: Use a secure hash rather than the builtin Lean hash function.
-/
structure Hash where
val : UInt64
deriving BEq, DecidableEq, Repr
namespace Hash
def ofNat (n : Nat) :=
mk n.toUInt64
def loadFromFile (hashFile : FilePath) : IO (Option Hash) :=
return (← IO.FS.readFile hashFile).toNat?.map ofNat
def nil : Hash :=
mk <| 1723 -- same as Name.anonymous
instance : NilTrace Hash := ⟨nil⟩
def mix (h1 h2 : Hash) : Hash :=
mk <| mixHash h1.val h2.val
instance : MixTrace Hash := ⟨mix⟩
protected def toString (self : Hash) : String :=
toString self.val
instance : ToString Hash := ⟨Hash.toString⟩
def ofString (str : String) :=
mix nil <| mk <| hash str -- same as Name.mkSimple
def ofByteArray (bytes : ByteArray) : Hash :=
⟨hash bytes⟩
end Hash
class ComputeHash (α : Type u) (m : outParam $ Type → Type v) where
computeHash : α → m Hash
instance [ComputeHash α m] : ComputeTrace α m Hash := ⟨ComputeHash.computeHash⟩
def pureHash [ComputeHash α Id] (a : α) : Hash :=
ComputeHash.computeHash a
def computeHash [ComputeHash α m] [MonadLiftT m n] (a : α) : n Hash :=
liftM <| ComputeHash.computeHash a
instance : ComputeHash String Id := ⟨Hash.ofString⟩
def computeFileHash (file : FilePath) : IO Hash :=
Hash.ofByteArray <$> IO.FS.readBinFile file
instance : ComputeHash FilePath IO := ⟨computeFileHash⟩
/--
A wrapper around `FilePath` that adjusts its `ComputeHash` implementation
to normalize `\r\n` sequences to `\n` for cross-platform compatibility. -/
structure TextFilePath where
path : FilePath
instance : ComputeHash TextFilePath IO where
computeHash file := do
let text ← IO.FS.readFile file.path
let text := text.replace "\r\n" "\n"
return Hash.ofString text
instance [ComputeHash α m] [Monad m] : ComputeHash (Array α) m where
computeHash ar := ar.foldlM (fun b a => Hash.mix b <$> computeHash a) Hash.nil
--------------------------------------------------------------------------------
/-! # Modification Time (MTime) Trace -/
--------------------------------------------------------------------------------
open IO.FS (SystemTime)
/-- A modification time. -/
def MTime := SystemTime
namespace MTime
instance : OfNat MTime (nat_lit 0) := ⟨⟨0,0⟩⟩
instance : BEq MTime := inferInstanceAs (BEq SystemTime)
instance : Repr MTime := inferInstanceAs (Repr SystemTime)
instance : Ord MTime := inferInstanceAs (Ord SystemTime)
instance : LT MTime := ltOfOrd
instance : LE MTime := leOfOrd
instance : Min MTime := minOfLe
instance : Max MTime := maxOfLe
instance : NilTrace MTime := ⟨0⟩
instance : MixTrace MTime := ⟨max⟩
end MTime
class GetMTime (α) where
getMTime : α → IO MTime
export GetMTime (getMTime)
instance [GetMTime α] : ComputeTrace α IO MTime := ⟨getMTime⟩
def getFileMTime (file : FilePath) : IO MTime :=
return (← file.metadata).modified
instance : GetMTime FilePath := ⟨getFileMTime⟩
instance : GetMTime TextFilePath := ⟨(getFileMTime ·.path)⟩
/-- Check if the info's `MTIme` is at least `depMTime`. -/
def checkIfNewer [GetMTime i] (info : i) (depMTime : MTime) : BaseIO Bool :=
(do pure ((← getMTime info) >= depMTime : Bool)).catchExceptions fun _ => pure false
--------------------------------------------------------------------------------
/-! # Lake Build Trace (Hash + MTIme) -/
--------------------------------------------------------------------------------
/-- Trace used for common Lake targets. Combines `Hash` and `MTime`. -/
structure BuildTrace where
hash : Hash
mtime : MTime
deriving Repr
namespace BuildTrace
def withHash (hash : Hash) (self : BuildTrace) : BuildTrace :=
{self with hash}
def withoutHash (self : BuildTrace) : BuildTrace :=
{self with hash := Hash.nil}
def withMTime (mtime : MTime) (self : BuildTrace) : BuildTrace :=
{self with mtime}
def withoutMTime (self : BuildTrace) : BuildTrace :=
{self with mtime := 0}
def fromHash (hash : Hash) : BuildTrace :=
mk hash 0
instance : Coe Hash BuildTrace := ⟨fromHash⟩
def fromMTime (mtime : MTime) : BuildTrace :=
mk Hash.nil mtime
instance : Coe MTime BuildTrace := ⟨fromMTime⟩
def nil : BuildTrace :=
mk Hash.nil 0
instance : NilTrace BuildTrace := ⟨nil⟩
def compute [ComputeHash i m] [MonadLiftT m IO] [GetMTime i] (info : i) : IO BuildTrace :=
return mk (← computeHash info) (← getMTime info)
instance [ComputeHash i m] [MonadLiftT m IO] [GetMTime i] : ComputeTrace i IO BuildTrace := ⟨compute⟩
def mix (t1 t2 : BuildTrace) : BuildTrace :=
mk (Hash.mix t1.hash t2.hash) (max t1.mtime t2.mtime)
instance : MixTrace BuildTrace := ⟨mix⟩
/--
Check the build trace against the given target info and hash
to see if the target is up-to-date.
-/
def checkAgainstHash [CheckExists i]
(info : i) (hash : Hash) (self : BuildTrace) : BaseIO Bool :=
pure (hash == self.hash) <&&> checkExists info
/--
Check the build trace against the given target info and its modification time
to see if the target is up-to-date.
-/
def checkAgainstTime [CheckExists i] [GetMTime i]
(info : i) (self : BuildTrace) : BaseIO Bool :=
checkIfNewer info self.mtime
/--
Check the build trace against the given target info and its trace file
to see if the target is up-to-date.
-/
def checkAgainstFile [CheckExists i] [GetMTime i]
(info : i) (traceFile : FilePath) (self : BuildTrace) : BaseIO Bool := do
let act : IO _ := do
if let some hash ← Hash.loadFromFile traceFile then
self.checkAgainstHash info hash
else
return self.mtime < (← getMTime info)
act.catchExceptions fun _ => pure false
def writeToFile (traceFile : FilePath) (self : BuildTrace) : IO PUnit :=
IO.FS.writeFile traceFile self.hash.toString
end BuildTrace

6
src/lake/Lake/CLI.lean Normal file
View file

@ -0,0 +1,6 @@
/-
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.CLI.Main

View file

@ -0,0 +1,29 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Index
namespace Lake
def env (cmd : String) (args : Array String := #[]) : LakeT IO UInt32 := do
IO.Process.spawn {cmd, args, env := ← getAugmentedEnv} >>= (·.wait)
def exe (name : Name) (args : Array String := #[]) (oldMode := false) : LakeT LogIO UInt32 := do
let ws ← getWorkspace
if let some exe := ws.findLeanExe? name then
let exeFile ← ws.runBuild (exe.build >>= (·.await)) oldMode
env exeFile.toString args
else
error s!"unknown executable `{name}`"
def uploadRelease (pkg : Package) (tag : String) : LogIO Unit := do
let mut args :=
#["release", "upload", tag, pkg.buildArchiveFile.toString, "--clobber"]
if let some repo := pkg.releaseRepo? then
args := args.append #["-R", repo]
tar pkg.buildArchive pkg.buildDir pkg.buildArchiveFile
(excludePaths := #["*.tar.gz", "*.tar.gz.trace"])
logInfo s!"Uploading {tag}/{pkg.buildArchive}"
proc {cmd := "gh", args}

View file

@ -0,0 +1,187 @@
/-
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.Build.Index
import Lake.CLI.Error
namespace Lake
/-! ## Build Target Specifiers -/
structure BuildSpec where
info : BuildInfo
getBuildJob : BuildData info.key → BuildJob Unit
@[inline] def BuildSpec.getJob (self : BuildSpec) (data : BuildData self.info.key) : Job Unit :=
discard <| self.getBuildJob data
@[inline] def BuildData.toBuildJob
[FamilyOut BuildData k (BuildJob α)] (data : BuildData k) : BuildJob Unit :=
discard <| ofFamily data
@[inline] def mkBuildSpec (info : BuildInfo)
[FamilyOut BuildData info.key (BuildJob α)] : BuildSpec :=
{info, getBuildJob := BuildData.toBuildJob}
@[inline] def mkConfigBuildSpec (facetType : String)
(info : BuildInfo) (config : FacetConfig Fam ι facet) (h : BuildData info.key = Fam facet)
: Except CliError BuildSpec := do
let some getJob := config.getJob?
| throw <| CliError.nonCliFacet facetType facet
return {info, getBuildJob := h ▸ getJob}
def BuildSpec.build (self : BuildSpec) : RecBuildM (Job Unit) :=
self.getJob <$> buildIndexTop' self.info
def buildSpecs (specs : Array BuildSpec) : BuildM PUnit := do
let jobs ← RecBuildM.run do specs.mapM (·.build)
jobs.forM (discard <| ·.await)
/-! ## Parsing CLI Build Target Specifiers -/
def parsePackageSpec (ws : Workspace) (spec : String) : Except CliError Package :=
if spec.isEmpty then
return ws.root
else
match ws.findPackage? <| stringToLegalOrSimpleName spec with
| some pkg => return pkg
| none => throw <| CliError.unknownPackage spec
open Module in
def resolveModuleTarget (ws : Workspace) (mod : Module) (facet : Name) : Except CliError BuildSpec :=
if facet.isAnonymous then
return mkBuildSpec <| mod.facet leanBinFacet
else if let some config := ws.findModuleFacetConfig? facet then do
mkConfigBuildSpec "module" (mod.facet facet) config rfl
else
throw <| CliError.unknownFacet "module" facet
def resolveLibTarget (ws : Workspace) (lib : LeanLib) (facet : Name) : Except CliError (Array BuildSpec) :=
if facet.isAnonymous then
lib.defaultFacets.mapM (resolveFacet ·)
else
Array.singleton <$> resolveFacet facet
where
resolveFacet facet :=
if let some config := ws.findLibraryFacetConfig? facet then do
mkConfigBuildSpec "library" (lib.facet facet) config rfl
else
throw <| CliError.unknownFacet "library" facet
def resolveExeTarget (exe : LeanExe) (facet : Name) : Except CliError BuildSpec :=
if facet.isAnonymous || facet == `exe then
return mkBuildSpec exe.exe
else
throw <| CliError.unknownFacet "executable" facet
def resolveExternLibTarget (lib : ExternLib) (facet : Name) : Except CliError BuildSpec :=
if facet.isAnonymous || facet = `static then
return mkBuildSpec lib.static
else if facet = `shared then
return mkBuildSpec lib.shared
else
throw <| CliError.unknownFacet "external library" facet
def resolveCustomTarget (pkg : Package)
(name facet : Name) (config : TargetConfig pkg.name name) : Except CliError BuildSpec :=
if !facet.isAnonymous then
throw <| CliError.invalidFacet name facet
else do
let info := pkg.target name
have h : BuildData info.key = CustomData (pkg.name, name) := rfl
return {info, getBuildJob := h ▸ config.getJob}
def resolveTargetInPackage (ws : Workspace)
(pkg : Package) (target facet : Name) : Except CliError (Array BuildSpec) :=
if let some config := pkg.findTargetConfig? target then
Array.singleton <$> resolveCustomTarget pkg target facet config
else if let some exe := pkg.findLeanExe? target then
Array.singleton <$> resolveExeTarget exe facet
else if let some lib := pkg.findExternLib? target then
Array.singleton <$> resolveExternLibTarget lib facet
else if let some lib := pkg.findLeanLib? target then
resolveLibTarget ws lib facet
else if let some mod := pkg.findModule? target then
Array.singleton <$> resolveModuleTarget ws mod facet
else
throw <| CliError.missingTarget pkg.name (target.toString false)
def resolveDefaultPackageTarget (ws : Workspace) (pkg : Package) : Except CliError (Array BuildSpec) :=
pkg.defaultTargets.concatMapM (resolveTargetInPackage ws pkg · .anonymous)
def resolvePackageTarget (ws : Workspace) (pkg : Package) (facet : Name) : Except CliError (Array BuildSpec) :=
if facet.isAnonymous then
resolveDefaultPackageTarget ws pkg
else if let some config := ws.findPackageFacetConfig? facet then do
Array.singleton <$> mkConfigBuildSpec "package" (pkg.facet facet) config rfl
else
throw <| CliError.unknownFacet "package" facet
def resolveTargetInWorkspace (ws : Workspace)
(target : Name) (facet : Name) : Except CliError (Array BuildSpec) :=
if let some ⟨pkg, config⟩ := ws.findTargetConfig? target then
Array.singleton <$> resolveCustomTarget pkg target facet config
else if let some exe := ws.findLeanExe? target then
Array.singleton <$> resolveExeTarget exe facet
else if let some lib := ws.findExternLib? target then
Array.singleton <$> resolveExternLibTarget lib facet
else if let some lib := ws.findLeanLib? target then
resolveLibTarget ws lib facet
else if let some pkg := ws.findPackage? target then
resolvePackageTarget ws pkg facet
else if let some mod := ws.findModule? target then
Array.singleton <$> resolveModuleTarget ws mod facet
else
throw <| CliError.unknownTarget target
def resolveTargetBaseSpec
(ws : Workspace) (spec : String) (facet : Name) : Except CliError (Array BuildSpec) := do
match spec.splitOn "/" with
| [spec] =>
if spec.isEmpty then
resolvePackageTarget ws ws.root facet
else if spec.startsWith "@" then
let pkg ← parsePackageSpec ws <| spec.drop 1
resolvePackageTarget ws pkg facet
else if spec.startsWith "+" then
let mod := spec.drop 1 |>.toName
if let some mod := ws.findModule? mod then
Array.singleton <$> resolveModuleTarget ws mod facet
else
throw <| CliError.unknownModule mod
else
resolveTargetInWorkspace ws (stringToLegalOrSimpleName spec) facet
| [pkgSpec, targetSpec] =>
let pkgSpec := if pkgSpec.startsWith "@" then pkgSpec.drop 1 else pkgSpec
let pkg ← parsePackageSpec ws pkgSpec
if targetSpec.isEmpty then
resolvePackageTarget ws pkg facet
else if targetSpec.startsWith "+" then
let mod := targetSpec.drop 1 |>.toName
if let some mod := pkg.findModule? mod then
Array.singleton <$> resolveModuleTarget ws mod facet
else
throw <| CliError.unknownModule mod
else
resolveTargetInPackage ws pkg targetSpec facet
| _ =>
throw <| CliError.invalidTargetSpec spec '/'
def parseTargetSpec (ws : Workspace) (spec : String) : Except CliError (Array BuildSpec) := do
match spec.splitOn ":" with
| [spec] =>
resolveTargetBaseSpec ws spec .anonymous
| [rootSpec, facet] =>
resolveTargetBaseSpec ws rootSpec facet.toName
| _ =>
throw <| CliError.invalidTargetSpec spec ':'
def parseTargetSpecs (ws : Workspace) (specs : List String) : Except CliError (Array BuildSpec) := do
let mut results := #[]
for spec in specs do
results := results ++ (← parseTargetSpec ws spec)
if results.isEmpty then
results ← resolveDefaultPackageTarget ws ws.root
return results

View file

@ -0,0 +1,70 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
open Lean (Name)
inductive CliError
/- CLI Errors -/
| missingCommand
| unknownCommand (cmd : String)
| missingArg (arg : String)
| missingOptArg (opt arg : String)
| unknownShortOption (opt : Char)
| unknownLongOption (opt : String)
| unexpectedArguments (args : List String)
/- Init CLI Errors -/
| unknownTemplate (spec : String)
/- Build CLI Errors -/
| unknownModule (mod : Name)
| unknownPackage (spec : String)
| unknownFacet (type : String) (facet : Name)
| unknownTarget (target : Name)
| missingModule (pkg : Name) (mod : Name)
| missingTarget (pkg : Name) (spec : String)
| nonCliTarget (target : Name)
| nonCliFacet (type : String) (facet : Name)
| invalidTargetSpec (spec : String) (tooMany : Char)
| invalidFacet (target : Name) (facet : Name)
/- Script CLI Error -/
| unknownScript (script : String)
| missingScriptDoc (script : String)
| invalidScriptSpec (spec : String)
/- Config Errors -/
| unknownLeanInstall
| unknownLakeInstall
| leanRevMismatch (expected actual : String)
deriving Inhabited, Repr
namespace CliError
def toString : CliError → String
| missingCommand => "missing command"
| unknownCommand cmd => s!"unknown command '{cmd}'"
| missingArg arg => s!"missing {arg}"
| missingOptArg opt arg => s!"missing {arg} after {opt}"
| unknownShortOption opt => s!"unknown short option '-{opt}'"
| unknownLongOption opt => s!"unknown long option '{opt}'"
| unexpectedArguments as => s!"unexpected arguments: {" ".intercalate as}"
| unknownTemplate spec => s!"unknown package template `{spec}`"
| unknownModule mod => s!"unknown module `{mod.toString false}`"
| unknownPackage spec => s!"unknown package `{spec}`"
| unknownFacet ty f => s!"unknown {ty} facet `{f.toString false}`"
| unknownTarget t => s!"unknown target `{t.toString false}`"
| missingModule pkg mod => s!"package '{pkg.toString false}' has no module '{mod.toString false}'"
| missingTarget pkg spec => s!"package '{pkg.toString false}' has no target '{spec}'"
| nonCliTarget t => s!"target `{t.toString false}` is not a buildable via `lake`"
| nonCliFacet t f => s!"{t} facet `{f.toString false}` is not a buildable via `lake`"
| invalidTargetSpec s c => s!"invalid script spec '{s}' (too many '{c}')"
| invalidFacet t f => s!"invalid facet `{f.toString false}`; target {t.toString false} has no facets"
| unknownScript s => s!"unknown script {s}"
| missingScriptDoc s => s!"no documentation provided for `{s}`"
| invalidScriptSpec s => s!"invalid script spec '{s}' (too many '/')"
| unknownLeanInstall => "could not detect a Lean installation"
| unknownLakeInstall => "could not detect the configuration of the Lake installation"
| leanRevMismatch e a => s!"expected Lean commit {e}, but got {if a.isEmpty then "nothing" else a}"
instance : ToString CliError := ⟨toString⟩

242
src/lake/Lake/CLI/Help.lean Normal file
View file

@ -0,0 +1,242 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake.Version
namespace Lake
def usage :=
uiVersionString ++ "
USAGE:
lake [OPTIONS] <COMMAND>
OPTIONS:
--version print version and exit
--help, -h print help of the program or a command and exit
--dir, -d=file use the package configuration in a specific directory
--file, -f=file use a specific file for the package configuration
--quiet, -q hide progress messages
--verbose, -v show verbose information (command invocations)
--lean=cmd specify the `lean` command used by Lake
-K key[=value] set the configuration file option named key
--old only rebuild modified modules (ignore transitive deps)
--update, -U update manifest before building
COMMANDS:
new <name> [<temp>] create a Lean package in a new directory
init <name> [<temp>] create a Lean package in the current directory
build [<targets>...] build targets
update update dependencies
upload <tag> upload build artifacts to a GitHub release
clean remove build outputs
script manage and run workspace scripts
scripts shorthand for `lake script list`
run <script> shorthand for `lake script run`
serve start the Lean language server
env <cmd> [<args>...] execute a command in the workspace's environment
exe <exe> [<args>...] build an exe and run it in the workspace's environment
See `lake help <command>` for more information on a specific command."
def templateHelp :=
s!"The initial configuration and starter files are based on the template:
std library and executable; default
exe executable only
lib library only
math library only with a mathlib dependency"
def helpNew :=
s!"Create a Lean package in a new directory
USAGE:
lake new <name> [<template>]
{templateHelp}"
def helpInit :=
s!"Create a Lean package in the current directory
USAGE:
lake init <name> [<template>]
{templateHelp}"
def helpBuild :=
"Build targets
USAGE:
lake build [<targets>...]
A target is specified with a string of the form:
[[@]<package>/][<target>|[+]<module>][:<facet>]
The optional `@` and `+` markers can be used to disambiguate packages
and modules from other kinds of targets (i.e., executables and libraries).
LIBRARY FACETS: build the library's ...
lean (default) Lean binaries (*.olean, *.ilean files)
static static binary (*.a file)
shared shared binary (*.so, *.dll, or *.dylib file)
MODULE FACETS: build the module's ...
deps transitive local imports & shared library dependencies
bin (default) Lean binaries (*.olean, *.ilean files) and *.c file
o *.o object file (of its C file)
dynlib shared library (e.g., for `--load-dynlib`)
TARGET EXAMPLES: build the ...
a default facet of target `a`
@a default target(s) of package `a`
+A olean and .ilean files of module `A`
a/b default facet of target `b` of package `a`
a/+A:c C file of module `A` of package `a`
:foo facet `foo` of the root package
A bare `build` command will build the default facet of the root package.
Package dependencies are not updated during a build."
def helpUpdate :=
"Update dependencies
USAGE:
lake update
This command sets up the directory with the package's dependencies
(i.e., `packagesDir`, which is, by default, `lake-packages`).
For each (transitive) git dependency, the specified commit is checked out
into a sub-directory of `packagesDir`. Already checked out dependencies are
updated to the latest version compatible with the package's configuration.
If there are dependencies on multiple versions of the same package, the
version materialized is undefined. The specific revision of the resolved
packages are cached in the `manifest.json` file of the `packagesDir`.
No copy is made of local dependencies."
def helpUpload :=
"Upload build artifacts to a GitHub release
USAGE:
lake upload <tag>
Packs the root package's `buildDir` into a `tar.gz` archive using `tar` and
then uploads the asset to the pre-existing GitHub release `tag` using `gh`."
def helpClean :=
"Remove build outputs
USAGE:
lake clean
Deletes the build directory of the package."
def helpScriptCli :=
"Manage Lake scripts
USAGE:
lake script <COMMAND>
COMMANDS:
list list available scripts
run <script> run a script
doc <script> print the docstring of a given script
See `lake help <command>` for more information on a specific command."
def helpScriptList :=
"List available scripts
USAGE:
lake script list
This command prints the list of all available scripts in the workspace."
def helpScriptRun :=
"Run a script
USAGE:
lake script run [<package>/]<script> [<args>...]
This command runs the given `script` from `package`, passing `args` to it.
Defaults to the root package.
A bare `run` command will run the default script(s) of the root package
(with no arguments)."
def helpScriptDoc :=
"Print a script's docstring
USAGE:
lake script doc [<package>/]<script>
Print the docstring of `script` in `package`. Defaults to the root package."
def helpServe :=
"Start the Lean language server
USAGE:
lake serve [-- <args>...]
Run the language server of the Lean installation (i.e., via `lean --server`)
with the package configuration's `moreServerArgs` field and `args`.
"
def helpEnv :=
"Execute a command in the workspace's environment
USAGE:
lake env <cmd> [<args>...]
Spawns a new process executing `cmd` with the given `args` and with
the environment set based on the workspace configuration and the detected
Lean/Lake installations.
Specifically, this command sets the following environment variables:
LAKE set to the detected Lake executable
LAKE_HOME set to the detected Lake home
LEAN_SYSROOT set to the detected Lean sysroot
LEAN_AR set to the detected Lean `ar` binary
LEAN_CC set to the detected `cc` (if not using bundled one)
LEAN_PATH adds the workspace's library directories
LEAN_SRC_PATH adds the workspace's source directories
PATH adds the workspace's library directories (Windows)
DYLD_LIBRARY_PATH adds the workspace's library directories (MacOS)
LD_LIBRARY_PATH adds the workspace's library directories (other Unix)"
def helpExe :=
"Build an executable target and run it in the workspace's environment
USAGE:
lake exe <exe-target> [<args>...]
Looks for the executable target in the workspace (see `lake help build` to
learn how to specify targets), builds it if it is out of date, and then runs
it with the given `args` in the workspace's environment (see `lake help env`
for how the environment is set)."
def helpScript : (cmd : String) → String
| "list" => helpScriptList
| "run" => helpScriptRun
| "doc" => helpScriptDoc
| _ => helpScriptCli
def help : (cmd : String) → String
| "new" => helpNew
| "init" => helpInit
| "build" => helpBuild
| "update" => helpUpdate
| "upload" => helpUpload
| "clean" => helpClean
| "script" => helpScriptCli
| "scripts" => helpScriptList
| "run" => helpScriptRun
| "serve" => helpServe
| "env" => helpEnv
| "exe" => helpExe
| _ => usage

205
src/lake/Lake/CLI/Init.lean Normal file
View file

@ -0,0 +1,205 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake.Util.Git
import Lake.Util.Sugar
import Lake.Config.Package
import Lake.Config.Workspace
import Lake.Load.Config
import Lake.Build.Actions
namespace Lake
open Git System
/-- The default module of an executable in `std` package. -/
def defaultExeRoot : Name := `Main
/-- `elan` toolchain file name -/
def toolchainFileName : FilePath :=
"lean-toolchain"
def gitignoreContents :=
s!"/{defaultBuildDir}
/{defaultPackagesDir}/*
"
def libFileContents :=
s!"def hello := \"world\""
def mainFileName : FilePath :=
s!"{defaultExeRoot}.lean"
def mainFileContents (libRoot : String) :=
s!"import {libRoot}
def main : IO Unit :=
IO.println s!\"Hello, \{hello}!\"
"
def exeFileContents :=
s!"def main : IO Unit :=
IO.println s!\"Hello, world!\"
"
def stdConfigFileContents (pkgName libRoot : String) :=
s!"import Lake
open Lake DSL
package {pkgName} \{
-- add package configuration options here
}
lean_lib {libRoot} \{
-- add library configuration options here
}
@[default_target]
lean_exe {pkgName} \{
root := `Main
}
"
def exeConfigFileContents (pkgName exeRoot : String) :=
s!"import Lake
open Lake DSL
package {pkgName} \{
-- add package configuration options here
}
@[default_target]
lean_exe {exeRoot} \{
-- add executable configuration options here
}
"
def libConfigFileContents (pkgName libRoot : String) :=
s!"import Lake
open Lake DSL
package {pkgName} \{
-- add package configuration options here
}
@[default_target]
lean_lib {libRoot} \{
-- add library configuration options here
}
"
def mathConfigFileContents (pkgName libRoot : String) :=
s!"import Lake
open Lake DSL
package {pkgName} \{
-- add any package configuration options here
}
require mathlib from git
\"https://github.com/leanprover-community/mathlib4.git\"
@[default_target]
lean_lib {libRoot} \{
-- add any library configuration options here
}
"
def mathToolchainUrl : String :=
"https://raw.githubusercontent.com/leanprover-community/mathlib4/master/lean-toolchain"
/-- The options for the template argument to `initPkg`. -/
inductive InitTemplate
| std | exe | lib | math
deriving Repr, DecidableEq
instance : Inhabited InitTemplate := ⟨.std⟩
def InitTemplate.parse? : String → Option InitTemplate
| "std" => some .std
| "exe" => some .exe
| "lib" => some .lib
| "math" => some .math
| _ => none
def InitTemplate.configFileContents (pkgName root : String) : InitTemplate → String
| .std => stdConfigFileContents pkgName root
| .lib => libConfigFileContents pkgName root
| .exe => exeConfigFileContents pkgName root
| .math => mathConfigFileContents pkgName root
def escapeName! : Name → String
| .anonymous => "[anonymous]"
| .str .anonymous s => escape s
| .str n s => escapeName! n ++ "." ++ escape s
| _ => unreachable!
where
escape s := Lean.idBeginEscape.toString ++ s ++ Lean.idEndEscape.toString
/-- Initialize a new Lake package in the given directory with the given name. -/
def initPkg (dir : FilePath) (name : String) (tmp : InitTemplate) : LogIO PUnit := do
let pkgName := stringToLegalOrSimpleName name
-- determine the name to use for the root
-- use upper camel case unless the specific module name already exists
let (root, rootFile, rootExists) ← do
let root := pkgName
let rootFile := Lean.modToFilePath dir root "lean"
let rootExists ← rootFile.pathExists
if tmp = .exe || rootExists then
pure (root, rootFile, rootExists)
else
let root := toUpperCamelCase (toUpperCamelCaseString name |>.toName)
let rootFile := Lean.modToFilePath dir root "lean"
pure (root, rootFile, ← rootFile.pathExists)
-- write default configuration file
let configFile := dir / defaultConfigFile
if (← configFile.pathExists) then
error "package already initialized"
let rootNameStr := escapeName! root
let contents := tmp.configFileContents (escapeName! pkgName) rootNameStr
IO.FS.writeFile configFile contents
-- write example code if the files do not already exist
if tmp = .exe then
unless (← rootFile.pathExists) do
IO.FS.writeFile rootFile exeFileContents
else
if !rootExists then
IO.FS.createDirAll rootFile.parent.get!
IO.FS.writeFile rootFile libFileContents
if tmp = .std then
let mainFile := dir / mainFileName
unless (← mainFile.pathExists) do
IO.FS.writeFile mainFile <| mainFileContents rootNameStr
-- write Lean's toolchain to file (if it has one) for `elan`
if Lean.toolchain ≠ "" then
if tmp = .math then
download "lean-toolchain" mathToolchainUrl (dir / toolchainFileName)
else
IO.FS.writeFile (dir / toolchainFileName) <| Lean.toolchain ++ "\n"
-- update `.gitignore` with additional entries for Lake
let h ← IO.FS.Handle.mk (dir / ".gitignore") IO.FS.Mode.append
h.putStr gitignoreContents
-- initialize a `.git` repository if none already
unless (← FilePath.isDir <| dir / ".git") do
let repo := GitRepo.mk dir
try
repo.quietInit
unless upstreamBranch = "master" do
repo.checkoutBranch upstreamBranch
else
logWarning "failed to initialize git repository"
def init (pkgName : String) (tmp : InitTemplate) : LogIO PUnit :=
initPkg "." pkgName tmp
def new (pkgName : String) (tmp : InitTemplate) : LogIO PUnit := do
let dirName := pkgName.map fun chr => if chr == '.' then '-' else chr
IO.FS.createDir dirName
initPkg dirName pkgName tmp

384
src/lake/Lake/CLI/Main.lean Normal file
View file

@ -0,0 +1,384 @@
/-
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.Load
import Lake.Build.Imports
import Lake.Util.Error
import Lake.Util.MainM
import Lake.Util.Cli
import Lake.CLI.Init
import Lake.CLI.Help
import Lake.CLI.Build
import Lake.CLI.Error
import Lake.CLI.Actions
import Lake.CLI.Serve
-- # CLI
open System
open Lean (Json toJson fromJson? LeanPaths)
namespace Lake
/-! ## General options for top-level `lake` -/
structure LakeOptions where
rootDir : FilePath := "."
configFile : FilePath := defaultConfigFile
leanInstall? : Option LeanInstall := none
lakeInstall? : Option LakeInstall := none
configOpts : NameMap String := {}
subArgs : List String := []
wantsHelp : Bool := false
verbosity : Verbosity := .normal
oldMode : Bool := false
updateDeps : Bool := false
/-- Get the Lean installation. Error if missing. -/
def LakeOptions.getLeanInstall (opts : LakeOptions) : Except CliError LeanInstall :=
match opts.leanInstall? with
| none => .error CliError.unknownLeanInstall
| some lean => .ok lean
/-- Get the Lake installation. Error if missing. -/
def LakeOptions.getLakeInstall (opts : LakeOptions) : Except CliError LakeInstall :=
match opts.lakeInstall? with
| none => .error CliError.unknownLakeInstall
| some lake => .ok lake
/-- Get the Lean and Lake installation. Error if either is missing. -/
def LakeOptions.getInstall (opts : LakeOptions) : Except CliError (LeanInstall × LakeInstall) := do
return (← opts.getLeanInstall, ← opts.getLakeInstall)
/-- Compute the Lake environment based on `opts`. Error if an install is missing. -/
def LakeOptions.computeEnv (opts : LakeOptions) : EIO CliError Lake.Env := do
Env.compute (← opts.getLakeInstall) (← opts.getLeanInstall)
/-- Make a `LoadConfig` from a `LakeOptions`. -/
def LakeOptions.mkLoadConfig (opts : LakeOptions) : EIO CliError LoadConfig :=
return {
env := ← opts.computeEnv
rootDir := opts.rootDir
configFile := opts.rootDir / opts.configFile
configOpts := opts.configOpts
leanOpts := Lean.Options.empty
}
export LakeOptions (mkLoadConfig)
/-! ## Monad -/
abbrev CliMainM := ExceptT CliError MainM
abbrev CliStateM := StateT LakeOptions CliMainM
abbrev CliM := ArgsT CliStateM
def CliM.run (self : CliM α) (args : List String) : BaseIO ExitCode := do
let (leanInstall?, lakeInstall?) ← findInstall?
let main := self args |>.run' {leanInstall?, lakeInstall?}
let main := main.run >>= fun | .ok a => pure a | .error e => error e.toString
main.run
instance : MonadLift LogIO CliStateM :=
⟨fun x => do MainM.runLogIO x (← get).verbosity⟩
instance : MonadLift OptionIO MainM where
monadLift x := x.adaptExcept (fun _ => 1)
/-! ## Argument Parsing -/
def takeArg (arg : String) : CliM String := do
match (← takeArg?) with
| none => throw <| CliError.missingArg arg
| some arg => pure arg
def takeOptArg (opt arg : String) : CliM String := do
match (← takeArg?) with
| none => throw <| CliError.missingOptArg opt arg
| some arg => pure arg
/--
Verify that there are no CLI arguments remaining
before running the given action.
-/
def noArgsRem (act : CliStateM α) : CliM α := do
let args ← getArgs
if args.isEmpty then act else
throw <| CliError.unexpectedArguments args
/-! ## Option Parsing -/
def getWantsHelp : CliStateM Bool :=
(·.wantsHelp) <$> get
def setLean (lean : String) : CliStateM PUnit := do
let leanInstall? ← findLeanCmdInstall? lean
modify ({· with leanInstall?})
def setConfigOpt (kvPair : String) : CliM PUnit :=
let pos := kvPair.posOf '='
let (key, val) :=
if pos = kvPair.endPos then
(kvPair.toName, "")
else
(kvPair.extract 0 pos |>.toName, kvPair.extract (kvPair.next pos) kvPair.endPos)
modifyThe LakeOptions fun opts =>
{opts with configOpts := opts.configOpts.insert key val}
def lakeShortOption : (opt : Char) → CliM PUnit
| 'q' => modifyThe LakeOptions ({· with verbosity := .quiet})
| 'v' => modifyThe LakeOptions ({· with verbosity := .verbose})
| 'd' => do let rootDir ← takeOptArg "-d" "path"; modifyThe LakeOptions ({· with rootDir})
| 'f' => do let configFile ← takeOptArg "-f" "path"; modifyThe LakeOptions ({· with configFile})
| 'K' => do setConfigOpt <| ← takeOptArg "-K" "key-value pair"
| 'U' => modifyThe LakeOptions ({· with updateDeps := true})
| 'h' => modifyThe LakeOptions ({· with wantsHelp := true})
| opt => throw <| CliError.unknownShortOption opt
def lakeLongOption : (opt : String) → CliM PUnit
| "--quiet" => modifyThe LakeOptions ({· with verbosity := .quiet})
| "--verbose" => modifyThe LakeOptions ({· with verbosity := .verbose})
| "--update" => modifyThe LakeOptions ({· with updateDeps := true})
| "--old" => modifyThe LakeOptions ({· with oldMode := true})
| "--dir" => do let rootDir ← takeOptArg "--dir" "path"; modifyThe LakeOptions ({· with rootDir})
| "--file" => do let configFile ← takeOptArg "--file" "path"; modifyThe LakeOptions ({· with configFile})
| "--lean" => do setLean <| ← takeOptArg "--lean" "path or command"
| "--help" => modifyThe LakeOptions ({· with wantsHelp := true})
| "--" => do let subArgs ← takeArgs; modifyThe LakeOptions ({· with subArgs})
| opt => throw <| CliError.unknownLongOption opt
def lakeOption :=
option {
short := lakeShortOption
long := lakeLongOption
longShort := shortOptionWithArg lakeShortOption
}
/-! ## Actions -/
/-- Verify the Lean version Lake was built with matches that of the give Lean installation. -/
def verifyLeanVersion (leanInstall : LeanInstall) : Except CliError PUnit := do
unless leanInstall.githash == Lean.githash do
throw <| CliError.leanRevMismatch Lean.githash leanInstall.githash
/-- Output the detected installs and verify the Lean version. -/
def verifyInstall (opts : LakeOptions) : ExceptT CliError MainM PUnit := do
IO.println s!"Lean:\n{repr <| opts.leanInstall?}"
IO.println s!"Lake:\n{repr <| opts.lakeInstall?}"
let (leanInstall, _) ← opts.getInstall
verifyLeanVersion leanInstall
def parseScriptSpec (ws : Workspace) (spec : String) : Except CliError (Package × String) :=
match spec.splitOn "/" with
| [script] => return (ws.root, script)
| [pkg, script] => return (← parsePackageSpec ws pkg, script)
| _ => throw <| CliError.invalidScriptSpec spec
def parseTemplateSpec (spec : String) : Except CliError InitTemplate :=
if spec.isEmpty then
pure default
else if let some tmp := InitTemplate.parse? spec then
pure tmp
else
throw <| CliError.unknownTemplate spec
/-! ## Commands -/
namespace lake
/-! ### `lake script` CLI -/
namespace script
protected def list : CliM PUnit := do
processOptions lakeOption
let config ← mkLoadConfig (← getThe LakeOptions)
noArgsRem do
let ws ← loadWorkspace config
ws.packageMap.forM fun _ pkg => do
let pkgName := pkg.name.toString (escape := false)
pkg.scripts.forM fun name _ =>
let scriptName := name.toString (escape := false)
IO.println s!"{pkgName}/{scriptName}"
protected nonrec def run : CliM PUnit := do
processOptions lakeOption
let config ← mkLoadConfig (← getThe LakeOptions)
let ws ← loadWorkspace config
if let some spec ← takeArg? then
let args ← takeArgs
let (pkg, scriptName) ← parseScriptSpec ws spec
if let some script := pkg.scripts.find? scriptName then
exit <| ← script.run args |>.run {opaqueWs := ws}
else do
throw <| CliError.unknownScript scriptName
else
for script in ws.root.defaultScripts do
exitIfErrorCode <| ← script.run [] |>.run {opaqueWs := ws}
exit 0
protected def doc : CliM PUnit := do
processOptions lakeOption
let spec ← takeArg "script name"
let config ← mkLoadConfig (← getThe LakeOptions)
noArgsRem do
let ws ← loadWorkspace config
let (pkg, scriptName) ← parseScriptSpec ws spec
if let some script := pkg.scripts.find? scriptName then
match script.doc? with
| some doc => IO.println doc
| none => throw <| CliError.missingScriptDoc scriptName
else
throw <| CliError.unknownScript scriptName
protected def help : CliM PUnit := do
IO.println <| helpScript <| (← takeArg?).getD ""
end script
def scriptCli : (cmd : String) → CliM PUnit
| "list" => script.list
| "run" => script.run
| "doc" => script.doc
| "help" => script.help
| cmd => throw <| CliError.unknownCommand cmd
/-! ### `lake` CLI -/
protected def new : CliM PUnit := do
processOptions lakeOption
let pkgName ← takeArg "package name"
let template ← parseTemplateSpec <| (← takeArg?).getD ""
noArgsRem do MainM.runLogIO (new pkgName template) (← getThe LakeOptions).verbosity
protected def init : CliM PUnit := do
processOptions lakeOption
let pkgName ← takeArg "package name"
let template ← parseTemplateSpec <| (← takeArg?).getD ""
noArgsRem do MainM.runLogIO (init pkgName template) (← getThe LakeOptions).verbosity
protected def build : CliM PUnit := do
processOptions lakeOption
let opts ← getThe LakeOptions
let config ← mkLoadConfig opts
let ws ← loadWorkspace config opts.updateDeps
let targetSpecs ← takeArgs
let specs ← parseTargetSpecs ws targetSpecs
ws.runBuild (buildSpecs specs) opts.oldMode |>.run (MonadLog.io opts.verbosity)
protected def resolveDeps : CliM PUnit := do
processOptions lakeOption
let opts ← getThe LakeOptions
let config ← mkLoadConfig opts
noArgsRem do
liftM <| discard <| (loadWorkspace config opts.updateDeps).run (MonadLog.io opts.verbosity)
protected def update : CliM PUnit := do
processOptions lakeOption
let opts ← getThe LakeOptions
let config ← mkLoadConfig opts
noArgsRem do
liftM <| (updateManifest config).run (MonadLog.io opts.verbosity)
protected def upload : CliM PUnit := do
processOptions lakeOption
let tag ← takeArg "release tag"
let opts ← getThe LakeOptions
let config ← mkLoadConfig opts
let ws ← loadWorkspace config
noArgsRem do
liftM <| uploadRelease ws.root tag |>.run (MonadLog.io opts.verbosity)
protected def printPaths : CliM PUnit := do
processOptions lakeOption
let opts ← getThe LakeOptions
let config ← mkLoadConfig opts
printPaths config (← takeArgs) opts.oldMode opts.verbosity
protected def clean : CliM PUnit := do
processOptions lakeOption
let config ← mkLoadConfig (← getThe LakeOptions)
noArgsRem do (← loadWorkspace config).clean
protected def script : CliM PUnit := do
if let some cmd ← takeArg? then
processLeadingOptions lakeOption -- between `lake script <cmd>` and args
if (← getWantsHelp) then
IO.println <| helpScript cmd
else
scriptCli cmd
else
throw <| CliError.missingCommand
protected def serve : CliM PUnit := do
processOptions lakeOption
let opts ← getThe LakeOptions
let args := opts.subArgs.toArray
let config ← mkLoadConfig opts
noArgsRem do exit <| ← serve config args
protected def env : CliM PUnit := do
let cmd ← takeArg "command"; let args ← takeArgs
let config ← mkLoadConfig (← getThe LakeOptions)
let ws ← loadWorkspace config
let ctx := mkLakeContext ws
exit <| ← (env cmd args.toArray).run ctx
protected def exe : CliM PUnit := do
let exeName ← takeArg "executable name"
let args ← takeArgs
let opts ← getThe LakeOptions
let config ← mkLoadConfig opts
let ws ← loadWorkspace config
let ctx := mkLakeContext ws
exit <| ← (exe exeName args.toArray opts.oldMode).run ctx
protected def selfCheck : CliM PUnit := do
processOptions lakeOption
noArgsRem do verifyInstall (← getThe LakeOptions)
protected def help : CliM PUnit := do
IO.println <| help <| (← takeArg?).getD ""
end lake
def lakeCli : (cmd : String) → CliM PUnit
| "new" => lake.new
| "init" => lake.init
| "build" => lake.build
| "update" => lake.update
| "resolve-deps" => lake.resolveDeps
| "upload" => lake.upload
| "print-paths" => lake.printPaths
| "clean" => lake.clean
| "script" => lake.script
| "scripts" => lake.script.list
| "run" => lake.script.run
| "serve" => lake.serve
| "env" => lake.env
| "exe" => lake.exe
| "self-check" => lake.selfCheck
| "help" => lake.help
| cmd => throw <| CliError.unknownCommand cmd
def lake : CliM PUnit := do
match (← getArgs) with
| [] => IO.println usage
| ["--version"] => IO.println uiVersionString
| _ => -- normal CLI
processLeadingOptions lakeOption -- between `lake` and command
if let some cmd ← takeArg? then
processLeadingOptions lakeOption -- between `lake <cmd>` and args
if (← getWantsHelp) then
IO.println <| help cmd
else
lakeCli cmd
else
if (← getWantsHelp) then
IO.println usage
else
throw <| CliError.missingCommand
def cli (args : List String) : BaseIO ExitCode :=
(lake).run args

View file

@ -0,0 +1,67 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Load
import Lake.Build
import Lake.Util.MainM
namespace Lake
open Lean (Json toJson fromJson? LeanPaths)
/-- Exit code to return if `print-paths` cannot find the config file. -/
def noConfigFileCode : ExitCode := 2
/--
Environment variable that is set when `lake serve` cannot parse the Lake configuration file
and falls back to plain `lean --server`.
-/
def invalidConfigEnvVar := "LAKE_INVALID_CONFIG"
/--
Build a list of imports of the package
and print the `.olean` and source directories of every used package.
If no configuration file exists, exit silently with `noConfigFileCode` (i.e, 2).
The `print-paths` command is used internally by Lean 4 server.
-/
def printPaths (config : LoadConfig) (imports : List String := [])
(oldMode : Bool := false) (verbosity : Verbosity := .normal) : MainM PUnit := do
let configFile := config.rootDir / config.configFile
if (← configFile.pathExists) then
if let some errLog := (← IO.getEnv invalidConfigEnvVar) then
IO.eprint errLog
IO.eprintln s!"Invalid Lake configuration. Please restart the server after fixing the Lake configuration file."
exit 1
let ws ← MainM.runLogIO (loadWorkspace config) verbosity
let dynlibs ← ws.runBuild (buildImportsAndDeps imports) oldMode
|>.run (MonadLog.eio verbosity)
IO.println <| Json.compress <| toJson {
oleanPath := ws.leanPath
srcPath := ws.leanSrcPath
loadDynlibPaths := dynlibs
: LeanPaths
}
else
exit noConfigFileCode
/--
Start the Lean LSP for the `Workspace` loaded from `config`
with the given additional `args`.
-/
def serve (config : LoadConfig) (args : Array String) : IO UInt32 := do
let (extraEnv, moreServerArgs) ← do
let (log, ws?) ← loadWorkspace config |>.captureLog
IO.eprint log
if let some ws := ws? then
let ctx := mkLakeContext ws
pure (← LakeT.run ctx getAugmentedEnv, ws.root.moreServerArgs)
else
IO.eprint "warning: package configuration has errors, falling back to plain `lean --server`"
pure (config.env.installVars.push (invalidConfigEnvVar, log), #[])
(← IO.Process.spawn {
cmd := config.env.lean.lean.toString
args := #["--server"] ++ moreServerArgs ++ args
env := extraEnv
}).wait

View file

@ -0,0 +1,6 @@
/-
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

View file

@ -0,0 +1,26 @@
/-
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.Opaque
import Lake.Config.InstallPath
open System
namespace Lake
/-- A Lake configuration. -/
structure Context where
opaqueWs : OpaqueWorkspace
/-- A transformer to equip a monad with a `Lake.Context`. -/
abbrev LakeT := ReaderT Context
@[inline] def LakeT.run (ctx : Context) (self : LakeT m α) : m α :=
ReaderT.run self ctx
/-- A monad equipped with a `Lake.Context`. -/
abbrev LakeM := LakeT Id
@[inline] def LakeM.run (ctx : Context) (self : LakeM α) : α :=
ReaderT.run self ctx |>.run

View file

@ -0,0 +1,41 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lean.Data.NameMap
namespace Lake
open Lean System
/--
The `src` of a `Dependency`.
In Lake, dependency sources currently come into flavors:
* Local `path`s relative to the package's directory.
* Remote `git` repositories that are download from a given `url`
into the workspace's `packagesDir`.
-/
inductive Source where
| path (dir : FilePath)
| git (url : String) (rev : Option String) (subDir : Option FilePath)
deriving Inhabited, Repr
/-- A `Dependency` of a package. -/
structure Dependency where
/--
A `Name` for the dependency.
The names of a package's dependencies cannot clash.
-/
name : Name
/--
The source of a dependency.
See the documentation of `Source` for more information.
-/
src : Source
/--
Arguments to pass to the dependency's package configuration.
-/
options : NameMap String := {}
deriving Inhabited

View file

@ -0,0 +1,72 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.NativeLib
import Lake.Config.InstallPath
open System
namespace Lake
/-- The detected Lake environment. -/
structure Env where
lake : LakeInstall
lean : LeanInstall
leanPath : SearchPath
leanSrcPath : SearchPath
sharedLibPath : SearchPath
deriving Inhabited, Repr
namespace Env
/-- Compute an `Lake.Env` object from the given installs and set environment variables. -/
def compute (lake : LakeInstall) (lean : LeanInstall) : BaseIO Env :=
return {
lake, lean
leanPath := ← getSearchPath "LEAN_PATH",
leanSrcPath := ← getSearchPath "LEAN_SRC_PATH",
sharedLibPath := ← getSearchPath sharedLibPathEnvVar
}
/-- Environment variable settings based only on the given Lean and Lake installations. -/
def installVars (env : Env) : Array (String × Option String) :=
#[
("LAKE", env.lake.lake.toString),
("LAKE_HOME", env.lake.home.toString),
("LEAN_SYSROOT", env.lean.sysroot.toString),
("LEAN_AR", env.lean.ar.toString),
("LEAN_CC", env.lean.leanCc?)
]
/-- Environment variable settings for the `Lake.Env`. -/
def vars (env : Env) : Array (String × Option String) :=
env.installVars ++ #[
("LEAN_PATH", some env.leanPath.toString),
("LEAN_SRC_PATH", some env.leanSrcPath.toString),
(sharedLibPathEnvVar, some env.sharedLibPath.toString)
]
/--
The default search path the Lake executable
uses when interpreting package configuration files.
In order to use the Lean stdlib (e.g., `Init`),
the executable needs the search path to include the directory
with the stdlib's `.olean` files (e.g., from `<lean-sysroot>/lib/lean`).
In order to use Lake's modules as well, the search path also
needs to include Lake's `.olean` files (e.g., from `build`).
While this can be done by having the user augment `LEAN_PATH` with
the necessary directories, Lake also intelligently augments the initial
search path with the `.olean` directories of the provided Lean and Lake
installations.
See `findInstall?` for more information on how Lake determines those
directories. If everything is configured as expected, the user will not
need to augment `LEAN_PATH`. Otherwise, they will need to provide Lake
with more information (either through `LEAN_PATH` or through other options).
-/
def leanSearchPath (env : Lake.Env) : SearchPath :=
env.lake.libDir :: env.lean.leanLibDir :: env.leanPath

View file

@ -0,0 +1,38 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Config.Package
namespace Lake
/-- An external library -- its package plus its configuration. -/
structure ExternLib where
/-- The package the library belongs to. -/
pkg : Package
/-- The external library's name. -/
name : Name
/-- The library's user-defined configuration. -/
config : ExternLibConfig pkg.name name
/-- The external libraries of the package (as an Array). -/
@[inline] def Package.externLibs (self : Package) : Array ExternLib :=
self.externLibConfigs.fold (fun a n v => a.push (⟨self, n, v⟩)) #[]
/-- Try to find a external library in the package with the given name. -/
@[inline] def Package.findExternLib? (name : Name) (self : Package) : Option ExternLib :=
self.externLibConfigs.find? name |>.map (⟨self, name, ·⟩)
namespace ExternLib
/--
The arguments to pass to `leanc` when linking the external library.
That is, the package's `moreLinkArgs`.
-/
@[inline] def linkArgs (self : ExternLib) : Array String :=
self.pkg.moreLinkArgs
/-- The name of the package target used to build the external library's static binary. -/
@[inline] def staticTargetName (self : ExternLib) : Name :=
.str self.name "static"

View file

@ -0,0 +1,21 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Job
namespace Lake
open Lean System
/-- A external library's declarative configuration. -/
structure ExternLibConfig (pkgName name : Name) where
/-- The library's build data. -/
getJob : CustomData (pkgName, .str name "static") → BuildJob FilePath
deriving Inhabited
/-- A dependently typed configuration based on its registered package and name. -/
structure ExternLibDecl where
pkg : Name
name : Name
config : ExternLibConfig pkg name

View file

@ -0,0 +1,68 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone, Mario Carneiro
-/
import Lake.Build.Info
import Lake.Build.Store
namespace Lake
/-- A facet's declarative configuration. -/
structure FacetConfig (DataFam : Name → Type) (ι : Type) (name : Name) : Type where
/-- The facet's build (function). -/
build : ι → IndexBuildM (DataFam name)
/-- Does this facet produce an associated asynchronous job? -/
getJob? : Option (DataFam name → BuildJob Unit)
deriving Inhabited
protected abbrev FacetConfig.name (_ : FacetConfig DataFam ι name) := name
/-- A smart constructor for facet configurations that are not known to generate targets. -/
@[inline] def mkFacetConfig (build : ι → IndexBuildM α)
[h : FamilyOut Fam facet α] : FacetConfig Fam ι facet where
build := cast (by rw [← h.family_key_eq_type]) build
getJob? := none
/--
A smart constructor for facet configurations that generate jobs for the CLI.
This is for small jobs that do not the increase the progress counter.
-/
@[inline] def mkFacetJobConfigSmall (build : ι → IndexBuildM (BuildJob α))
[h : FamilyOut Fam facet (BuildJob α)] : FacetConfig Fam ι facet where
build := cast (by rw [← h.family_key_eq_type]) build
getJob? := some fun data => discard <| ofFamily data
/-- A smart constructor for facet configurations that generate jobs for the CLI. -/
@[inline] def mkFacetJobConfig (build : ι → IndexBuildM (BuildJob α))
[FamilyOut Fam facet (BuildJob α)] : FacetConfig Fam ι facet :=
mkFacetJobConfigSmall fun i => do
let ctx ← readThe BuildContext
ctx.startedBuilds.modify (·+1)
let job ← build i
job.bindSync (prio := .default + 1) fun a trace => do
ctx.finishedBuilds.modify (·+1)
return (a, trace)
/-- A dependently typed configuration based on its registered name. -/
structure NamedConfigDecl (β : Name → Type u) where
name : Name
config : β name
/-- A module facet's declarative configuration. -/
abbrev ModuleFacetConfig := FacetConfig ModuleData Module
/-- A module facet declaration from a configuration file. -/
abbrev ModuleFacetDecl := NamedConfigDecl ModuleFacetConfig
/-- A package facet's declarative configuration. -/
abbrev PackageFacetConfig := FacetConfig PackageData Package
/-- A package facet declaration from a configuration file. -/
abbrev PackageFacetDecl := NamedConfigDecl PackageFacetConfig
/-- A library facet's declarative configuration. -/
abbrev LibraryFacetConfig := FacetConfig LibraryData LeanLib
/-- A library facet declaration from a configuration file. -/
abbrev LibraryFacetDecl := NamedConfigDecl LibraryFacetConfig

View file

@ -0,0 +1,50 @@
/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Mac Malone
-/
import Lean.Util.Path
import Lake.Util.Name
open Lean (Name)
open System (FilePath)
namespace Lake
/-- A specification of a set of module names. -/
inductive Glob
/-- Selects just the specified module name. -/
| one : Name → Glob
/-- Selects all submodules of the specified module, but not the module itself. -/
| submodules : Name → Glob
/-- Selects the specified module and all submodules. -/
| andSubmodules : Name → Glob
deriving Inhabited, Repr
instance : Coe Name Glob := ⟨Glob.one⟩
partial def forEachModuleIn [Monad m] [MonadLiftT IO m]
(dir : FilePath) (f : Name → m PUnit) (ext := "lean") : m PUnit := do
for entry in (← dir.readDir) do
if (← liftM (m := IO) <| entry.path.isDir) then
let n := Name.mkSimple entry.fileName
let r := FilePath.withExtension entry.fileName ext
if (← liftM (m := IO) r.pathExists) then f n
forEachModuleIn entry.path (f <| n ++ ·)
else if entry.path.extension == some ext then
f <| Name.mkSimple <| FilePath.withExtension entry.fileName "" |>.toString
namespace Glob
def «matches» (m : Name) : (self : Glob) → Bool
| one n => n == m
| submodules n => n.isPrefixOf m && n != m
| andSubmodules n => n.isPrefixOf m
@[inline] nonrec def forEachModuleIn [Monad m] [MonadLiftT IO m]
(dir : FilePath) (f : Name → m PUnit) : (self : Glob) → m PUnit
| one n => f n
| submodules n =>
forEachModuleIn (Lean.modToFilePath dir n "") (f <| n ++ ·)
| andSubmodules n =>
f n *> forEachModuleIn (Lean.modToFilePath dir n "") (f <| n ++ ·)

View file

@ -0,0 +1,226 @@
/-
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.Util.NativeLib
open System
namespace Lake
/-- Standard path of `lean` in a Lean installation. -/
def leanExe (sysroot : FilePath) :=
sysroot / "bin" / "lean" |>.withExtension FilePath.exeExtension
/-- Standard path of `leanc` in a Lean installation. -/
def leancExe (sysroot : FilePath) :=
sysroot / "bin" / "leanc" |>.withExtension FilePath.exeExtension
/-- Standard path of `llvm-ar` in a Lean installation. -/
def leanArExe (sysroot : FilePath) :=
sysroot / "bin" / "llvm-ar" |>.withExtension FilePath.exeExtension
/-- Standard path of `clang` in a Lean installation. -/
def leanCcExe (sysroot : FilePath) :=
sysroot / "bin" / "clang" |>.withExtension FilePath.exeExtension
/-- Standard path of `libleanshared` in a Lean installation. -/
def leanSharedLib (sysroot : FilePath) :=
let dir :=
if Platform.isWindows then
sysroot / "bin"
else
sysroot / "lib" / "lean"
dir / "libleanshared" |>.withExtension sharedLibExt
/-- Path information about the local Lean installation. -/
structure LeanInstall where
sysroot : FilePath
githash : String
srcDir := sysroot / "src" / "lean"
leanLibDir := sysroot / "lib" / "lean"
includeDir := sysroot / "include"
systemLibDir := sysroot / "lib"
lean := leanExe sysroot
leanc := leancExe sysroot
sharedLib := leanSharedLib sysroot
ar : FilePath
cc : FilePath
customCc : Bool
deriving Inhabited, Repr
/-- The `LEAN_CC` of the Lean installation. -/
def LeanInstall.leanCc? (self : LeanInstall) : Option String :=
if self.customCc then self.cc.toString else none
/-- Standard path of `lake` in a Lake installation. -/
def lakeExe (buildHome : FilePath) :=
buildHome / "bin" / "lake" |>.withExtension FilePath.exeExtension
/-- Path information about the local Lake installation. -/
structure LakeInstall where
home : FilePath
srcDir := home
libDir := home / "build" / "lib"
lake := lakeExe <| home / "build"
deriving Inhabited, Repr
/--
Try to find the sysroot of the given `lean` command (if it exists)
by calling `lean --print-prefix` and returning the path it prints.
Defaults to trying the `lean` in `PATH`.
-/
def findLeanSysroot? (lean := "lean") : BaseIO (Option FilePath) := do
let act : IO _ := do
let out ← IO.Process.output {
cmd := lean,
args := #["--print-prefix"]
}
if out.exitCode == 0 then
pure <| some <| FilePath.mk <| out.stdout.trim
else
pure <| none
act.catchExceptions fun _ => pure none
/--
Construct the `LeanInstall` object for the given Lean sysroot.
Does the following:
1. Invokes `lean` to find out its `githash`.
2. Finds the `ar` and `cc` to use with Lean.
3. Computes the sub-paths of the Lean install.
For (1), if the invocation fails, `githash` is set to the empty string.
For (2), if `LEAN_AR` or `LEAN_CC` are defined, it uses those paths.
Otherwise, if Lean is packaged with an `llvm-ar` and/or `clang`, use them.
If not, use the `ar` and/or `cc` in the system's `PATH`. This last step is
needed because internal builds of Lean do not bundle these tools
(unlike user-facing releases).
We also track whether `LEAN_CC` was set to determine whether it should
be set in the future for `lake env`. This is because if `LEAN_CC` was not set,
it needs to remain not set for `leanc` to work.
Even setting it to the bundled compiler will break `leanc` -- see
[leanprover/lean4#1281](https://github.com/leanprover/lean4/issues/1281).
For (3), it assumes that the Lean installation is organized the normal way.
That is, with its binaries located in `<lean-sysroot>/bin`, its
Lean libraries in `<lean-sysroot>/lib/lean`, and its system libraries in
`<lean-sysroot>/lib`.
-/
def LeanInstall.get (sysroot : FilePath) : BaseIO LeanInstall := do
let (cc, customCc) ← findCc
return {
sysroot,
githash := ← getGithash
ar := ← findAr
cc, customCc
}
where
getGithash := do
let act : IO _ := do
let out ← IO.Process.output {
cmd := leanExe sysroot |>.toString,
args := #["--githash"]
}
pure <| out.stdout.trim
act.catchExceptions fun _ => pure ""
findAr := do
if let some ar ← IO.getEnv "LEAN_AR" then
return ar
else
let ar := leanArExe sysroot
if (← ar.pathExists) then pure ar else pure "ar"
findCc := do
if let some cc ← IO.getEnv "LEAN_CC" then
return (FilePath.mk cc, true)
else
let cc := leanCcExe sysroot
let cc := if (← cc.pathExists) then cc else "cc"
return (cc, false)
/--
Try to find the installation of the given `lean` command
by calling `findLeanCmdHome?`. See `LeanInstall.get` for how it assumes the
Lean install is organized.
-/
def findLeanCmdInstall? (lean := "lean") : BaseIO (Option LeanInstall) :=
OptionT.run do LeanInstall.get (← findLeanSysroot? lean)
/--
Check if Lake's executable is co-located with Lean, and, if so,
try to return their joint home by assuming they are both located at `<home>/bin`.
-/
def findLakeLeanJointHome? : BaseIO (Option FilePath) := do
if let Except.ok appPath ← IO.appPath.toBaseIO then
if let some appDir := appPath.parent then
let leanExe := appDir / "lean" |>.withExtension FilePath.exeExtension
if (← leanExe.pathExists) then
return appDir.parent
return none
/--
Try to get Lake's home by assuming
the executable is located at `<lake-home>/build/bin/lake`.
-/
def lakePackageHome? (lake : FilePath) : Option FilePath := do
(← (← lake.parent).parent).parent
/--
Try to find Lean's installation by first checking the
`LEAN_SYSROOT` environment variable and then by trying `findLeanCmdHome?`.
See `LeanInstall.get` for how it assumes the Lean install is organized.
-/
def findLeanInstall? : BaseIO (Option LeanInstall) := do
if let some sysroot ← IO.getEnv "LEAN_SYSROOT" then
return some <| ← LeanInstall.get sysroot
if let some sysroot ← findLeanSysroot? then
return some <| ← LeanInstall.get sysroot
return none
/--
Try to find Lake's installation by
first checking the `LAKE_HOME` environment variable
and then by trying the `lakePackageHome?` of the running executable.
It assumes that the Lake installation is organized the same way it is built.
That is, with its binary located at `<lake-home>/build/bin/lake` and its static
library and `.olean` files in `<lake-home>/build/lib`, and its source files
located directly in `<lake-home>`.
-/
def findLakeInstall? : BaseIO (Option LakeInstall) := do
if let some home ← IO.getEnv "LAKE_HOME" then
return some {home}
if let Except.ok lake ← IO.appPath.toBaseIO then
if let some home := lakePackageHome? lake then
return some {home, lake}
return none
/--
Try to get Lake's install path by first trying `findLakeLeanHome?`
then by running `findLeanInstall?` and `findLakeInstall?`.
If Lake is co-located with `lean` (i.e., there is `lean` executable
in the same directory as itself), it will assume it was installed with
Lean and that both Lake's and Lean's files are all located their shared
sysroot.
In particular, their binaries are located in `<sysroot>/bin`,
their Lean libraries in `<sysroot>/lib/lean`,
Lean's source files in `<sysroot>/src/lean`,
and Lake's source files in `<sysroot>/src/lean/lake`.
-/
def findInstall? : BaseIO (Option LeanInstall × Option LakeInstall) := do
if let some home ← findLakeLeanJointHome? then
let lean ← LeanInstall.get home
return (
some lean,
some {
home,
srcDir := lean.srcDir / "lake",
libDir := lean.leanLibDir,
lake := lakeExe home
}
)
else
return (← findLeanInstall?, ← findLakeInstall?)

View file

@ -0,0 +1,83 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/--
Lake equivalent of CMake's
[`CMAKE_BUILD_TYPE`](https://stackoverflow.com/a/59314670).
-/
inductive BuildType
/--
Debug optimization, asserts enabled, custom debug code enabled, and
debug info included in executable (so you can step through the code with a
debugger and have address to source-file:line-number translation).
For example, passes `-Og -g` when compiling C code.
-/
| debug
/--
Optimized, *with* debug info, but no debug code or asserts
(e.g., passes `-O3 -g -DNDEBUG` when compiling C code).
-/
| relWithDebInfo
/--
Same as `release` but optimizing for size rather than speed
(e.g., passes `-Os -DNDEBUG` when compiling C code).
-/
| minSizeRel
/--
High optimization level and no debug info, code, or asserts
(e.g., passes `-O3 -DNDEBUG` when compiling C code).
-/
| release
deriving Inhabited, Repr, DecidableEq, Ord
instance : LT BuildType := ltOfOrd
instance : LE BuildType := leOfOrd
instance : Min BuildType := minOfLe
instance : Max BuildType := maxOfLe
/-- The arguments to pass to `leanc` based on the build type. -/
def BuildType.leancArgs : BuildType → Array String
| debug => #["-Og", "-g"]
| relWithDebInfo => #["-O3", "-g", "-DNDEBUG"]
| minSizeRel => #["-Os", "-DNDEBUG"]
| release => #["-O3", "-DNDEBUG"]
/-- Configuration options common to targets that build modules. -/
structure LeanConfig where
/--
The mode in which the modules should be built (e.g., `debug`, `release`).
Defaults to `release`.
-/
buildType : BuildType := .release
/--
Additional arguments to pass to `lean`
when compiling a module's Lean source files.
-/
moreLeanArgs : Array String := #[]
/--
Additional arguments to pass to `lean`
when compiling a module's Lean source files.
Unlike `moreLeanArgs`, these arguments do not affect the trace
of the build result, so they can be changed without triggering a rebuild.
-/
weakLeanArgs : Array String := #[]
/--
Additional arguments to pass to `leanc`
when compiling a module's C source files generated by `lean`.
Lake already passes some flags based on the `buildType`,
but you can change this by, for example, adding `-O0` and `-UNDEBUG`.
-/
moreLeancArgs : Array String := #[]
/--
Additional arguments to pass to `leanc` when linking (e.g., for shared
libraries or binary executables). These will come *after* the paths of
external libraries.
-/
moreLinkArgs : Array String := #[]
deriving Inhabited, Repr

View file

@ -0,0 +1,84 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Config.Module
namespace Lake
open Lean System
/-- A Lean executable -- its package plus its configuration. -/
structure LeanExe where
/-- The package the executable belongs to. -/
pkg : Package
/-- The executable's user-defined configuration. -/
config : LeanExeConfig
/-- The Lean executables of the package (as an Array). -/
@[inline] def Package.leanExes (self : Package) : Array LeanExe :=
self.leanExeConfigs.fold (fun a _ v => a.push (⟨self, v⟩)) #[]
/-- Try to find a Lean executable in the package with the given name. -/
@[inline] def Package.findLeanExe? (name : Name) (self : Package) : Option LeanExe :=
self.leanExeConfigs.find? name |>.map (⟨self, ·⟩)
/--
Converts the executable configuration into a library
with a single module (the root).
-/
def LeanExeConfig.toLeanLibConfig (self : LeanExeConfig) : LeanLibConfig where
name := self.name
roots := #[]
libName := self.exeName
toLeanConfig := self.toLeanConfig
namespace LeanExe
/-- The executable's well-formed name. -/
@[inline] def name (self : LeanExe) : Name :=
self.config.name
/-- Converts the executable into a library with a single module (the root). -/
@[inline] def toLeanLib (self : LeanExe) : LeanLib :=
⟨self.pkg, self.config.toLeanLibConfig⟩
/-- The executable's root module. -/
@[inline] def root (self : LeanExe) : Module where
lib := self.toLeanLib
name := self.config.root
keyName := self.pkg.name ++ self.config.root
/-- Return the the root module if the name matches, otherwise return none. -/
def isRoot? (name : Name) (self : LeanExe) : Option Module :=
if name == self.config.root then some self.root else none
/--
The file name of binary executable
(i.e., `exeName` plus the platform's `exeExtension`).
-/
@[inline] def fileName (self : LeanExe) : FilePath :=
FilePath.withExtension self.config.exeName FilePath.exeExtension
/-- The path to the executable in the package's `binDir`. -/
@[inline] def file (self : LeanExe) : FilePath :=
self.pkg.binDir / self.fileName
/--
The arguments to pass to `leanc` when linking the binary executable.
That is, `-rdynamic` (if non-Windows and `supportInterpreter`) plus the
package's and then the executable's `moreLinkArgs`.
-/
def linkArgs (self : LeanExe) : Array String :=
if self.config.supportInterpreter && !Platform.isWindows then
#["-rdynamic"] ++ self.pkg.moreLinkArgs ++ self.config.moreLinkArgs
else
self.pkg.moreLinkArgs ++ self.config.moreLinkArgs
end LeanExe
/-- Locate the named module in the package (if it is buildable and local to it). -/
def Package.findModule? (mod : Name) (self : Package) : Option Module :=
self.leanLibs.findSome? (·.findModule? mod) <|>
self.leanExes.findSome? (·.isRoot? mod)

View file

@ -0,0 +1,46 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Config.LeanConfig
namespace Lake
open Lean System
/-- A Lean executable's declarative configuration. -/
structure LeanExeConfig extends LeanConfig where
/-- The name of the target. -/
name : Name
/--
The root module of the binary executable.
Should include a `main` definition that will serve
as the entry point of the program.
The root is built by recursively building its
local imports (i.e., fellow modules of the workspace).
Defaults to the name of the target.
-/
root : Name := name
/--
The name of the binary executable.
Defaults to the target name with any `.` replaced with a `-`.
-/
exeName : String := name.toStringWithSep "-" (escape := false)
/--
Whether to expose symbols within the executable to the Lean interpreter.
This allows the executable to interpret Lean files (e.g., via
`Lean.Elab.runFrontend`).
Implementation-wise, this passes `-rdynamic` to the linker when building
on non-Windows systems.
Defaults to `false`.
-/
supportInterpreter : Bool := false
deriving Inhabited, Repr

View file

@ -0,0 +1,120 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Config.Package
namespace Lake
open Lean System
/-- A Lean library -- its package plus its configuration. -/
structure LeanLib where
/-- The package the library belongs to. -/
pkg : Package
/-- The library's user-defined configuration. -/
config : LeanLibConfig
/-- The Lean libraries of the package (as an Array). -/
@[inline] def Package.leanLibs (self : Package) : Array LeanLib :=
self.leanLibConfigs.fold (fun a _ v => a.push (⟨self, v⟩)) #[]
/-- Try to find a Lean library in the package with the given name. -/
@[inline] def Package.findLeanLib? (name : Name) (self : Package) : Option LeanLib :=
self.leanLibConfigs.find? name |>.map (⟨self, ·⟩)
namespace LeanLib
/-- The library's well-formed name. -/
@[inline] def name (self : LeanLib) : Name :=
self.config.name
/-- The package's `srcDir` joined with the library's `srcDir`. -/
@[inline] def srcDir (self : LeanLib) : FilePath :=
self.pkg.srcDir / self.config.srcDir
/-- The library's root directory for `lean` (i.e., `srcDir`). -/
@[inline] def rootDir (self : LeanLib) : FilePath :=
self.srcDir
/--
The names of the library's root modules
(i.e., the library's `roots` configuration).
-/
@[inline] def roots (self : LeanLib) : Array Name :=
self.config.roots
/-- Whether the given module is considered local to the library. -/
@[inline] def isLocalModule (mod : Name) (self : LeanLib) : Bool :=
self.config.isLocalModule mod
/-- Whether the given module is a buildable part of the library. -/
@[inline] def isBuildableModule (mod : Name) (self : LeanLib) : Bool :=
self.config.isBuildableModule mod
/-- The file name of the library's static binary (i.e., its `.a`) -/
@[inline] def staticLibFileName (self : LeanLib) : FilePath :=
nameToStaticLib self.config.libName
/-- The path to the static library in the package's `libDir`. -/
@[inline] def staticLibFile (self : LeanLib) : FilePath :=
self.pkg.nativeLibDir / self.staticLibFileName
/-- The file name of the library's shared binary (i.e., its `dll`, `dylib`, or `so`) . -/
@[inline] def sharedLibFileName (self : LeanLib) : FilePath :=
nameToSharedLib self.config.libName
/-- The path to the shared library in the package's `libDir`. -/
@[inline] def sharedLibFile (self : LeanLib) : FilePath :=
self.pkg.nativeLibDir / self.sharedLibFileName
/--
Whether to precompile the library's modules.
Is true if either the package or the library have `precompileModules` set.
-/
@[inline] def precompileModules (self : LeanLib) : Bool :=
self.pkg.precompileModules || self.config.precompileModules
/-- The library's `defaultFacets` configuration. -/
@[inline] def defaultFacets (self : LeanLib) : Array Name :=
self.config.defaultFacets
/-- The library's `nativeFacets` configuration. -/
@[inline] def nativeFacets (self : LeanLib) : Array (ModuleFacet (BuildJob FilePath)) :=
self.config.nativeFacets
/--
The build type for modules of this library.
That is, the minimum of package's `buildType` and the library's `buildType`.
-/
@[inline] def buildType (self : LeanLib) : BuildType :=
min self.pkg.buildType self.config.buildType
/--
The arguments to pass to `lean` when compiling the library's Lean files.
That is, the package's `moreLeanArgs` plus the library's `moreLeanArgs`.
-/
@[inline] def leanArgs (self : LeanLib) : Array String :=
self.pkg.moreLeanArgs ++ self.config.moreLeanArgs
/--
The arguments to weakly pass to `lean` when compiling the library's Lean files.
That is, the package's `weakLeanArgs` plus the library's `weakLeanArgs`.
-/
@[inline] def weakLeanArgs (self : LeanLib) : Array String :=
self.pkg.weakLeanArgs ++ self.config.weakLeanArgs
/--
The arguments to pass to `leanc` when compiling the library's C files.
That is, the build type's `leancArgs`, the package's `moreLeancArgs`,
and then the library's `moreLeancArgs`.
-/
@[inline] def leancArgs (self : LeanLib) : Array String :=
self.buildType.leancArgs ++ self.pkg.moreLeancArgs ++ self.config.moreLeancArgs
/--
The arguments to pass to `leanc` when linking the shared library.
That is, the package's `moreLinkArgs` plus the library's `moreLinkArgs`.
-/
@[inline] def linkArgs (self : LeanLib) : Array String :=
self.pkg.moreLinkArgs ++ self.config.moreLinkArgs

View file

@ -0,0 +1,89 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.Casing
import Lake.Build.Facets
import Lake.Config.InstallPath
import Lake.Config.LeanConfig
import Lake.Config.Glob
namespace Lake
open Lean System
/-- A Lean library's declarative configuration. -/
structure LeanLibConfig extends LeanConfig where
/-- The name of the target. -/
name : Name
/--
The subdirectory of the package's source directory containing the library's
Lean source files. Defaults simply to said `srcDir`.
(This will be passed to `lean` as the `-R` option.)
-/
srcDir : FilePath := "."
/--
The root module(s) of the library.
Submodules of these roots (e.g., `Lib.Foo` of `Lib`) are considered
part of the package.
Defaults to a single root of the library's upper camel case name.
-/
roots : Array Name := #[toUpperCamelCase name]
/--
An `Array` of module `Glob`s to build for the library.
Defaults to a `Glob.one` of each of the library's `roots`.
Submodule globs build every source file within their directory.
Local imports of glob'ed files (i.e., fellow modules of the workspace) are
also recursively built.
-/
globs : Array Glob := roots.map Glob.one
/--
The name of the library.
Used as a base for the file names of its static and dynamic binaries.
Defaults to the upper camel case name of the target.
-/
libName := toUpperCamelCase name |>.toString (escape := false)
/--
Whether to compile each of the library's modules into a native shared library
that is loaded whenever the module is imported. This speeds up evaluation of
metaprograms and enables the interpreter to run functions marked `@[extern]`.
Defaults to `false`.
-/
precompileModules : Bool := false
/--
An `Array` of library facets to build on a bare `lake build` of the library.
For example, `#[LeanLib.sharedLib]` will build the shared library facet.
-/
defaultFacets : Array Name := #[LeanLib.leanFacet]
/--
An `Array` of module facets to build and combine into the library's static
and shared libraries. Defaults to ``#[Module.oFacet]`` (i.e., the object file
compiled from the Lean source).
-/
nativeFacets : Array (ModuleFacet (BuildJob FilePath)) := #[Module.oFacet]
deriving Inhabited
namespace LeanLibConfig
/-- Whether the given module is considered local to the library. -/
def isLocalModule (mod : Name) (self : LeanLibConfig) : Bool :=
self.roots.any (fun root => root.isPrefixOf mod) ||
self.globs.any (fun glob => glob.matches mod)
/-- Whether the given module is a buildable part of the library. -/
def isBuildableModule (mod : Name) (self : LeanLibConfig) : Bool :=
self.globs.any (fun glob => glob.matches mod) ||
self.roots.any (fun root => root.isPrefixOf mod && self.globs.any (·.matches root))

View file

@ -0,0 +1,131 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Trace
import Lake.Config.LeanLib
import Lake.Util.OrdHashSet
namespace Lake
open Lean System
/-- A buildable Lean module of a `LeanLib`. -/
structure Module where
lib : LeanLib
name : Name
/--
The name of the module as a key.
Used to create private modules (e.g., executable roots).
-/
keyName : Name := name
instance : Hashable Module where hash m := hash m.keyName
instance : BEq Module where beq m n := m.keyName == n.keyName
abbrev ModuleSet := HashSet Module
@[inline] def ModuleSet.empty : ModuleSet := HashSet.empty
abbrev OrdModuleSet := OrdHashSet Module
@[inline] def OrdModuleSet.empty : OrdModuleSet := OrdHashSet.empty
abbrev ModuleMap (α) := RBMap Module α (·.name.quickCmp ·.name)
@[inline] def ModuleMap.empty : ModuleMap α := RBMap.empty
/-- Locate the named module in the library (if it is buildable and local to it). -/
def LeanLib.findModule? (mod : Name) (self : LeanLib) : Option Module :=
if self.isBuildableModule mod then some {lib := self, name := mod} else none
/-- Get an `Array` of the library's modules (as specified by its globs). -/
def LeanLib.getModuleArray (self : LeanLib) : IO (Array Module) :=
(·.2) <$> StateT.run (s := #[]) do
self.config.globs.forM fun glob => do
glob.forEachModuleIn self.srcDir fun mod => do
modify (·.push {lib := self, name := mod})
/-- The library's buildable root modules. -/
def LeanLib.rootModules (self : LeanLib) : Array Module :=
self.config.roots.filterMap self.findModule?
namespace Module
abbrev pkg (self : Module) : Package :=
self.lib.pkg
@[inline] def rootDir (self : Module) : FilePath :=
self.lib.rootDir
@[inline] def filePath (dir : FilePath) (ext : String) (self : Module) : FilePath :=
Lean.modToFilePath dir self.name ext
@[inline] def srcPath (ext : String) (self : Module) : FilePath :=
self.filePath self.lib.srcDir ext
@[inline] def leanFile (self : Module) : FilePath :=
self.srcPath "lean"
@[inline] def leanLibPath (ext : String) (self : Module) : FilePath :=
self.filePath self.pkg.leanLibDir ext
@[inline] def oleanFile (self : Module) : FilePath :=
self.leanLibPath "olean"
@[inline] def ileanFile (self : Module) : FilePath :=
self.leanLibPath "ilean"
@[inline] def traceFile (self : Module) : FilePath :=
self.leanLibPath "trace"
@[inline] def irPath (ext : String) (self : Module) : FilePath :=
self.filePath self.pkg.irDir ext
@[inline] def cFile (self : Module) : FilePath :=
self.irPath "c"
@[inline] def oFile (self : Module) : FilePath :=
self.irPath "o"
@[inline] def dynlibName (self : Module) : String :=
-- NOTE: file name MUST be unique on Windows
self.name.toStringWithSep "-" (escape := true)
@[inline] def dynlibFile (self : Module) : FilePath :=
self.pkg.nativeLibDir / nameToSharedLib self.dynlibName
@[inline] def buildType (self : Module) : BuildType :=
self.lib.buildType
@[inline] def leanArgs (self : Module) : Array String :=
self.lib.leanArgs
@[inline] def weakLeanArgs (self : Module) : Array String :=
self.lib.weakLeanArgs
@[inline] def leancArgs (self : Module) : Array String :=
self.lib.leancArgs
@[inline] def linkArgs (self : Module) : Array String :=
self.lib.linkArgs
@[inline] def shouldPrecompile (self : Module) : Bool :=
self.lib.precompileModules
@[inline] def nativeFacets (self : Module) : Array (ModuleFacet (BuildJob FilePath)) :=
self.lib.nativeFacets
/-! ## Trace Helpers -/
protected def getMTime (self : Module) : IO MTime := do
return mixTrace (← getMTime self.oleanFile) (← getMTime self.ileanFile)
instance : GetMTime Module := ⟨Module.getMTime⟩
protected def computeHash (self : Module) : IO Hash := do
return mixTrace (← computeHash self.oleanFile) (← computeHash self.ileanFile)
instance : ComputeHash Module IO := ⟨Module.computeHash⟩
protected def checkExists (self : Module) : BaseIO Bool := do
return (← checkExists self.oleanFile) && (← checkExists self.ileanFile)
instance : CheckExists Module := ⟨Module.checkExists⟩

View file

@ -0,0 +1,202 @@
/-
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.Context
import Lake.Config.Workspace
open System
open Lean (Name)
/-! # Lake Configuration Monads
Definitions and helpers for interacting with the Lake configuration monads.
-/
namespace Lake
/-- A monad equipped with a (read-only) detected environment for Lake. -/
abbrev MonadLakeEnv (m : Type → Type u) :=
MonadReaderOf Lake.Env m
/-- A monad equipped with a (read-only) Lake `Workspace`. -/
abbrev MonadWorkspace (m : Type → Type u) :=
MonadReaderOf Workspace m
/-- A monad equipped with a (read-only) Lake context. -/
abbrev MonadLake (m : Type → Type u) :=
MonadReaderOf Context m
/-- Make a `Lake.Context` from a `Workspace`. -/
def mkLakeContext (ws : Workspace) : Context where
opaqueWs := ws
@[inline] def Context.workspace (self : Context) :=
self.opaqueWs.get
instance [MonadLake m] [Functor m] : MonadWorkspace m where
read := (·.workspace) <$> read
instance [MonadWorkspace m] [Functor m] : MonadLakeEnv m where
read := (·.lakeEnv) <$> read
section
variable [MonadWorkspace m]
/-! ## Workspace Helpers -/
/-- Get the workspace of the context. -/
@[inline] def getWorkspace : m Workspace :=
read
variable [Functor m]
/-- Get the root package of the context's workspace. -/
@[inline] def getRootPackage : m Package :=
(·.root) <$> read
@[inherit_doc Workspace.findPackage?, inline]
def findPackage? (name : Name) : m (Option (NPackage name)) :=
(·.findPackage? name) <$> getWorkspace
@[inherit_doc Workspace.findModule?, inline]
def findModule? (name : Name) : m (Option Module) :=
(·.findModule? name) <$> getWorkspace
@[inherit_doc Workspace.findLeanExe?, inline]
def findLeanExe? (name : Name) : m (Option LeanExe) :=
(·.findLeanExe? name) <$> getWorkspace
@[inherit_doc Workspace.findLeanLib?, inline]
def findLeanLib? (name : Name) : m (Option LeanLib) :=
(·.findLeanLib? name) <$> getWorkspace
@[inherit_doc Workspace.findExternLib?, inline]
def findExternLib? (name : Name) : m (Option ExternLib) :=
(·.findExternLib? name) <$> getWorkspace
/-- Get the paths added to `LEAN_PATH` by the context's workspace. -/
@[inline] def getLeanPath : m SearchPath :=
(·.leanPath) <$> getWorkspace
/-- Get the paths added to `LEAN_SRC_PATH` by the context's workspace. -/
@[inline] def getLeanSrcPath : m SearchPath :=
(·.leanSrcPath) <$> getWorkspace
/-- Get the paths added to the shared library path by the context's workspace. -/
@[inline] def getSharedLibPath : m SearchPath :=
(·.sharedLibPath) <$> getWorkspace
/-- Get the augmented `LEAN_PATH` set by the context's workspace. -/
@[inline] def getAugmentedLeanPath : m SearchPath :=
(·.augmentedLeanPath) <$> getWorkspace
/-- Get the augmented `LEAN_SRC_PATH` set by the context's workspace. -/
@[inline] def getAugmentedLeanSrcPath : m SearchPath :=
(·.augmentedLeanSrcPath) <$> getWorkspace
/-- Get the augmented shared library path set by the context's workspace. -/
@[inline] def getAugmentedSharedLibPath : m SearchPath :=
(·.augmentedSharedLibPath) <$> getWorkspace
/-- Get the augmented environment variables set by the context's workspace. -/
@[inline] def getAugmentedEnv : m (Array (String × Option String)) :=
(·.augmentedEnvVars) <$> getWorkspace
end
section
variable [MonadLakeEnv m] [Functor m]
/-! ## Environment Helpers -/
@[inline] def getLakeEnv : m Lake.Env :=
read
/-! ### Search Path Helpers -/
/-- Get the detected `LEAN_PATH` value of the Lake environment. -/
@[inline] def getEnvLeanPath : m SearchPath :=
(·.leanPath) <$> getLakeEnv
/-- Get the detected `LEAN_SRC_PATH` value of the Lake environment. -/
@[inline] def getEnvLeanSrcPath : m SearchPath :=
(·.leanSrcPath) <$> getLakeEnv
/-- Get the detected `sharedLibPathEnvVar` value of the Lake environment. -/
@[inline] def getEnvSharedLibPath : m SearchPath :=
(·.sharedLibPath) <$> getLakeEnv
/-! ### Lean Install Helpers -/
/-- Get the detected Lean installation. -/
@[inline] def getLeanInstall : m LeanInstall :=
(·.lean) <$> getLakeEnv
/-- Get the root directory of the detected Lean installation. -/
@[inline] def getLeanSysroot : m FilePath :=
(·.sysroot) <$> getLeanInstall
/-- Get the Lean source directory of the detected Lean installation. -/
@[inline] def getLeanSrcDir : m FilePath :=
(·.srcDir) <$> getLeanInstall
/-- Get the Lean library directory of the detected Lean installation. -/
@[inline] def getLeanLibDir : m FilePath :=
(·.leanLibDir) <$> getLeanInstall
/-- Get the C include directory of the detected Lean installation. -/
@[inline] def getLeanIncludeDir : m FilePath :=
(·.includeDir) <$> getLeanInstall
/-- Get the system library directory of the detected Lean installation. -/
@[inline] def getLeanSystemLibDir : m FilePath :=
(·.systemLibDir) <$> getLeanInstall
/-- Get the path of the `lean` binary in the detected Lean installation. -/
@[inline] def getLean : m FilePath :=
(·.lean) <$> getLeanInstall
/-- Get the path of the `leanc` binary in the detected Lean installation. -/
@[inline] def getLeanc : m FilePath :=
(·.leanc) <$> getLeanInstall
/-- Get the path of the `libleanshared` library in the detected Lean installation. -/
@[inline] def getLeanSharedLib : m FilePath :=
(·.sharedLib) <$> getLeanInstall
/-- Get the path of the `ar` binary in the detected Lean installation. -/
@[inline] def getLeanAr : m FilePath :=
(·.ar) <$> getLeanInstall
/-- Get the path of C compiler in the detected Lean installation. -/
@[inline] def getLeanCc : m FilePath :=
(·.cc) <$> getLeanInstall
/-- Get the optional `LEAN_CC` compiler override of the detected Lean installation. -/
@[inline] def getLeanCc? : m (Option String) :=
(·.leanCc?) <$> getLeanInstall
/-! ### Lake Install Helpers -/
/-- Get the detected Lake installation. -/
@[inline] def getLakeInstall : m LakeInstall :=
(·.lake) <$> getLakeEnv
/-- Get the root directory of the detected Lake installation (e.g., `LAKE_HOME`). -/
@[inline] def getLakeHome : m FilePath :=
(·.home) <$> getLakeInstall
/-- Get the source directory of the detected Lake installation. -/
@[inline] def getLakeSrcDir : m FilePath :=
(·.srcDir) <$> getLakeInstall
/-- Get the Lean library directory of the detected Lake installation. -/
@[inline] def getLakeLibDir : m FilePath :=
(·.libDir) <$> getLakeInstall
/-- Get the path of the `lake` binary in the detected Lake installation. -/
@[inline] def getLake : m FilePath :=
(·.lake) <$> getLakeInstall
end

View file

@ -0,0 +1,18 @@
/-
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.Util.Name
import Lake.Util.Opaque
namespace Lake
/-- Opaque reference to a `Package` used for forward declaration. -/
declare_opaque_type OpaquePackage
/-- Opaque reference to a `Workspace` used for forward declaration. -/
declare_opaque_type OpaqueWorkspace
/-- Opaque reference to a `TargetConfig` used for forward declaration. -/
declare_opaque_type OpaqueTargetConfig (pkgName name : Name)

View file

@ -0,0 +1,367 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake.Config.Opaque
import Lake.Config.LeanLibConfig
import Lake.Config.LeanExeConfig
import Lake.Config.ExternLibConfig
import Lake.Config.WorkspaceConfig
import Lake.Config.Dependency
import Lake.Config.Script
import Lake.Util.DRBMap
import Lake.Util.OrdHashSet
open System Lean
namespace Lake
/-- A string descriptor of the `System.Platform` OS (`windows`, `macOS`, or `linux`). -/
def osDescriptor : String :=
if Platform.isWindows then
"windows"
else if Platform.isOSX then
"macOS"
else
"linux"
/--
A `tar.gz` file name suffix encoding the the current Platform.
(i.e, `osDescriptor` joined with `System.Platform.numBits`).
-/
def archiveSuffix :=
s!"{osDescriptor}-{Platform.numBits}.tar.gz"
/-- If `name?`, `{name}-{archiveSuffix}`, otherwise just `archiveSuffix`. -/
def nameToArchive (name? : Option String) : String :=
match name? with
| none => archiveSuffix
| some name => s!"{name}-{archiveSuffix}"
/--
First tries to convert a string into a legal name.
If that fails, defaults to making it a simple name (e.g., `Lean.Name.mkSimple`).
Currently used for package and target names taken from the CLI.
-/
def stringToLegalOrSimpleName (s : String) : Name :=
if s.toName.isAnonymous then Lean.Name.mkSimple s else s.toName
--------------------------------------------------------------------------------
/-! # Defaults -/
--------------------------------------------------------------------------------
/-- The default setting for a `PackageConfig`'s `manifestFile` option. -/
def defaultManifestFile := "lake-manifest.json"
/-- The default setting for a `PackageConfig`'s `buildDir` option. -/
def defaultBuildDir : FilePath := "build"
/-- The default setting for a `PackageConfig`'s `leanLibDir` option. -/
def defaultLeanLibDir : FilePath := "lib"
/-- The default setting for a `PackageConfig`'s `nativeLibDir` option. -/
def defaultNativeLibDir : FilePath := "lib"
/-- The default setting for a `PackageConfig`'s `binDir` option. -/
def defaultBinDir : FilePath := "bin"
/-- The default setting for a `PackageConfig`'s `irDir` option. -/
def defaultIrDir : FilePath := "ir"
--------------------------------------------------------------------------------
/-! # PackageConfig -/
--------------------------------------------------------------------------------
/-- A `Package`'s declarative configuration. -/
structure PackageConfig extends WorkspaceConfig, LeanConfig where
/-- The `Name` of the package. -/
name : Name
/--
The path of a package's manifest file, which stores the exact versions
of its resolved dependencies.
Defaults to `defaultManifestFile` (i.e., `lake-manifest.json`).
-/
manifestFile := defaultManifestFile
/-- An `Array` of target names to build whenever the package is used. -/
extraDepTargets : Array Name := #[]
/--
Whether to compile each of the package's module into a native shared library
that is loaded whenever the module is imported. This speeds up evaluation of
metaprograms and enables the interpreter to run functions marked `@[extern]`.
Defaults to `false`.
-/
precompileModules : Bool := false
/--
Additional arguments to pass to the Lean language server
(i.e., `lean --server`) launched by `lake server`.
-/
moreServerArgs : Array String := #[]
/--
The directory containing the package's Lean source files.
Defaults to the package's directory.
(This will be passed to `lean` as the `-R` option.)
-/
srcDir : FilePath := "."
/--
The directory to which Lake should output the package's build results.
Defaults to `defaultBuildDir` (i.e., `build`).
-/
buildDir : FilePath := defaultBuildDir
/--
The build subdirectory to which Lake should output the package's
binary Lean libraries (e.g., `.olean`, `.ilean` files).
Defaults to `defaultLeanLibDir` (i.e., `lib`).
-/
leanLibDir : FilePath := defaultLeanLibDir
/--
The build subdirectory to which Lake should output the package's
native libraries (e.g., `.a`, `.so`, `.dll` files).
Defaults to `defaultNativeLibDir` (i.e., `lib`).
-/
nativeLibDir : FilePath := defaultNativeLibDir
/--
The build subdirectory to which Lake should output the package's binary executable.
Defaults to `defaultBinDir` (i.e., `bin`).
-/
binDir : FilePath := defaultBinDir
/--
The build subdirectory to which Lake should output
the package's intermediary results (e.g., `.c` and `.o` files).
Defaults to `defaultIrDir` (i.e., `ir`).
-/
irDir : FilePath := defaultIrDir
/--
The URL of the GitHub repository to upload and download releases of this package.
If `none` (the default), for downloads, Lake uses the URL the package was download
from (if it is a dependency) and for uploads, uses `gh`'s default.
-/
releaseRepo? : Option String := none
/--
The name of the build archive on GitHub. Defaults to `none`.
The archive's full file name will be `nameToArchive buildArchive?`.
-/
buildArchive? : Option String := none
/--
Whether to prefer downloading a prebuilt release (from GitHub) rather than
building this package from the source when this package is used as a dependency.
-/
preferReleaseBuild : Bool := false
deriving Inhabited
--------------------------------------------------------------------------------
/-! # Package -/
--------------------------------------------------------------------------------
abbrev DNameMap α := DRBMap Name α Name.quickCmp
@[inline] def DNameMap.empty : DNameMap α := DRBMap.empty
/-- A Lake package -- its location plus its configuration. -/
structure Package where
/-- The path to the package's directory. -/
dir : FilePath
/-- The package's user-defined configuration. -/
config : PackageConfig
/-- The elaboration environment of the package's configuration file. -/
configEnv : Environment
/-- The Lean `Options` the package configuration was elaborated with. -/
leanOpts : Options
/-- The URL to this package's Git remote. -/
remoteUrl? : Option String := none
/-- The Git tag of this package. -/
gitTag? : Option String := none
/-- (Opaque references to) the package's direct dependencies. -/
opaqueDeps : Array OpaquePackage := #[]
/-- Lean library configurations for the package. -/
leanLibConfigs : NameMap LeanLibConfig := {}
/-- Lean binary executable configurations for the package. -/
leanExeConfigs : NameMap LeanExeConfig := {}
/-- External library targets for the package. -/
externLibConfigs : DNameMap (ExternLibConfig config.name) := {}
/-- (Opaque references to) targets defined in the package. -/
opaqueTargetConfigs : DNameMap (OpaqueTargetConfig config.name) := {}
/--
The names of the package's targets to build by default
(i.e., on a bare `lake build` of the package).
-/
defaultTargets : Array Name := #[]
/-- Scripts for the package. -/
scripts : NameMap Script := {}
/--
The names of the package's scripts run by default
(i.e., on a bare `lake run` of the package).
-/
defaultScripts : Array Script := #[]
instance : Nonempty Package :=
have : Inhabited Environment := Classical.inhabited_of_nonempty inferInstance
by refine' ⟨{..}⟩ <;> exact default
hydrate_opaque_type OpaquePackage Package
instance : Hashable Package where hash pkg := hash pkg.config.name
instance : BEq Package where beq p1 p2 := p1.config.name == p2.config.name
abbrev PackageSet := HashSet Package
@[inline] def PackageSet.empty : PackageSet := HashSet.empty
abbrev OrdPackageSet := OrdHashSet Package
@[inline] def OrdPackageSet.empty : OrdPackageSet := OrdHashSet.empty
/-- The package's name. -/
abbrev Package.name (self : Package) : Name :=
self.config.name
/-- A package with a name known at type-level. -/
structure NPackage (name : Name) extends Package where
name_eq : toPackage.name = name
attribute [simp] NPackage.name_eq
instance : CoeOut (NPackage name) Package := ⟨NPackage.toPackage⟩
instance : CoeDep Package pkg (NPackage pkg.name) := ⟨⟨pkg, rfl⟩⟩
/-- The package's name. -/
abbrev NPackage.name (_ : NPackage n) := n
namespace Package
/-- The package's direct dependencies. -/
@[inline] def deps (self : Package) : Array Package :=
self.opaqueDeps.map (·.get)
/--
The directory for storing the package's remote dependencies.
Either its `packagesDir` configuration or `defaultPackagesDir`.
-/
def relPkgsDir (self : Package) : FilePath :=
self.config.packagesDir.getD defaultPackagesDir
/-- The package's `dir` joined with its `relPkgsDir` -/
def pkgsDir (self : Package) : FilePath :=
self.dir / self.relPkgsDir
/-- The package's JSON manifest of remote dependencies. -/
def manifestFile (self : Package) : FilePath :=
self.dir / self.config.manifestFile
/-- The package's `dir` joined with its `buildDir` configuration. -/
@[inline] def buildDir (self : Package) : FilePath :=
self.dir / self.config.buildDir
/-- The package's `extraDepTargets` configuration. -/
@[inline] def extraDepTargets (self : Package) : Array Name :=
self.config.extraDepTargets
/-- The package's `releaseRepo?` configuration. -/
@[inline] def releaseRepo? (self : Package) : Option String :=
self.config.releaseRepo?
/--
The package's URL × tag release.
Tries `releaseRepo?` first and then falls back to `remoteUrl?`.
-/
def release? (self : Package) : Option (String × String) := do
let url ← self.releaseRepo? <|> self.remoteUrl?
let tag ← self.gitTag?
return (url, tag)
/-- The package's `buildArchive?` configuration. -/
@[inline] def buildArchive? (self : Package) : Option String :=
self.config.buildArchive?
/-- The file name of the package's build archive derived from `buildArchive?`. -/
@[inline] def buildArchive (self : Package) : String :=
nameToArchive self.buildArchive?
/-- The package's `buildDir` joined with its `buildArchive` configuration. -/
@[inline] def buildArchiveFile (self : Package) : FilePath :=
self.buildDir / self.buildArchive
/-- The package's `preferReleaseBuild` configuration. -/
@[inline] def preferReleaseBuild (self : Package) : Bool :=
self.config.preferReleaseBuild
/-- The package's `precompileModules` configuration. -/
@[inline] def precompileModules (self : Package) : Bool :=
self.config.precompileModules
/-- The package's `moreServerArgs` configuration. -/
@[inline] def moreServerArgs (self : Package) : Array String :=
self.config.moreServerArgs
/-- The package's `buildType` configuration. -/
@[inline] def buildType (self : Package) : BuildType :=
self.config.buildType
/-- The package's `moreLeanArgs` configuration. -/
@[inline] def moreLeanArgs (self : Package) : Array String :=
self.config.moreLeanArgs
/-- The package's `weakLeanArgs` configuration. -/
@[inline] def weakLeanArgs (self : Package) : Array String :=
self.config.weakLeanArgs
/-- The package's `moreLeancArgs` configuration. -/
@[inline] def moreLeancArgs (self : Package) : Array String :=
self.config.moreLeancArgs
/-- The package's `moreLinkArgs` configuration. -/
@[inline] def moreLinkArgs (self : Package) : Array String :=
self.config.moreLinkArgs
/-- The package's `dir` joined with its `srcDir` configuration. -/
@[inline] def srcDir (self : Package) : FilePath :=
self.dir / self.config.srcDir
/-- The package's root directory for `lean` (i.e., `srcDir`). -/
@[inline] def rootDir (self : Package) : FilePath :=
self.srcDir
/-- The package's `buildDir` joined with its `leanLibDir` configuration. -/
@[inline] def leanLibDir (self : Package) : FilePath :=
self.buildDir / self.config.leanLibDir
/-- The package's `buildDir` joined with its `nativeLibDir` configuration. -/
@[inline] def nativeLibDir (self : Package) : FilePath :=
self.buildDir / self.config.nativeLibDir
/-- The package's `buildDir` joined with its `binDir` configuration. -/
@[inline] def binDir (self : Package) : FilePath :=
self.buildDir / self.config.binDir
/-- The package's `buildDir` joined with its `irDir` configuration. -/
@[inline] def irDir (self : Package) : FilePath :=
self.buildDir / self.config.irDir
/-- Whether the given module is considered local to the package. -/
def isLocalModule (mod : Name) (self : Package) : Bool :=
self.leanLibConfigs.any (fun _ lib => lib.isLocalModule mod)
/-- Whether the given module is in the package (i.e., can build it). -/
def isBuildableModule (mod : Name) (self : Package) : Bool :=
self.leanLibConfigs.any (fun _ lib => lib.isBuildableModule mod) ||
self.leanExeConfigs.any (fun _ exe => exe.root == mod)
/-- Remove the package's build outputs (i.e., delete its build directory). -/
def clean (self : Package) : IO PUnit := do
if (← self.buildDir.pathExists) then
IO.FS.removeDirAll self.buildDir

View file

@ -0,0 +1,34 @@
/-
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.Util.Exit
import Lake.Config.Context
namespace Lake
/--
The type of a `Script`'s monad.
`IO` equipped information about the Lake configuration.
-/
abbrev ScriptM := LakeT IO
/--
The type of a `Script`'s function.
Similar to the `main` function's signature, except that its monad is
also equipped with information about the Lake configuration.
-/
abbrev ScriptFn := (args : List String) → ScriptM ExitCode
/--
A package `Script` is a `ScriptFn` definition that is
indexed by a `String` key and can be be run by `lake run <key> [-- <args>]`.
-/
structure Script where
fn : ScriptFn
doc? : Option String
deriving Inhabited
def Script.run (args : List String) (self : Script) : ScriptM ExitCode :=
self.fn args

View file

@ -0,0 +1,36 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Build.Info
import Lake.Build.Store
namespace Lake
/-- A custom target's declarative configuration. -/
structure TargetConfig (pkgName name : Name) : Type where
/-- The target's build function. -/
build : (pkg : NPackage pkgName) → IndexBuildM (CustomData (pkgName, name))
/-- The target's resulting build job. -/
getJob : CustomData (pkgName, name) → BuildJob Unit
deriving Inhabited
/-- A smart constructor for target configurations that generate CLI targets. -/
@[inline] def mkTargetJobConfig
(build : (pkg : NPackage pkgName) → IndexBuildM (BuildJob α))
[h : FamilyOut CustomData (pkgName, name) (BuildJob α)] : TargetConfig pkgName name where
build := cast (by rw [← h.family_key_eq_type]) build
getJob := fun data => discard <| ofFamily data
/-- A dependently typed configuration based on its registered package and name. -/
structure TargetDecl where
pkg : Name
name : Name
config : TargetConfig pkg name
hydrate_opaque_type OpaqueTargetConfig TargetConfig pkgName name
/-- Try to find a target configuration in the package with the given name . -/
def Package.findTargetConfig? (name : Name) (self : Package) : Option (TargetConfig self.name name) :=
self.opaqueTargetConfigs.find? name |>.map (·.get)

View file

@ -0,0 +1,184 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Util.Paths
import Lake.Config.FacetConfig
import Lake.Config.TargetConfig
import Lake.Config.Env
import Lake.Util.Log
open System
namespace Lake
/-- A Lake workspace -- the top-level package directory. -/
structure Workspace : Type where
/-- The root package of the workspace. -/
root : Package
/-- The detect `Lake.Env` of the workspace. -/
lakeEnv : Lake.Env
/-- Name-package map of packages within the workspace. -/
packageMap : DNameMap NPackage := {}
/-- Name-configuration map of module facets defined in the workspace. -/
moduleFacetConfigs : DNameMap ModuleFacetConfig
/-- Name-configuration map of package facets defined in the workspace. -/
packageFacetConfigs : DNameMap PackageFacetConfig
/-- Name-configuration map of library facets defined in the workspace. -/
libraryFacetConfigs : DNameMap LibraryFacetConfig
instance : Nonempty Workspace :=
have : Inhabited Package := Classical.inhabited_of_nonempty inferInstance
by refine' ⟨{..}⟩ <;> exact default
hydrate_opaque_type OpaqueWorkspace Workspace
namespace Workspace
/-- The path to the workspace's directory (i.e., the directory of the root package). -/
@[inline] def dir (self : Workspace) : FilePath :=
self.root.dir
/-- The workspace's configuration. -/
@[inline] def config (self : Workspace) : WorkspaceConfig :=
self.root.config.toWorkspaceConfig
/-- The workspace's remote packages directory. -/
@[inline] def relPkgsDir (self : Workspace) : FilePath :=
self.root.relPkgsDir
/-- The workspace's `dir` joined with its `relPkgsDir`. -/
@[inline] def pkgsDir (self : Workspace) : FilePath :=
self.root.pkgsDir
/-- The workspace's Lake manifest. -/
@[inline] def manifestFile (self : Workspace) : FilePath :=
self.root.manifestFile
/-- The `List` of packages to the workspace. -/
def packageList (self : Workspace) : List Package :=
self.packageMap.revFold (fun pkgs _ pkg => pkg.toPackage :: pkgs) []
/-- The `Array` of packages to the workspace. -/
def packageArray (self : Workspace) : Array Package :=
self.packageMap.fold (fun pkgs _ pkg => pkgs.push pkg.toPackage) #[]
/-- Add a package to the workspace. -/
def addPackage (pkg : Package) (self : Workspace) : Workspace :=
{self with packageMap := self.packageMap.insert pkg.name pkg}
/-- Try to find a package within the workspace with the given name. -/
@[inline] def findPackage? (name : Name) (self : Workspace) : Option (NPackage name) :=
self.packageMap.find? name
/-- Check if the module is local to any package in the workspace. -/
def isLocalModule (mod : Name) (self : Workspace) : Bool :=
self.packageMap.any fun _ pkg => pkg.isLocalModule mod
/-- Check if the module is buildable by any package in the workspace. -/
def isBuildableModule (mod : Name) (self : Workspace) : Bool :=
self.packageMap.any fun _ pkg => pkg.isBuildableModule mod
/-- Locate the named module in the workspace (if it is local to it). -/
def findModule? (mod : Name) (self : Workspace) : Option Module :=
self.packageArray.findSome? (·.findModule? mod)
/-- Try to find a Lean library in the workspace with the given name. -/
def findLeanLib? (name : Name) (self : Workspace) : Option LeanLib :=
self.packageArray.findSome? fun pkg => pkg.findLeanLib? name
/-- Try to find a Lean executable in the workspace with the given name. -/
def findLeanExe? (name : Name) (self : Workspace) : Option LeanExe :=
self.packageArray.findSome? fun pkg => pkg.findLeanExe? name
/-- Try to find an external library in the workspace with the given name. -/
def findExternLib? (name : Name) (self : Workspace) : Option ExternLib :=
self.packageArray.findSome? fun pkg => pkg.findExternLib? name
/-- Try to find a target configuration in the workspace with the given name. -/
def findTargetConfig? (name : Name) (self : Workspace) : Option ((pkg : Package) × TargetConfig pkg.name name) :=
self.packageArray.findSome? fun pkg => pkg.findTargetConfig? name <&> (⟨pkg, ·⟩)
/-- Add a module facet to the workspace. -/
def addModuleFacetConfig (cfg : ModuleFacetConfig name) (self : Workspace) : Workspace :=
{self with moduleFacetConfigs := self.moduleFacetConfigs.insert name cfg}
/-- Try to find a module facet configuration in the workspace with the given name. -/
@[inline] def findModuleFacetConfig? (name : Name) (self : Workspace) : Option (ModuleFacetConfig name) :=
self.moduleFacetConfigs.find? name
/-- Add a package facet to the workspace. -/
def addPackageFacetConfig (cfg : PackageFacetConfig name) (self : Workspace) : Workspace :=
{self with packageFacetConfigs := self.packageFacetConfigs.insert name cfg}
/-- Try to find a package facet configuration in the workspace with the given name. -/
@[inline] def findPackageFacetConfig? (name : Name) (self : Workspace) : Option (PackageFacetConfig name) :=
self.packageFacetConfigs.find? name
/-- Add a library facet to the workspace. -/
def addLibraryFacetConfig (cfg : LibraryFacetConfig name) (self : Workspace) : Workspace :=
{self with libraryFacetConfigs := self.libraryFacetConfigs.insert cfg.name cfg}
/-- Try to find a library facet configuration in the workspace with the given name. -/
@[inline] def findLibraryFacetConfig? (name : Name) (self : Workspace) : Option (LibraryFacetConfig name) :=
self.libraryFacetConfigs.find? name
/-- The workspace's binary Lean library paths (which are added to `LEAN_PATH`). -/
def leanPath (self : Workspace) : SearchPath :=
self.packageList.map (·.leanLibDir)
/-- The workspace's source directories (which are added to `LEAN_SRC_PATH`). -/
def leanSrcPath (self : Workspace) : SearchPath :=
self.packageList.map (·.srcDir)
/--
The workspace's shared library path (e.g., for `--load-dynlib`).
This is added to the `sharedLibPathEnvVar` by `lake env`.
-/
def sharedLibPath (self : Workspace) : SearchPath :=
self.packageList.map (·.nativeLibDir)
/--
The detected `LEAN_PATH` of the environment
augmented with the workspace's `leanPath` and Lake's `libDir`.
We include Lake's `oleanDir` at the end to ensure that same Lake package being
used to build is available to the environment (and thus, e.g., the Lean server).
Otherwise, it may fall back on whatever the default Lake instance is.
-/
def augmentedLeanPath (self : Workspace) : SearchPath :=
self.lakeEnv.leanPath ++ self.leanPath ++ [self.lakeEnv.lake.libDir]
/--
The detected `LEAN_SRC_PATH` of the environment
augmented with the workspace's `leanSrcPath` and Lake's `srcDir`.
We include Lake's `srcDir` at the end to ensure that same Lake package being
used to build is available to the environment (and thus, e.g., the Lean server).
Otherwise, it may fall back on whatever the default Lake instance is.
-/
def augmentedLeanSrcPath (self : Workspace) : SearchPath :=
self.lakeEnv.leanSrcPath ++ self.leanSrcPath ++ [self.lakeEnv.lake.srcDir]
/-
The detected `sharedLibPathEnv` value of the environment
augmented with the workspace's `libPath`.
-/
def augmentedSharedLibPath (self : Workspace) : SearchPath :=
self.lakeEnv.sharedLibPath ++ self.sharedLibPath
/--
The detected environment augmented with the Workspace's paths.
These are the settings use by `lake env` / `Lake.env` to run executables.
-/
def augmentedEnvVars (self : Workspace) : Array (String × Option String) :=
self.lakeEnv.installVars ++ #[
("LEAN_PATH", some self.augmentedLeanPath.toString),
("LEAN_SRC_PATH", some self.augmentedLeanSrcPath.toString),
(sharedLibPathEnvVar, some self.augmentedSharedLibPath.toString)
]
/-- Remove all packages' build outputs (i.e., delete their build directories). -/
def clean (self : Workspace) : IO Unit := do
self.packageMap.forM fun _ pkg => pkg.clean

View file

@ -0,0 +1,20 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
open System
namespace Lake
/-- The default setting for a `WorkspaceConfig`'s `packagesDir` option. -/
def defaultPackagesDir : FilePath := "lake-packages"
/-- A `Workspace`'s declarative configuration. -/
structure WorkspaceConfig where
/--
The directory to which Lake should download remote dependencies.
Defaults to `defaultPackagesDir` (i.e., `lake-packages`).
-/
packagesDir : Option FilePath := none
deriving Inhabited, Repr

15
src/lake/Lake/DSL.lean Normal file
View file

@ -0,0 +1,15 @@
/-
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.DSL.DeclUtil
import Lake.DSL.Attributes
import Lake.DSL.Extensions
import Lake.DSL.Config
import Lake.DSL.Package
import Lake.DSL.Script
import Lake.DSL.Require
import Lake.DSL.Targets
import Lake.DSL.Facets
import Lake.DSL.Meta

View file

@ -0,0 +1,56 @@
/-
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.Util.OrderedTagAttribute
open Lean
namespace Lake
initialize packageAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `package "mark a definition as a Lake package configuration"
initialize packageDepAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `package_dep "mark a definition as a Lake package dependency"
initialize scriptAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `script "mark a definition as a Lake script"
initialize defaultScriptAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `default_script "mark a Lake script as the package's default"
fun name => do
unless (← getEnv <&> (scriptAttr.hasTag · name)) do
throwError "attribute `default_script` can only be used on a `script`"
initialize leanLibAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `lean_lib "mark a definition as a Lake Lean library target configuration"
initialize leanExeAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `lean_exe "mark a definition as a Lake Lean executable target configuration"
initialize externLibAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `extern_lib "mark a definition as a Lake external library target"
initialize targetAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `target "mark a definition as a custom Lake target"
initialize defaultTargetAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `default_target "mark a Lake target as the package's default"
fun name => do
let valid ← getEnv <&> fun env =>
leanLibAttr.hasTag env name ||
leanExeAttr.hasTag env name ||
externLibAttr.hasTag env name ||
targetAttr.hasTag env name
unless valid do
throwError "attribute `default_target` can only be used on a target (e.g., `lean_lib`, `lean_exe`)"
initialize moduleFacetAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `module_facet "mark a definition as a Lake module facet"
initialize packageFacetAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `package_facet "mark a definition as a Lake package facet"
initialize libraryFacetAttr : OrderedTagAttribute ←
registerOrderedTagAttribute `library_facet "mark a definition as a Lake library facet"

View file

@ -0,0 +1,65 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Elab.ElabRules
import Lake.DSL.Extensions
namespace Lake.DSL
open Lean Elab Term
/--
A dummy default constant for `__dir__` to make it type check
outside Lakefile elaboration (e.g., when editing).
-/
opaque dummyDir : System.FilePath
/--
A dummy default constant for `get_config` to make it type check
outside Lakefile elaboration (e.g., when editing).
-/
opaque dummyGetConfig? : Name → Option String
/--
A macro that expands to the path of package's directory
during the Lakefile's elaboration.
-/
scoped syntax (name := dirConst) "__dir__" : term
@[term_elab dirConst]
def elabDirConst : TermElab := fun stx expectedType? => do
let exp :=
if let some dir := dirExt.getState (← getEnv) then
let str := Syntax.mkStrLit dir.toString (SourceInfo.fromRef stx)
Syntax.mkApp (mkCIdentFrom stx ``System.FilePath.mk) #[str]
else
-- `id` app forces Lean to show macro's doc rather than the constant's
Syntax.mkApp (mkCIdentFrom stx ``id) #[mkCIdentFrom stx ``dummyDir]
withMacroExpansion stx exp <| elabTerm exp expectedType?
/--
A macro that expands to the specified configuration option (or `none`,
if not the option has not been set) during the Lakefile's elaboration.
Configuration arguments are set either via the Lake CLI (by the `-K` option)
or via the `with` clause in a `require` statement.
-/
scoped syntax (name := getConfig) "get_config? " ident :term
@[term_elab getConfig]
def elabGetConfig : TermElab := fun stx expectedType? => do
tryPostponeIfNoneOrMVar expectedType?
match stx with
| `(getConfig| get_config? $key) => do
let exp : Term ← show TermElabM Term from do
if let some opts := optsExt.getState (← getEnv) then
if let some val := opts.find? key.getId then
`(some $(Syntax.mkStrLit val <| SourceInfo.fromRef (← getRef)))
else
-- Make sure `none` is properly typed
`((none : Option String))
else
return Syntax.mkApp (mkCIdentFrom stx ``dummyGetConfig?) #[quote key.getId]
withMacroExpansion stx exp <| elabTerm exp expectedType?
| _ => throwUnsupportedSyntax

View file

@ -0,0 +1,86 @@
/-
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.Util.Binder
import Lean.Parser.Command
namespace Lake.DSL
open Lean Parser Command
abbrev DocComment := TSyntax ``docComment
abbrev Attributes := TSyntax ``Term.attributes
abbrev AttrInstance := TSyntax ``Term.attrInstance
abbrev WhereDecls := TSyntax ``Term.whereDecls
---
def expandAttrs (attrs? : Option Attributes) : Array AttrInstance :=
if let some attrs := attrs? then
match attrs with
| `(Term.attributes| @[$attrs,*]) => attrs
| _ => #[]
else
#[]
syntax structVal :=
"{" manyIndent(group(Term.structInstField ", "?)) "}"
syntax declValDo :=
ppSpace Term.do (Term.whereDecls)?
syntax declValStruct :=
ppSpace structVal (Term.whereDecls)?
syntax declValTyped :=
Term.typeSpec declValSimple
syntax declValOptTyped :=
(Term.typeSpec)? declValSimple
syntax simpleDeclSig :=
ident Term.typeSpec declValSimple
syntax structDeclSig :=
ident (Command.whereStructInst <|> declValOptTyped <|> declValStruct)?
syntax bracketedSimpleBinder :=
"(" ident (" : " term)? ")"
syntax simpleBinder :=
ident <|> bracketedSimpleBinder
abbrev SimpleBinder := TSyntax ``simpleBinder
open Lean.Parser.Term in
def expandOptSimpleBinder (stx? : Option SimpleBinder) : MacroM FunBinder := do
match stx? with
| some stx =>
match stx with
| `(simpleBinder| $id:ident) =>
`(funBinder| $id)
| `(simpleBinder| ($id $[: $ty?]?)) =>
let ty := ty?.getD (← `(_))
`(funBinder| ($id : $ty))
| _ => `(funBinder| _)
| none => `(funBinder| _)
def fixName (id : Ident) : Option Name → Ident
| some n => mkIdentFrom id n
| none => id
def mkConfigStructDecl (name? : Option Name)
(doc? : Option DocComment) (attrs : Array AttrInstance) (ty : Term)
: (spec : Syntax) → MacroM Syntax.Command
| `(structDeclSig| $id:ident) =>
`($[$doc?]? @[$attrs,*] abbrev $(fixName id name?) : $ty :=
{name := $(quote id.getId)})
| `(structDeclSig| $id:ident where $ds;* $[$wds?]?) =>
`($[$doc?]? @[$attrs,*] abbrev $(fixName id name?) : $ty where
name := $(quote id.getId); $ds;* $[$wds?]?)
| `(structDeclSig| $id:ident $[: $ty?]? := $defn $[$wds?]?) =>
`($[$doc?]? @[$attrs,*] abbrev $(fixName id name?) : $(ty?.getD ty) := $defn $[$wds?]?)
| `(structDeclSig| $id:ident { $[$fs $[,]?]* } $[$wds?]?) => do
let defn ← `({ name := $(quote id.getId), $fs,* })
`($[$doc?]? @[$attrs,*] abbrev $(fixName id name?) : $ty := $defn $[$wds?]?)
| stx => Macro.throwErrorAt stx "ill-formed configuration syntax"

View file

@ -0,0 +1,17 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Environment
import Lake.Config.Dependency
open Lean
namespace Lake
initialize dirExt : EnvExtension (Option System.FilePath) ←
registerEnvExtension (pure none)
initialize optsExt : EnvExtension (Option (NameMap String)) ←
registerEnvExtension (pure none)

View file

@ -0,0 +1,173 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.DSL.DeclUtil
import Lake.Config.FacetConfig
import Lake.Config.TargetConfig
import Lake.Build.Index
/-!
Macros for declaring custom facets and targets.
-/
namespace Lake.DSL
open Lean Parser Command
syntax buildDeclSig :=
ident (ppSpace simpleBinder)? Term.typeSpec declValSimple
/--
Define a new module facet. Has one form:
```lean
module_facet «facet-name» (mod : Module) : α :=
/- build function term -/
```
The `mod` parameter (and its type specifier) is optional.
The term should be of type `IndexBuildM (BuildJob α)`.
-/
scoped macro (name := moduleFacetDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
kw:"module_facet " sig:buildDeclSig : command => do
match sig with
| `(buildDeclSig| $id:ident $[$mod?]? : $ty := $defn $[$wds?]?) =>
let attr ← withRef kw `(Term.attrInstance| module_facet)
let attrs := #[attr] ++ expandAttrs attrs?
let name := Name.quoteFrom id id.getId
let facetId := mkIdentFrom id <| id.getId.modifyBase (.str · "_modFacet")
let mod ← expandOptSimpleBinder mod?
`(module_data $id : BuildJob $ty
$[$doc?:docComment]? @[$attrs,*] abbrev $facetId : ModuleFacetDecl := {
name := $name
config := Lake.mkFacetJobConfig
fun $mod => ($defn : IndexBuildM (BuildJob $ty))
} $[$wds?]?)
| stx => Macro.throwErrorAt stx "ill-formed module facet declaration"
/--
Define a new package facet. Has one form:
```lean
package_facet «facet-name» (pkg : Package) : α :=
/- build function term -/
```
The `pkg` parameter (and its type specifier) is optional.
The term should be of type `IndexBuildM (BuildJob α)`.
-/
scoped macro (name := packageFacetDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
kw:"package_facet " sig:buildDeclSig : command => do
match sig with
| `(buildDeclSig| $id:ident $[$pkg?]? : $ty := $defn $[$wds?]?) =>
let attr ← withRef kw `(Term.attrInstance| package_facet)
let attrs := #[attr] ++ expandAttrs attrs?
let name := Name.quoteFrom id id.getId
let facetId := mkIdentFrom id <| id.getId.modifyBase (.str · "_pkgFacet")
let pkg ← expandOptSimpleBinder pkg?
`(package_data $id : BuildJob $ty
$[$doc?]? @[$attrs,*] abbrev $facetId : PackageFacetDecl := {
name := $name
config := Lake.mkFacetJobConfig
fun $pkg => ($defn : IndexBuildM (BuildJob $ty))
} $[$wds?]?)
| stx => Macro.throwErrorAt stx "ill-formed package facet declaration"
/--
Define a new library facet. Has one form:
```lean
library_facet «facet-name» (lib : LeanLib) : α :=
/- build function term -/
```
The `lib` parameter (and its type specifier) is optional.
The term should be of type `IndexBuildM (BuildJob α)`.
-/
scoped macro (name := libraryFacetDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
kw:"library_facet " sig:buildDeclSig : command => do
match sig with
| `(buildDeclSig| $id:ident $[$lib?]? : $ty := $defn $[$wds?]?) =>
let attr ← withRef kw `(Term.attrInstance| library_facet)
let attrs := #[attr] ++ expandAttrs attrs?
let name := Name.quoteFrom id id.getId
let facetId := mkIdentFrom id <| id.getId.modifyBase (.str · "_libFacet")
let lib ← expandOptSimpleBinder lib?
`(library_data $id : BuildJob $ty
$[$doc?]? @[$attrs,*] abbrev $facetId : LibraryFacetDecl := {
name := $name
config := Lake.mkFacetJobConfig
fun $lib => ($defn : IndexBuildM (BuildJob $ty))
} $[$wds?]?)
| stx => Macro.throwErrorAt stx "ill-formed library facet declaration"
/--
Define a new custom target for the package. Has one form:
```lean
target «target-name» (pkg : Package) : α :=
/- build function term -/
```
The `pkg` parameter (and its type specifier) is optional.
The term should be of type `IndexBuildM (BuildJob α)`.
-/
scoped macro (name := targetDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
kw:"target " sig:buildDeclSig : command => do
match sig with
| `(buildDeclSig| $id:ident $[$pkg?]? : $ty := $defn $[$wds?]?) =>
let attr ← withRef kw `(Term.attrInstance| target)
let attrs := #[attr] ++ expandAttrs attrs?
let name := Name.quoteFrom id id.getId
let pkgName := mkIdentFrom id `_package.name
let pkg ← expandOptSimpleBinder pkg?
`(family_def $id : CustomData ($pkgName, $name) := BuildJob $ty
$[$doc?]? @[$attrs,*] abbrev $id : TargetDecl := {
pkg := $pkgName
name := $name
config := Lake.mkTargetJobConfig
fun $pkg => ($defn : IndexBuildM (BuildJob $ty))
} $[$wds?]?)
| stx => Macro.throwErrorAt stx "ill-formed target declaration"
--------------------------------------------------------------------------------
/-! # External Library Target -/
--------------------------------------------------------------------------------
syntax externLibDeclSpec :=
ident (ppSpace simpleBinder)? declValSimple
/--
Define a new external library target for the package. Has one form:
```lean
extern_lib «target-name» (pkg : Package) :=
/- build function term -/
```
The `pkg` parameter (and its type specifier) is optional.
The term should be of type `IndexBuildM (BuildJob FilePath)` and
build the external library's **static** library.
-/
scoped macro (name := externLibDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
"extern_lib " spec:externLibDeclSpec : command => do
match spec with
| `(externLibDeclSpec| $id:ident $[$pkg?]? := $defn $[$wds?]?) =>
let attr ← `(Term.attrInstance| extern_lib)
let attrs := #[attr] ++ expandAttrs attrs?
let pkgName := mkIdentFrom id `_package.name
let targetId := mkIdentFrom id <| id.getId.modifyBase (· ++ `static)
let name := Name.quoteFrom id id.getId
`(target $targetId $[$pkg?]? : FilePath := $defn $[$wds?]?
$[$doc?:docComment]? @[$attrs,*] def $id : ExternLibDecl := {
pkg := $pkgName
name := $name
config := {getJob := ofFamily}
})
| stx => Macro.throwErrorAt stx "ill-formed external library declaration"

View file

@ -0,0 +1,61 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.EvalTerm
import Lean.Elab.ElabRules
/-!
Syntax for elaboration time control flow.
-/
namespace Lake.DSL
open Lean Elab Command
/--
The `do` command syntax groups multiple similarly indented commands together.
The group can then be passed to another command that usually only accepts a
single command (e.g., `meta if`).
-/
syntax cmdDo := ("do" many1Indent(command)) <|> command
def expandCmdDo : TSyntax ``cmdDo → Array Command
| `(cmdDo|do $cmds*) => cmds
| `(cmdDo|$cmd:command) => #[cmd]
| _ => #[]
/--
The `meta if` command has two forms:
```lean
meta if <c:term> then <a:command>
meta if <c:term> then <a:command> else <b:command>
```
It expands to the command `a` if the term `c` evaluates to true
(at elaboration time). Otherwise, it expands to command `b` (if an `else`
clause is provided).
One can use this command to specify, for example, external library targets
only available on specific platforms:
```lean
meta if System.Platform.isWindows then
extern_lib winOnlyLib := ...
else meta if System.Platform.isOSX then
extern_lib macOnlyLib := ...
else
extern_lib linuxOnlyLib := ...
```
-/
scoped syntax (name := metaIf)
"meta " "if " term " then " cmdDo (" else " cmdDo)? : command
elab_rules : command | `(meta if $c then $t $[else $e?]?) => do
if (← withRef c <| runTermElabM fun _ => evalTerm Bool c) then
let cmd := mkNullNode (expandCmdDo t)
withMacroExpansion (← getRef) cmd <| elabCommand cmd
else if let some e := e? then
let cmd := mkNullNode (expandCmdDo e)
withMacroExpansion (← getRef) cmd <| elabCommand cmd

View file

@ -0,0 +1,35 @@
/-
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.Package
import Lake.DSL.Attributes
import Lake.DSL.DeclUtil
namespace Lake.DSL
open Lean Parser Command
/-- The name given to the definition created by the `package` syntax. -/
def packageDeclName := `_package
/--
Defines the configuration of a Lake package. Has many forms:
```lean
package «pkg-name»
package «pkg-name» { /- config opts -/ }
package «pkg-name» where /- config opts -/
package «pkg-name» : PackageConfig := /- config -/
```
There can only be one `package` declaration per Lake configuration file.
The defined package configuration will be available for reference as `_package`.
-/
scoped macro (name := packageDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
"package " sig:structDeclSig : command => do
let attr ← `(Term.attrInstance| «package»)
let ty := mkCIdentFrom (← getRef) ``PackageConfig
let attrs := #[attr] ++ expandAttrs attrs?
mkConfigStructDecl packageDeclName doc? attrs ty sig

View file

@ -0,0 +1,57 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Parser.Command
import Lake.DSL.Extensions
namespace Lake.DSL
open Lean Parser Command
syntax fromPath :=
term
syntax fromGit :=
&" git " term:max ("@" term:max)? ("/" term)?
syntax depSpec :=
ident " from " (fromGit <|> fromPath) (" with " term)?
def expandDepSpec : TSyntax ``depSpec → MacroM Command
| `(depSpec| $name:ident from git $url $[@ $rev?]? $[/ $path?]? $[with $opts?]?) => do
let rev ← match rev? with | some rev => `(some $rev) | none => `(none)
let path ← match path? with | some path => `(some $path) | none => `(none)
let opts := opts?.getD <| ← `({})
`(@[package_dep] def $name : Dependency := {
name := $(quote name.getId),
src := Source.git $url $rev $path,
options := $opts
})
| `(depSpec| $name:ident from $path:term $[with $opts?]?) => do
let opts := opts?.getD <| ← `({})
`(@[package_dep] def $name : Dependency := {
name := $(quote name.getId),
src := Source.path $path,
options := $opts
})
| _ => Macro.throwUnsupported
/--
Adds a mew package dependency to the workspace. Has two forms:
```lean
require foo from "path"/"to"/"local"/"package" with NameMap.empty
require bar from git "url.git"@"rev"/"optional"/"path-to"/"dir-with-pkg"
```
Either form supports the optional `with` clause.
The `@"rev"` and `/"path"/"dir"` parts of the git form of `require`
are optional.
The elements of both the `from` and `with` clauses are proper terms so
normal computation is supported within them (though parentheses made be
required to disambiguate the syntax).
-/
scoped macro (name := requireDecl) "require " spec:depSpec : command =>
expandDepSpec spec

View file

@ -0,0 +1,35 @@
/-
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.Package
import Lake.DSL.Attributes
import Lake.DSL.DeclUtil
namespace Lake.DSL
open Lean Parser Command
syntax scriptDeclSpec :=
ident (ppSpace simpleBinder)? (declValSimple <|> declValDo)
/--
Define a new Lake script for the package. Has two forms:
```lean
script «script-name» (args) do /- ... -/
script «script-name» (args) := ...
```
-/
scoped syntax (name := scriptDecl)
(docComment)? optional(Term.attributes) "script " scriptDeclSpec : command
@[macro scriptDecl]
def expandScriptDecl : Macro
| `($[$doc?]? $[$attrs?]? script $id:ident $[$args?]? do $seq $[$wds?]?) => do
`($[$doc?]? $[$attrs?]? script $id:ident $[$args?]? := do $seq $[$wds?]?)
| `($[$doc?]? $[$attrs?]? script $id:ident $[$args?]? := $defn $[$wds?]?) => do
let args ← expandOptSimpleBinder args?
let attrs := #[← `(Term.attrInstance| «script»)] ++ expandAttrs attrs?
`($[$doc?]? @[$attrs,*] def $id : ScriptFn := fun $args => $defn $[$wds?]?)
| stx => Macro.throwErrorAt stx "ill-formed script declaration"

View file

@ -0,0 +1,57 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.DSL.DeclUtil
import Lake.DSL.Attributes
import Lake.Config.LeanExeConfig
import Lake.Config.LeanLibConfig
import Lake.Config.ExternLibConfig
namespace Lake.DSL
open Lean Parser Command
--------------------------------------------------------------------------------
/-! # Lean Library & Executable Targets -/
--------------------------------------------------------------------------------
/--
Define a new Lean library target for the package.
Can optionally be provided with a configuration of type `LeanLibConfig`.
Has many forms:
```lean
lean_lib «target-name»
lean_lib «target-name» { /- config opts -/ }
lean_lib «target-name» where /- config opts -/
lean_lib «target-name» := /- config -/
```
-/
scoped macro (name := leanLibDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
"lean_lib " sig:structDeclSig : command => do
let attr ← `(Term.attrInstance| lean_lib)
let ty := mkCIdentFrom (← getRef) ``LeanLibConfig
let attrs := #[attr] ++ expandAttrs attrs?
mkConfigStructDecl none doc? attrs ty sig
/--
Define a new Lean binary executable target for the package.
Can optionally be provided with a configuration of type `LeanExeConfig`.
Has many forms:
```lean
lean_exe «target-name»
lean_exe «target-name» { /- config opts -/ }
lean_exe «target-name» where /- config opts -/
lean_exe «target-name» := /- config -/
```
-/
scoped macro (name := leanExeDecl)
doc?:optional(docComment) attrs?:optional(Term.attributes)
"lean_exe " sig:structDeclSig : command => do
let attr ← `(Term.attrInstance| lean_exe)
let ty := mkCIdentFrom (← getRef) ``LeanExeConfig
let attrs := #[attr] ++ expandAttrs attrs?
mkConfigStructDecl none doc? attrs ty sig

6
src/lake/Lake/Load.lean Normal file
View file

@ -0,0 +1,6 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Load.Main

View file

@ -0,0 +1,28 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Data.Name
import Lean.Data.Options
import Lake.Config.Env
import Lake.Util.Log
namespace Lake
open System Lean
/-- The default name of the Lake configuration file (i.e., `lakefile.lean`). -/
def defaultConfigFile : FilePath := "lakefile.lean"
/-- Context for loading a Lake configuration. -/
structure LoadConfig where
/-- The Lake environment of the load process. -/
env : Lake.Env
/-- The root directory of the loaded package (and its workspace). -/
rootDir : FilePath
/-- The Lean file with the package's Lake configuration (e.g., `lakefile.lean`) -/
configFile : FilePath := rootDir / defaultConfigFile
/-- A set of key-value Lake configuration options (i.e., `-K` settings). -/
configOpts : NameMap String := {}
/-- The Lean options with which to elaborate the configuration file. -/
leanOpts : Options := {}

View file

@ -0,0 +1,67 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Elab.Frontend
import Lake.DSL.Extensions
import Lake.Load.Config
import Lake.Util.Log
namespace Lake
open Lean System
deriving instance BEq, Hashable for Import
/- Cache for the imported header environment of Lake configuration files. -/
initialize importEnvCache : IO.Ref (HashMap (List Import) Environment) ← IO.mkRef {}
/-- Like `Lean.Elab.processHeader`, but using `importEnvCache`. -/
def processHeader (header : Syntax) (opts : Options) (trustLevel : UInt32)
(inputCtx : Parser.InputContext) : StateT MessageLog IO Environment := do
try
let imports := Elab.headerToImports header
if let some env := (← importEnvCache.get).find? imports then
return env
let env ← importModules imports opts trustLevel
importEnvCache.modify (·.insert imports env)
return env
catch e =>
let pos := inputCtx.fileMap.toPosition <| header.getPos?.getD 0
modify (·.add { fileName := inputCtx.fileName, data := toString e, pos })
mkEmptyEnvironment
/-- Main module `Name` of a Lake configuration file. -/
def configModuleName : Name := `lakefile
/-- Elaborate `configFile` with the given package directory and options. -/
def elabConfigFile (pkgDir : FilePath) (configOpts : NameMap String)
(leanOpts := Options.empty) (configFile := pkgDir / defaultConfigFile) : LogIO Environment := do
-- Read file and initialize environment
let input ← IO.FS.readFile configFile
let inputCtx := Parser.mkInputContext input configFile.toString
let (header, parserState, messages) ← Parser.parseHeader inputCtx
let (env, messages) ← processHeader header leanOpts 1024 inputCtx messages
let env := env.setMainModule configModuleName
-- Configure extensions
let env := dirExt.setState env pkgDir
let env := optsExt.setState env configOpts
-- Elaborate File
let commandState := Elab.Command.mkState env messages leanOpts
let s ← Elab.IO.processCommands inputCtx parserState commandState
-- Log messages
for msg in s.commandState.messages.toList do
match msg.severity with
| MessageSeverity.information => logInfo (← msg.toString)
| MessageSeverity.warning => logWarning (← msg.toString)
| MessageSeverity.error => logError (← msg.toString)
-- Check result
if s.commandState.messages.hasErrors then
error s!"{configFile}: package configuration has errors"
else
return s.commandState.env

View file

@ -0,0 +1,189 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone, Gabriel Ebner
-/
import Lake.Util.EStateT
import Lake.Util.StoreInsts
import Lake.Config.Workspace
import Lake.Build.Topological
import Lake.Build.Module
import Lake.Build.Package
import Lake.Build.Library
import Lake.Load.Materialize
import Lake.Load.Package
import Lake.Load.Elab
open System Lean
namespace Lake
/-- Load the tagged `Dependency` definitions from a package configuration environment. -/
def loadDepsFromEnv (env : Environment) (opts : Options) : Except String (Array Dependency) := do
(packageDepAttr.ext.getState env).mapM (evalConstCheck env opts Dependency ``Dependency)
def loadDepPackage (parentPkg : Package) (result : MaterializeResult)
(dep : Dependency) : LogIO Package := do
let dir := result.pkgDir
let configEnv ← elabConfigFile dir dep.options parentPkg.leanOpts (dir / defaultConfigFile)
let config ← IO.ofExcept <| PackageConfig.loadFromEnv configEnv parentPkg.leanOpts
return {
dir, config, configEnv
remoteUrl? := result.remoteUrl?
gitTag? := result.gitTag?
leanOpts := parentPkg.leanOpts
}
def buildUpdatedManifest (ws : Workspace) : LogIO Manifest := do
let res ← StateT.run (s := mkNameMap MaterializeResult) do
EStateT.run' (mkNameMap Package) do
buildAcyclic (·.name) ws.root fun pkg resolve => do
let topLevel := pkg.name = ws.root.name
let relPkgDir :=
if let some {relPkgDir, ..} := ((← getThe (NameMap MaterializeResult)).find? pkg.name) then
relPkgDir
else
"." -- topLevel
unless topLevel do
for entry in (← Manifest.loadOrEmpty pkg.manifestFile) do
unless (← getThe (NameMap MaterializeResult)).contains entry.name do
let entry := entry.inDirectory relPkgDir
let result ← materializePackageEntry ws.dir ws.relPkgsDir entry
modifyThe (NameMap MaterializeResult) (·.insert entry.name result)
let deps ← IO.ofExcept <| loadDepsFromEnv pkg.configEnv pkg.leanOpts
let deps ← deps.mapM fun dep => do
if let some result := (← getThe (NameMap MaterializeResult)).find? dep.name then
return (dep, result)
else
let depName := dep.name.toString (escape := false)
let entry ← updateSource relPkgDir ws.relPkgsDir depName dep.src
let result ← materializePackageEntry ws.dir ws.relPkgsDir entry
modifyThe (NameMap MaterializeResult) (·.insert entry.name result)
return (dep, result)
let depPkgs ← deps.mapM fun (dep, result) => do
if let .some pkg := (← getThe (NameMap Package)).find? dep.name then
return pkg
else
let pkg ← loadDepPackage pkg result dep
modifyThe (NameMap Package) (·.insert dep.name pkg)
return pkg
return {pkg with opaqueDeps := ← depPkgs.mapM (.mk <$> resolve ·)}
match res with
| (.ok _, results) =>
let mut manifest : Manifest := {packagesDir? := ws.relPkgsDir}
for (_, result) in results do
manifest := manifest.insert result.manifestEntry
return manifest
| (.error cycle, _) =>
let cycle := cycle.map (s!" {·}")
error s!"dependency cycle detected:\n{"\n".intercalate cycle}"
/--
Load a `Workspace` for a Lake package by elaborating its configuration file.
Does not resolve dependencies.
-/
def loadWorkspaceRoot (config : LoadConfig) : LogIO Workspace := do
Lean.searchPathRef.set config.env.leanSearchPath
let configEnv ← elabConfigFile config.rootDir config.configOpts config.leanOpts config.configFile
let pkgConfig ← IO.ofExcept <| PackageConfig.loadFromEnv configEnv config.leanOpts
let repo := GitRepo.mk config.rootDir
let root := {
configEnv, leanOpts := config.leanOpts
dir := config.rootDir, config := pkgConfig
remoteUrl? := ← repo.getFilteredRemoteUrl?
gitTag? := ← repo.findTag?
}
return {
root, lakeEnv := config.env
moduleFacetConfigs := initModuleFacetConfigs
packageFacetConfigs := initPackageFacetConfigs
libraryFacetConfigs := initLibraryFacetConfigs
}
/--
Finalize the workspace's root and its transitive dependencies
and add them to the workspace.
-/
def Workspace.finalize (ws : Workspace) : LogIO Workspace := do
have : MonadStore Name Package (StateT Workspace LogIO) := {
fetch? := fun name => return (← get).findPackage? name
store := fun _ pkg => modify (·.addPackage pkg)
}
let (res, ws) ← EStateT.run ws do
buildTop (·.name) ws.root fun pkg load => do
let depPkgs ← pkg.deps.mapM load
set <| ← IO.ofExcept <| (← get).addFacetsFromEnv pkg.configEnv pkg.leanOpts
let pkg ← pkg.finalize depPkgs
return pkg
match res with
| Except.ok root =>
return {ws with root}
| Except.error cycle => do
let cycle := cycle.map (s!" {·}")
error <|
s!"oops! dependency load cycle detected (this likely indicates a bug in Lake):\n" ++
"\n".intercalate cycle
/--
Resolving a workspace's dependencies using a manifest,
downloading and/or updating them as necessary.
-/
def Workspace.materializeDeps (ws : Workspace) (manifest : Manifest) : LogIO Workspace := do
if !manifest.isEmpty && manifest.packagesDir? != some ws.relPkgsDir then
logWarning <|
"manifest out of date: package directory changed, " ++
"use `lake update` to update"
let relPkgsDir := manifest.packagesDir?.getD ws.relPkgsDir
let res ← EStateT.run' (mkNameMap Package) do
buildAcyclic (·.name) ws.root fun pkg resolve => do
let topLevel := pkg.name = ws.root.name
let deps ← IO.ofExcept <| loadDepsFromEnv pkg.configEnv pkg.leanOpts
if topLevel then
for dep in deps do
let warnOutOfDate (what : String) :=
logWarning <|
s!"manifest out of date: {what} of dependency {dep.name} changed, " ++
"use `lake update` to update"
if let .some entry := manifest.find? dep.name then
match dep.src, entry with
| .git url rev _, .git _ url' _ rev' _ =>
if url ≠ url' then warnOutOfDate "git url"
if rev ≠ rev' then warnOutOfDate "git revision"
| .path .., .path .. => pure ()
| _, _ => warnOutOfDate "source kind (git/path)"
let depPkgs ← deps.mapM fun dep => do
fetchOrCreate dep.name do
let .some entry := manifest.find? dep.name
| error <| s!"dependency {dep.name} of {pkg.name} not in manifest, " ++
"use `lake update` to update"
let result ← materializePackageEntry ws.dir relPkgsDir entry
loadDepPackage pkg result dep
return { pkg with opaqueDeps := ← depPkgs.mapM (.mk <$> resolve ·) }
match res with
| Except.ok root =>
({ws with root}).finalize
| Except.error cycle =>
let cycle := cycle.map (s!" {·}")
error s!"dependency cycle detected:\n{"\n".intercalate cycle}"
/--
Load a `Workspace` for a Lake package by
elaborating its configuration file and resolving its dependencies.
If `updateDeps` is true, updates the manifest before resolving dependencies.
-/
def loadWorkspace (config : LoadConfig) (updateDeps := false) : LogIO Workspace := do
let ws ← loadWorkspaceRoot config
let manifest ← do
if updateDeps then
let manifest ← buildUpdatedManifest ws
manifest.saveToFile ws.manifestFile
pure manifest
else
Manifest.loadOrEmpty ws.manifestFile
ws.materializeDeps manifest
/-- Updates the manifest for a Lake package. -/
def updateManifest (config : LoadConfig) : LogIO Unit := do
let ws ← loadWorkspaceRoot config
let manifest ← buildUpdatedManifest ws
manifest.saveToFile ws.manifestFile

View file

@ -0,0 +1,110 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone, Gabriel Ebner
-/
import Lean.Data.Json
import Lake.Util.Log
open System Lean
namespace Lake
/-- Current version of the manifest format. -/
def Manifest.version : Nat := 4
/-- An entry for a package stored in the manifest. -/
inductive PackageEntry
| path (name : String) (dir : FilePath)
-- `dir` is relative to the package directory
-- of the package containing the manifest
| git (name : String) (url : String) (rev : String)
(inputRev? : Option String) (subDir? : Option FilePath)
deriving FromJson, ToJson, Repr, Inhabited
def PackageEntry.name : PackageEntry → String
| path name .. | git name .. => name
def PackageEntry.inDirectory (pkgDir : FilePath) : PackageEntry → PackageEntry
| path name dir => path name (pkgDir / dir)
| entry => entry
/-- Manifest file format. -/
structure Manifest where
packagesDir? : Option FilePath := none
entryMap : NameMap PackageEntry := {}
namespace Manifest
def empty : Manifest := {}
def isEmpty (self : Manifest) : Bool :=
self.entryMap.isEmpty
def entryArray (self : Manifest) : Array PackageEntry :=
self.entryMap.fold (fun a _ v => a.push v) #[]
def contains (packageName : Name) (self : Manifest) : Bool :=
self.entryMap.contains packageName
def find? (packageName : Name) (self : Manifest) : Option PackageEntry :=
self.entryMap.find? packageName
def insert (entry : PackageEntry) (self : Manifest) : Manifest :=
{self with entryMap := self.entryMap.insert entry.name entry}
instance : ForIn m Manifest PackageEntry where
forIn self init f := self.entryMap.forIn init (f ·.2)
protected def toJson (self : Manifest) : Json :=
Json.mkObj [
("version", version),
("packagesDir", toJson self.packagesDir?),
("packages", toJson self.entryArray)
]
instance : ToJson Manifest := ⟨Manifest.toJson⟩
protected def fromJson? (json : Json) : Except String Manifest := do
let ver ← (← json.getObjVal? "version").getNat?
match ver with
| 3 | 4 =>
let packagesDir? ← do
match json.getObjVal? "packagesDir" with
| .ok path => fromJson? path
| .error _ => pure none
let entries : Array PackageEntry ← fromJson? (← json.getObjVal? "packages")
return {
packagesDir?,
entryMap := entries.foldl (fun map entry => map.insert entry.name entry) {}
}
| 1 | 2 =>
throw s!"incompatible manifest version `{ver}`"
| _ =>
throw s!"unknown manifest version `{ver}`"
instance : FromJson Manifest := ⟨Manifest.fromJson?⟩
def loadFromFile (file : FilePath) : IO Manifest := do
let contents ← IO.FS.readFile file
match Json.parse contents with
| .ok json =>
match fromJson? json with
| .ok manifest =>
return manifest
| .error e =>
throw <| IO.userError <| s!"improperly formatted manifest: {e}"
| .error e =>
throw <| IO.userError <| s!"invalid JSON in manifest: {e}"
def loadOrEmpty (file : FilePath) : LogIO Manifest := do
match (← loadFromFile file |>.toBaseIO) with
| .ok a => return a
| .error e =>
unless e matches .noFileOrDirectory .. do
logWarning (toString e)
return {}
def saveToFile (self : Manifest) (manifestFile : FilePath) : IO PUnit := do
let jsonString := Json.pretty self.toJson
IO.FS.writeFile manifestFile <| jsonString.push '\n'

View file

@ -0,0 +1,102 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake.Util.Git
import Lake.Load.Manifest
import Lake.Config.Dependency
import Lake.Config.Package
open System Lean
namespace Lake
/-- Update the Git package in `repo` to `rev` if not already at it. -/
def updateGitPkg (repo : GitRepo) (rev? : Option String) : LogIO PUnit := do
let rev ← repo.findRemoteRevision rev?
if (← repo.headRevision) == rev then return
logInfo s!"updating {repo} to revision {rev}"
repo.checkoutDetach rev
/-- Clone the Git package as `repo`. -/
def cloneGitPkg (repo : GitRepo) (url : String) (rev? : Option String) : LogIO PUnit := do
logInfo s!"cloning {url} to {repo}"
repo.clone url
if let some rev := rev? then
let hash ← repo.resolveRemoteRevision rev
repo.checkoutDetach hash
def updateGitRepo (repo : GitRepo) (url : String)
(rev? : Option String) (name : String) : LogIO Unit := do
if (← repo.dirExists) then
if (← repo.getRemoteUrl?) = url then
updateGitPkg repo rev?
else
-- TODO: git resolves local file paths so we always hit this case for local repos
if System.Platform.isWindows then
-- Deleting git repositories via IO.FS.removeDirAll does not work reliably on windows
logInfo s!"{name}: URL has changed; you might need to delete {repo.dir} manually"
updateGitPkg repo rev?
else
logInfo s!"{name}: URL has changed; deleting {repo.dir} and cloning again"
IO.FS.removeDirAll repo.dir
cloneGitPkg repo url rev?
else
cloneGitPkg repo url rev?
def updateSource (relParentDir packagesDir : FilePath) (name : String) (source : Source) : LogIO PackageEntry :=
match source with
| .path dir => return .path name (relParentDir / dir)
| .git url inputRev? subDir? => do
let dir := packagesDir / name
let repo := GitRepo.mk dir
updateGitRepo repo url inputRev? name
let rev ← repo.headRevision
return .git name url rev inputRev? subDir?
structure MaterializeResult where
pkgDir : FilePath
relPkgDir : FilePath
remoteUrl? : Option String
gitTag? : Option String
manifestEntry : PackageEntry
deriving Repr, Inhabited
/--
Materializes a package entry, cloning and/or checkout it out as necessary.
-/
def materializePackageEntry (wsDir relPkgsDir : FilePath) (manifestEntry : PackageEntry) : LogIO MaterializeResult :=
match manifestEntry with
| .path _name pkgDir =>
return {
pkgDir := wsDir / pkgDir
relPkgDir := pkgDir
remoteUrl? := none
gitTag? := none
manifestEntry
}
| .git name url rev _inputRev? subDir? => do
let relGitDir := relPkgsDir / name
let gitDir := wsDir / relGitDir
let repo := GitRepo.mk gitDir
/-
Do not update (fetch remote) if already on revision
Avoids errors when offline e.g. [leanprover/lake#104][104]
[104]: https://github.com/leanprover/lake/issues/104
-/
let updateNecessary ← id do
if (← repo.dirExists) then
return (← repo.headRevision?) != rev
return true
if updateNecessary then
updateGitRepo repo url rev name
let relPkgDir := match subDir? with | .some subDir => relGitDir / subDir | .none => relGitDir
return {
pkgDir := wsDir / relPkgDir
relPkgDir
remoteUrl? := Git.filterUrl? url
gitTag? := ← repo.findTag?
manifestEntry
}

View file

@ -0,0 +1,122 @@
/-
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.DSL.Attributes
import Lake.Config.Workspace
/-!
This module contains definitions to load configuration objects from
a package configuration file (e.g., `lakefile.lean`).
-/
namespace Lake
open Lean System
/-- Unsafe implementation of `evalConstCheck`. -/
unsafe def unsafeEvalConstCheck (env : Environment) (opts : Options) (α) (type : Name) (const : Name) : Except String α :=
match env.find? const with
| none => throw s!"unknown constant '{const}'"
| some info =>
match info.type with
| Expr.const c _ =>
if c != type then
throwUnexpectedType
else
env.evalConst α opts const
| _ => throwUnexpectedType
where
throwUnexpectedType : Except String α :=
throw s!"unexpected type at '{const}', `{type}` expected"
/-- Like `Lean.Environment.evalConstCheck`, but with plain universe-polymorphic `Except`. -/
@[implemented_by unsafeEvalConstCheck] opaque evalConstCheck
(env : Environment) (opts : Options) (α) (type : Name) (const : Name) : Except String α
/-- Construct a `NameMap` from the declarations tagged with `attr`. -/
def mkTagMap
(env : Environment) (attr : OrderedTagAttribute)
[Monad m] (f : Name → m α) : m (NameMap α) :=
attr.ext.getState env |>.foldlM (init := {}) fun map declName =>
return map.insert declName <| ← f declName
/-- Construct a `DNameMap` from the declarations tagged with `attr`. -/
def mkDTagMap
(env : Environment) (attr : OrderedTagAttribute)
[Monad m] (f : (n : Name) → m (β n)) : m (DNameMap β) :=
attr.ext.getState env |>.foldlM (init := {}) fun map declName =>
return map.insert declName <| ← f declName
/-- Load a `PackageConfig` from a configuration environment. -/
def PackageConfig.loadFromEnv
(env : Environment) (opts := Options.empty) : Except String PackageConfig := do
let declName ←
match packageAttr.ext.getState env |>.toList with
| [] => error s!"configuration file is missing a `package` declaration"
| [name] => pure name
| _ => error s!"configuration file has multiple `package` declarations"
evalConstCheck env opts _ ``PackageConfig declName
/--
Load the remainder of a `Package`
from its configuration environment after resolving its dependencies.
-/
def Package.finalize (self : Package) (deps : Array Package) : LogIO Package := do
let env := self.configEnv; let opts := self.leanOpts
-- Load Script, Facet, & Target Configurations
let scripts : NameMap Script ← mkTagMap env scriptAttr fun name => do
let fn ← IO.ofExcept <| evalConstCheck env opts ScriptFn ``ScriptFn name
return {fn, doc? := (← findDocString? env name)}
let defaultScripts ← defaultScriptAttr.ext.getState env |>.mapM fun name =>
if let some script := scripts.find? name then pure script else
error s!"package is missing script `{name}` marked as a default"
let leanLibConfigs ← IO.ofExcept <| mkTagMap env leanLibAttr fun name =>
evalConstCheck env opts LeanLibConfig ``LeanLibConfig name
let leanExeConfigs ← IO.ofExcept <| mkTagMap env leanExeAttr fun name =>
evalConstCheck env opts LeanExeConfig ``LeanExeConfig name
let externLibConfigs ← mkDTagMap env externLibAttr fun name =>
match evalConstCheck env opts ExternLibDecl ``ExternLibDecl name with
| .ok decl =>
if h : decl.pkg = self.config.name ∧ decl.name = name then
return h.1 ▸ h.2 ▸ decl.config
else
error s!"target was defined as `{decl.pkg}/{decl.name}`, but was registered as `{self.name}/{name}`"
| .error e => error e
let opaqueTargetConfigs ← mkDTagMap env targetAttr fun name =>
match evalConstCheck env opts TargetDecl ``TargetDecl name with
| .ok decl =>
if h : decl.pkg = self.config.name ∧ decl.name = name then
return OpaqueTargetConfig.mk <| h.1 ▸ h.2 ▸ decl.config
else
error s!"target was defined as `{decl.pkg}/{decl.name}`, but was registered as `{self.name}/{name}`"
| .error e => error e
let defaultTargets := defaultTargetAttr.ext.getState env
-- Fill in the Package
return {self with
opaqueDeps := deps.map (.mk ·)
leanLibConfigs, leanExeConfigs, externLibConfigs
opaqueTargetConfigs, defaultTargets, scripts, defaultScripts
}
/--
Load module/package facets into a `Workspace` from a configuration environment.
-/
def Workspace.addFacetsFromEnv
(env : Environment) (opts : Options) (self : Workspace) : Except String Workspace := do
let mut ws := self
for name in moduleFacetAttr.ext.getState env do
match evalConstCheck env opts ModuleFacetDecl ``ModuleFacetDecl name with
| .ok decl => ws := ws.addModuleFacetConfig <| decl.config
| .error e => error e
for name in packageFacetAttr.ext.getState env do
match evalConstCheck env opts PackageFacetDecl ``PackageFacetDecl name with
| .ok decl => ws := ws.addPackageFacetConfig <| decl.config
| .error e => error e
for name in libraryFacetAttr.ext.getState env do
match evalConstCheck env opts LibraryFacetDecl ``LibraryFacetDecl name with
| .ok decl => ws := ws.addLibraryFacetConfig <| decl.config
| .error e => error e
return ws

10
src/lake/Lake/Main.lean Normal file
View file

@ -0,0 +1,10 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake
import Lake.CLI
def main (args : List String) : IO UInt32 := do
Lake.cli args -- should not throw errors (outside user code)

View file

@ -0,0 +1,267 @@
/-
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.Util.Task
import Lake.Util.OptionIO
import Lake.Util.Lift
/-!
This module Defines the asynchronous monadic interface for Lake.
The interface is composed of three major abstract monadic types:
* `m`: The monad of the synchronous action (e.g., `IO`).
* `n`: The monad of the (a)synchronous task manager (e.g., `BaseIO`).
* `k`: The monad of the (a)synchronous task (e.g., `IOTask`).
The definitions within this module provide the basic utilities for converting
between these monads and combining them in different ways.
-/
namespace Lake
--------------------------------------------------------------------------------
/-! # Async / Await Abstraction -/
--------------------------------------------------------------------------------
class Sync (m : Type u → Type v) (n : outParam $ Type u' → Type w) (k : outParam $ Type u → Type u') where
/-- Run the monadic action as a synchronous task. -/
sync : m α → n (k α)
export Sync (sync)
class Async (m : Type u → Type v) (n : outParam $ Type u' → Type w) (k : outParam $ Type u → Type u') where
/-- Run the monadic action as an asynchronous task. -/
async : m α → n (k α)
export Async (async)
class Await (k : Type u → Type v) (m : outParam $ Type u → Type w) where
/-- Wait for an (a)synchronous task to finish. -/
await : k α → m α
export Await (await)
/-! ## Standard Instances -/
instance : Sync Id Id Task := ⟨Task.pure⟩
instance : Sync BaseIO BaseIO BaseIOTask := ⟨Functor.map Task.pure⟩
instance [Sync m n k] : Sync (ReaderT ρ m) (ReaderT ρ n) k where
sync x := fun r => sync (x r)
instance [Sync m n k] : Sync (ExceptT ε m) n (ExceptT ε k) where
sync x := cast (by delta ExceptT; rfl) <| sync (n := n) x.run
instance [Sync m n k] : Sync (OptionT m) n (OptionT k) where
sync x := cast (by delta OptionT; rfl) <| sync (n := n) x.run
instance : Sync (EIO ε) BaseIO (EIOTask ε) where
sync x := sync <| ExceptT.mk x.toBaseIO
instance : Sync OptionIO BaseIO OptionIOTask where
sync x := sync <| OptionT.mk x.toBaseIO
instance : Async Id Id Task := ⟨Task.pure⟩
instance : Async BaseIO BaseIO BaseIOTask := ⟨BaseIO.asTask⟩
instance [Async m n k] : Async (ReaderT ρ m) (ReaderT ρ n) k where
async x := fun r => async (x r)
instance [Async m n k] : Async (ExceptT ε m) n (ExceptT ε k) where
async x := cast (by delta ExceptT; rfl) <| async (n := n) x.run
instance [Async m n k] : Async (OptionT m) n (OptionT k) where
async x := cast (by delta OptionT; rfl) <| async (n := n) x.run
instance : Async (EIO ε) BaseIO (EIOTask ε) where
async x := async <| ExceptT.mk x.toBaseIO
instance : Async OptionIO BaseIO OptionIOTask where
async x := async <| OptionT.mk x.toBaseIO
instance : Await Task Id := ⟨Task.get⟩
instance : Await (EIOTask ε) (EIO ε) where
await x := IO.wait x >>= liftM
instance : Await OptionIOTask OptionIO where
await x := IO.wait x >>= liftM
instance [Await k m] : Await (ExceptT ε k) (ExceptT ε m) where
await x := ExceptT.mk <| await x.run
instance [Await k m] : Await (OptionT k) (OptionT m) where
await x := OptionT.mk <| await x.run
--------------------------------------------------------------------------------
/-! # Combinators -/
--------------------------------------------------------------------------------
class BindSync (m : Type u → Type v) (n : outParam $ Type u' → Type w) (k : outParam $ Type u → Type u') where
/-- Perform a synchronous action after another (a)synchronous task completes successfully. -/
bindSync {α β : Type u} : Task.Priority → k α → (α → m β) → n (k β)
export BindSync (bindSync)
class BindAsync (n : Type u → Type v) (k : Type u → Type u) where
/-- Perform a asynchronous task after another (a)synchronous task completes successfully. -/
bindAsync {α β : Type u} : k α → (α → n (k β)) → n (k β)
export BindAsync (bindAsync)
class SeqAsync (n : outParam $ Type u → Type v) (k : Type u → Type u) where
/-- Combine two (a)synchronous tasks, applying the result of the second one ot the first one. -/
seqAsync {α β : Type u} : k (α → β) → k α → n (k β)
export SeqAsync (seqAsync)
class SeqLeftAsync (n : outParam $ Type u → Type v) (k : Type u → Type u) where
/-- Combine two (a)synchronous tasks, returning the result of the first one. -/
seqLeftAsync {α β : Type u} : k α → k β → n (k α)
export SeqLeftAsync (seqLeftAsync)
class SeqRightAsync (n : outParam $ Type u → Type v) (k : Type u → Type u) where
/-- Combine two (a)synchronous tasks, returning the result of the second one. -/
seqRightAsync {α β : Type u} : k α → k β → n (k β)
export SeqRightAsync (seqRightAsync)
class SeqWithAsync (n : outParam $ Type u → Type v) (k : Type u → Type u) where
/-- Combine two (a)synchronous tasks using `f`. -/
seqWithAsync {α β : Type u} : (f : α → β → γ) → k α → k β → n (k γ)
export SeqWithAsync (seqWithAsync)
class ApplicativeAsync (n : outParam $ Type u → Type v) (k : Type u → Type u)
extends SeqAsync n k, SeqLeftAsync n k, SeqRightAsync n k, SeqWithAsync n k where
seqAsync := seqWithAsync fun f a => f a
seqLeftAsync := seqWithAsync fun a _ => a
seqRightAsync := seqWithAsync fun _ b => b
/-! ## Standard Instances -/
instance : BindSync Id Id Task := ⟨fun _ => flip Task.map⟩
instance : BindSync BaseIO BaseIO BaseIOTask := ⟨fun _ => flip BaseIO.mapTask⟩
instance : BindSync (EIO ε) BaseIO (ETask ε) where
bindSync prio ka f := ka.run |> BaseIO.mapTask (prio := prio) fun
| Except.ok a => f a |>.toBaseIO
| Except.error e => pure <| Except.error e
instance : BindSync OptionIO BaseIO OptionIOTask where
bindSync prio ka f := ka.run |> BaseIO.mapTask (prio := prio) fun
| some a => f a |>.toBaseIO
| none => pure none
instance [BindSync m n k] : BindSync (ReaderT ρ m) (ReaderT ρ n) k where
bindSync prio ka f := fun r => bindSync prio ka fun a => f a r
instance [BindSync m n k] [Pure m] : BindSync (ExceptT ε m) n (ExceptT ε k) where
bindSync prio ka f := cast (by delta ExceptT; rfl) <| bindSync prio (n := n) ka.run fun
| Except.ok a => f a |>.run
| Except.error e => pure <| Except.error e
instance [BindSync m n k] [Pure m] : BindSync (OptionT m) n (OptionT k) where
bindSync prio ka f := cast (by delta OptionT; rfl) <| bindSync prio ka.run fun
| some a => f a |>.run
| none => pure none
instance : BindAsync Id Task := ⟨Task.bind⟩
instance : BindAsync BaseIO BaseIOTask := ⟨BaseIO.bindTask⟩
instance : BindAsync BaseIO (EIOTask ε) where
bindAsync ka f := BaseIO.bindTask ka.run fun
| Except.ok a => f a
| Except.error e => pure <| pure (Except.error e)
instance : BindAsync BaseIO OptionIOTask where
bindAsync ka f := BaseIO.bindTask ka.run fun
| some a => f a
| none => pure (pure none)
instance [BindAsync n k] : BindAsync (ReaderT ρ n) k where
bindAsync ka f := fun r => bindAsync ka fun a => f a r
instance [BindAsync n k] [Pure n] [Pure k] : BindAsync n (ExceptT ε k) where
bindAsync ka f := cast (by delta ExceptT; rfl) <| bindAsync ka.run fun
| Except.ok a => f a
| Except.error e => pure <| pure <| Except.error e
instance [BindAsync n k] [Pure n] [Pure k] : BindAsync n (OptionT k) where
bindAsync ka f := cast (by delta OptionT; rfl) <| bindAsync ka.run fun
| some a => f a
| none => pure (pure none)
instance : ApplicativeAsync Id Task where
seqWithAsync f ka kb := ka.bind fun a => kb.bind fun b => pure <| f a b
instance : ApplicativeAsync BaseIO BaseIOTask where
seqWithAsync f ka kb := BaseIO.bindTask ka fun a => BaseIO.bindTask kb fun b => pure <| pure <| f a b
instance [ApplicativeAsync n k] : ApplicativeAsync n (ExceptT ε k) where
seqWithAsync f ka kb :=
let h xa xb : Except ε _ := return f (← xa) (← xb)
cast (by delta ExceptT; rfl) <| seqWithAsync (n := n) h ka kb
instance [ApplicativeAsync n k] : ApplicativeAsync n (OptionT k) where
seqWithAsync f ka kb :=
let h xa xb : Option _ := return f (← xa) (← xb)
cast (by delta OptionT; rfl) <| seqWithAsync (n := n) h ka kb
--------------------------------------------------------------------------------
/-! # List/Array Utilities -/
--------------------------------------------------------------------------------
/-! ## Sequencing (A)synchronous Tasks -/
/-- Combine all (a)synchronous tasks in a `List` from right to left into a single task ending `last`. -/
def seqLeftList1Async [SeqLeftAsync n k] [Monad n] (last : (k α)) : (tasks : List (k α)) → n (k α)
| [] => return last
| t::ts => seqLeftList1Async t ts >>= (seqLeftAsync last ·)
/-- Combine all (a)synchronous tasks in a `List` from right to left into a single task. -/
def seqLeftListAsync [SeqLeftAsync n k] [Monad n] [Pure k] : (tasks : List (k PUnit)) → n (k PUnit)
| [] => return (pure ())
| t::ts => seqLeftList1Async t ts
/-- Combine all (a)synchronous tasks in a `List` from left to right into a single task. -/
def seqRightListAsync [SeqRightAsync n k] [Monad n] [Pure k] : (tasks : List (k PUnit)) → n (k PUnit)
| [] => return (pure ())
| t::ts => ts.foldlM seqRightAsync t
/-- Combine all (a)synchronous tasks in a `Array` from right to left into a single task. -/
def seqLeftArrayAsync [SeqLeftAsync n k] [Monad n] [Pure k] (tasks : Array (k PUnit)) : n (k PUnit) :=
if h : 0 < tasks.size then
tasks.pop.foldrM seqLeftAsync (tasks.get ⟨tasks.size - 1, Nat.sub_lt h (by decide)⟩)
else
return (pure ())
/-- Combine all (a)synchronous tasks in a `Array` from left to right into a single task. -/
def seqRightArrayAsync [SeqRightAsync n k] [Monad n] [Pure k] (tasks : Array (k PUnit)) : n (k PUnit) :=
if h : 0 < tasks.size then
tasks.foldlM seqRightAsync (tasks.get ⟨0, h⟩)
else
return (pure ())
/-! ## Folding (A)synchronous Tasks -/
variable [SeqWithAsync n k] [Monad n] [Pure k]
/-- Fold a `List` of (a)synchronous tasks from right to left (i.e., a right fold) into a single task. -/
def foldLeftListAsync (f : α → β → β) (init : β) (tasks : List (k α)) : n (k β) :=
tasks.foldrM (seqWithAsync f) (pure init)
/-- Fold an `Array` of (a)synchronous tasks from right to left (i.e., a right fold) into a single task. -/
def foldLeftArrayAsync (f : α → β → β) (init : β) (tasks : Array (k α)) : n (k β) :=
tasks.foldrM (seqWithAsync f) (pure init)
/-- Fold a `List` of (a)synchronous tasks from left to right (i.e., a left fold) into a single task. -/
def foldRightListAsync (f : β → α → β) (init : β) (tasks : List (k α)) : n (k β) :=
tasks.foldlM (seqWithAsync f) (pure init)
/-- Fold an `Array` of (a)synchronous tasks from left to right (i.e., a left fold) into a single task. -/
def foldRightArrayAsync (f : β → α → β) (init : β) (tasks : Array (k α)) : n (k β) :=
tasks.foldlM (seqWithAsync f) (pure init)

View file

@ -0,0 +1,160 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Parser.Term
import Lean.Elab.Term
import Lean.Expr
namespace Lake
open Lean Parser
abbrev Ellipsis := TSyntax ``Term.ellipsis
abbrev NamedArgument := TSyntax ``Term.namedArgument
abbrev Argument := TSyntax ``Term.argument
instance : Coe Term Argument where
coe s := ⟨s.raw⟩
instance : Coe Ellipsis Argument where
coe s := ⟨s.raw⟩
instance : Coe NamedArgument Argument where
coe s := ⟨s.raw⟩
abbrev Hole := TSyntax ``Term.hole
abbrev BinderIdent := TSyntax ``Term.binderIdent
abbrev TypeSpec := TSyntax ``Term.typeSpec
def mkHoleFrom (ref : Syntax) : Hole :=
mkNode ``Term.hole #[mkAtomFrom ref "_"]
instance : Coe Hole Term where
coe s := ⟨s.raw⟩
instance : Coe Hole BinderIdent where
coe s := ⟨s.raw⟩
instance : Coe Ident BinderIdent where
coe s := ⟨s.raw⟩
abbrev BracketedBinder := TSyntax ``Term.bracketedBinder
abbrev FunBinder := TSyntax ``Term.funBinder
instance : Coe BinderIdent FunBinder where
coe s := ⟨s.raw⟩
@[run_parser_attribute_hooks]
def binder := Term.binderIdent <|> Term.bracketedBinder
abbrev Binder := TSyntax ``binder
instance : Coe Binder (TSyntax [identKind, ``Term.hole, ``Term.bracketedBinder]) where
coe stx := ⟨stx.raw⟩
abbrev BinderModifier := TSyntax [``Term.binderTactic, ``Term.binderDefault]
--------------------------------------------------------------------------------
-- Adapted from the private utilities in `Lean.Elab.Binders`
structure BinderSyntaxView where
id : Ident
type : Term
info : BinderInfo
modifier? : Option BinderModifier := none
def expandOptType (ref : Syntax) (optType : Syntax) : Term :=
if optType.isNone then
mkHoleFrom ref
else
⟨optType[0][1]⟩
def getBinderIds (ids : Syntax) : MacroM (Array BinderIdent) :=
ids.getArgs.mapM fun id =>
let k := id.getKind
if k == identKind || k == `Lean.Parser.Term.hole then
return ⟨id⟩
else
Macro.throwErrorAt id "identifier or `_` expected"
def expandBinderIdent (stx : Syntax) : MacroM Ident :=
match stx with
| `(_) => (⟨·⟩) <$> Elab.Term.mkFreshIdent stx
| _ => pure ⟨stx⟩
def expandOptIdent (stx : Syntax) : BinderIdent :=
if stx.isNone then mkHoleFrom stx else ⟨stx[0]⟩
def expandBinderType (ref : Syntax) (stx : Syntax) : Term :=
if stx.getNumArgs == 0 then mkHoleFrom ref else ⟨stx[1]⟩
def expandBinderModifier (optBinderModifier : Syntax) : Option BinderModifier :=
if optBinderModifier.isNone then
none
else
some ⟨optBinderModifier[0]⟩
def matchBinder (stx : Syntax) : MacroM (Array BinderSyntaxView) := do
let k := stx.getKind
if stx.isIdent || k == ``Term.hole then
-- binderIdent
return #[{ id := (← expandBinderIdent stx), type := mkHoleFrom stx, info := .default }]
else if k == ``Lean.Parser.Term.explicitBinder then
-- `(` binderIdent+ binderType (binderDefault <|> binderTactic)? `)`
let ids ← getBinderIds stx[1]
let type := stx[2]
let modifier? := expandBinderModifier stx[3]
ids.mapM fun id => return {
id := ← expandBinderIdent id,
type := expandBinderType id type,
info := .default,
modifier?
}
else if k == ``Lean.Parser.Term.implicitBinder then
-- `{` binderIdent+ binderType `}`
let ids ← getBinderIds stx[1]
let type := stx[2]
ids.mapM fun id => return {
id := ← expandBinderIdent id,
type := expandBinderType id type,
info := .implicit
}
else if k == ``Lean.Parser.Term.strictImplicitBinder then
-- `⦃` binderIdent+ binderType `⦄`
let ids ← getBinderIds stx[1]
let type := stx[2]
ids.mapM fun id => do pure {
id := ← expandBinderIdent id,
type := expandBinderType id type,
info := .strictImplicit
}
else if k == ``Lean.Parser.Term.instBinder then
-- `[` optIdent type `]`
let id := expandOptIdent stx[1]
let type := stx[2]
return #[{id := ← expandBinderIdent id, type := ⟨type⟩, info := .instImplicit}]
else
Macro.throwUnsupported
--------------------------------------------------------------------------------
def BinderSyntaxView.mkBinder : BinderSyntaxView → MacroM Binder
| {id, type, info, modifier?} => do
match info with
| .default => `(binder| ($id : $type $[$modifier?]?))
| .implicit => `(binder| {$id : $type})
| .strictImplicit => `(binder| ⦃$id : $type⦄)
| .instImplicit => `(binder| [$id : $type])
def BinderSyntaxView.mkArgument : BinderSyntaxView → MacroM NamedArgument
| {id, ..} => `(Term.namedArgument| ($id := $id))
def expandBinders (dbs : Array Binder) : MacroM (Array Binder × Array Term) := do
let mut bs := #[]
let mut args : Array Term := #[]
for db in dbs do
let views ← matchBinder db.raw
for view in views do
bs := bs.push (← view.mkBinder)
args := args.push ⟨(← view.mkArgument).raw⟩
return (bs, args)

View file

@ -0,0 +1,19 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
open Lean (Name)
/-- Converts a snake case, kebab case, or lower camel case `String` to upper camel case. -/
def toUpperCamelCaseString (str : String) : String :=
let parts := str.split fun chr => chr == '_' || chr == '-'
String.join <| parts.map (·.capitalize)
/-- Converts a snake case, kebab case, or lower camel case `Name` to upper camel case. -/
def toUpperCamelCase (name : Name) : Name :=
if let Name.str p s := name then
Name.mkStr (toUpperCamelCase p) <| toUpperCamelCaseString s
else
name

165
src/lake/Lake/Util/Cli.lean Normal file
View file

@ -0,0 +1,165 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/-!
Defines the abstract CLI interface for Lake.
-/
/-! # Types -/
def ArgList := List String
@[inline] def ArgList.mk (args : List String) : ArgList :=
args
abbrev ArgsT := StateT ArgList
@[inline] def ArgsT.run (args : List String) (self : ArgsT m α) : m (α × List String) :=
StateT.run self args
@[inline] def ArgsT.run' [Functor m] (args : List String) (self : ArgsT m α) : m α :=
StateT.run' self args
structure OptionHandlers (m : Type u → Type v) (α : Type u) where
/-- Process a long option (ex. `--long` or `"--long foo bar"`). -/
long : String → m α
/-- Process a short option (ex. `-x` or `--`). -/
short : Char → m α
/-- Process a long short option (ex. `-long`, `-xarg`, `-xyz`). -/
longShort : String → m α
/-! # Utilities -/
variable [Monad m] [MonadStateOf ArgList m]
/-- Get the remaining argument list. -/
@[inline] def getArgs : m (List String) :=
get
/-- Replace the argument list. -/
@[inline] def setArgs (args : List String) : m PUnit :=
set (ArgList.mk args)
/-- Take the head of the remaining argument list (or none if empty). -/
@[inline] def takeArg? : m (Option String) :=
modifyGet fun | [] => (none, []) | arg :: args => (some arg, args)
/-- Take the remaining argument list, leaving only an empty list. -/
@[inline] def takeArgs : m (List String) :=
modifyGet fun args => (args, [])
/-- Add a string to the head of the remaining argument list. -/
@[inline] def consArg (arg : String) : m PUnit :=
modify fun args => arg :: args
/-- Process a short option of the form `-x=arg`. -/
@[inline] def shortOptionWithEq (handle : Char → m α) (opt : String) : m α := do
consArg (opt.drop 3); handle (opt.get ⟨1⟩)
/-- Process a short option of the form `"-x arg"`. -/
@[inline] def shortOptionWithSpace (handle : Char → m α) (opt : String) : m α := do
consArg <| opt.drop 2 |>.trimLeft; handle (opt.get ⟨1⟩)
/-- Process a short option of the form `-xarg`. -/
@[inline] def shortOptionWithArg (handle : Char → m α) (opt : String) : m α := do
consArg (opt.drop 2); handle (opt.get ⟨1⟩)
/-- Process a multiple short options grouped together (ex. `-xyz` as `x`, `y`, `z`). -/
@[inline] def multiShortOption (handle : Char → m PUnit) (opt : String) : m PUnit := do
-- TODO: this code is assuming all characters are ASCII.
for i in [1:opt.length] do handle (opt.get ⟨i⟩)
/-- Splits a long option of the form `"--long foo bar"` into `--long` and `"foo bar"`. -/
@[inline] def longOptionOrSpace (handle : String → m α) (opt : String) : m α :=
let pos := opt.posOf ' '
if pos = opt.endPos then
handle opt
else do
consArg <| opt.extract (opt.next pos) opt.endPos
handle <| opt.extract 0 pos
/-- Splits a long option of the form `--long=arg` into `--long` and `arg`. -/
@[inline] def longOptionOrEq (handle : String → m α) (opt : String) : m α :=
let pos := opt.posOf '='
if pos = opt.endPos then
handle opt
else do
consArg <| opt.extract (opt.next pos) opt.endPos
handle <| opt.extract 0 pos
/-- Process a long option of the form `--long`, `--long=arg`, `"--long arg"`. -/
@[inline] def longOption (handle : String → m α) : String → m α :=
longOptionOrEq <| longOptionOrSpace handle
/-- Process a short option of the form `-x`, `-x=arg`, `-x arg`, or `-long`. -/
@[inline] def shortOption
(shortHandle : Char → m α) (longHandle : String → m α)
(opt : String) : m α :=
if opt.length == 2 then -- `-x`
shortHandle (opt.get ⟨1⟩)
else -- `-c(.+)`
match opt.get ⟨2⟩ with
| '=' => -- `-x=arg`
shortOptionWithEq shortHandle opt
| ' ' => -- `"-x arg"`
shortOptionWithSpace shortHandle opt
| _ => -- `-long`
longHandle opt
/--
Process an option, short or long, using the given handlers.
An option is an argument of length > 1 starting with a dash (`-`).
An option may consume additional elements of the argument list.
-/
@[inline] def option (handlers : OptionHandlers m α) (opt : String) : m α :=
if opt.get ⟨1⟩ == '-' then -- `--(.*)`
longOption handlers.long opt
else
shortOption handlers.short handlers.longShort opt
/-- Process the head argument of the list using `handle` if it is an option. -/
def processLeadingOption (handle : String → m PUnit) : m PUnit := do
match (← getArgs) with
| [] => pure ()
| arg :: args =>
if arg.length > 1 && arg.get 0 == '-' then -- `-(.+)`
setArgs args
handle arg
/--
Process the leading options of the remaining argument list.
Consumes empty leading arguments in the argument list.
-/
partial def processLeadingOptions (handle : String → m PUnit) : m PUnit := do
if let arg :: args ← getArgs then
let len := arg.length
if len > 1 && arg.get 0 == '-' then -- `-(.+)`
setArgs args
handle arg
processLeadingOptions handle
else if len == 0 then -- skip empty leading args
setArgs args
processLeadingOptions handle
/-- Process every option and collect the remaining arguments into an `Array`. -/
partial def collectArgs (option : String → m PUnit) (args : Array String := #[]) : m (Array String) := do
if let some arg ← takeArg? then
let len := arg.length
if len > 1 && arg.get 0 == '-' then -- `-(.+)`
option arg
collectArgs option args
else if len == 0 then -- skip empty args
collectArgs option args
else
collectArgs option (args.push arg)
else
pure args
/-- Process every option in the argument list. -/
@[inline] def processOptions (handle : String → m PUnit) : m PUnit := do
setArgs (← collectArgs handle).toList

View file

@ -0,0 +1,126 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/--
Proof that the equality of a compare function corresponds
to propositional equality.
-/
class EqOfCmp (α : Type u) (cmp : αα → Ordering) where
eq_of_cmp {a a' : α} : cmp a a' = .eq → a = a'
export EqOfCmp (eq_of_cmp)
/--
Proof that the equality of a compare function corresponds
to propositional equality and vice versa.
-/
class LawfulCmpEq (α : Type u) (cmp : αα → Ordering) extends EqOfCmp α cmp where
cmp_rfl {a : α} : cmp a a = .eq
export LawfulCmpEq (cmp_rfl)
attribute [simp] cmp_rfl
@[simp] theorem cmp_iff_eq [LawfulCmpEq α cmp] : cmp a a' = .eq ↔ a = a' :=
Iff.intro eq_of_cmp fun a_eq => a_eq ▸ cmp_rfl
/--
Proof that the equality of a compare function corresponds
to propositional equality with respect to a given function.
-/
class EqOfCmpWrt (α : Type u) {β : Type v} (f : α → β) (cmp : αα → Ordering) where
eq_of_cmp_wrt {a a' : α} : cmp a a' = .eq → f a = f a'
export EqOfCmpWrt (eq_of_cmp_wrt)
instance : EqOfCmpWrt α (fun _ => α) cmp := ⟨fun _ => rfl⟩
instance [EqOfCmp α cmp] : EqOfCmpWrt α f cmp where
eq_of_cmp_wrt h := by rw [eq_of_cmp h]
instance [EqOfCmpWrt α (fun a => a) cmp] : EqOfCmp α cmp where
eq_of_cmp h := eq_of_cmp_wrt (f := fun a => a) h
-- ## Basic Instances
theorem eq_of_compareOfLessAndEq [LT α] [DecidableEq α] {a a' : α}
[Decidable (a < a')] (h : compareOfLessAndEq a a' = .eq) : a = a' := by
unfold compareOfLessAndEq at h
split at h; case inl => exact False.elim h
split at h; case inr => exact False.elim h
assumption
theorem compareOfLessAndEq_rfl [LT α] [DecidableEq α] {a : α}
[Decidable (a < a)] (lt_irrefl : ¬ a < a) : compareOfLessAndEq a a = .eq := by
simp [compareOfLessAndEq, lt_irrefl]
instance : LawfulCmpEq Nat compare where
eq_of_cmp := eq_of_compareOfLessAndEq
cmp_rfl := compareOfLessAndEq_rfl <| Nat.lt_irrefl _
theorem Fin.eq_of_compare {n n' : Fin m} (h : compare n n' = .eq) : n = n' := by
dsimp only [compare] at h
have h' := eq_of_compareOfLessAndEq h
exact Fin.eq_of_val_eq h'
instance : LawfulCmpEq (Fin n) compare where
eq_of_cmp := Fin.eq_of_compare
cmp_rfl := compareOfLessAndEq_rfl <| Nat.lt_irrefl _
instance : LawfulCmpEq UInt64 compare where
eq_of_cmp h := eq_of_compareOfLessAndEq h
cmp_rfl := compareOfLessAndEq_rfl <| Nat.lt_irrefl _
theorem List.lt_irrefl [LT α] (irrefl_α : ∀ a : α, ¬ a < a)
: (a : List α) → ¬ a < a
| _, .head _ _ h => irrefl_α _ h
| _, .tail _ _ h3 => lt_irrefl irrefl_α _ h3
@[simp] theorem String.lt_irrefl (s : String) : ¬ s < s :=
List.lt_irrefl (fun c => Nat.lt_irrefl c.1.1) _
instance : LawfulCmpEq String compare where
eq_of_cmp := eq_of_compareOfLessAndEq
cmp_rfl := compareOfLessAndEq_rfl <| String.lt_irrefl _
@[macro_inline]
def Option.compareWith (cmp : αα → Ordering) : Option α → Option α → Ordering
| none, none => .eq
| none, some _ => .lt
| some _, none => .gt
| some x, some y => cmp x y
instance [EqOfCmp α cmp] : EqOfCmp (Option α) (Option.compareWith cmp) where
eq_of_cmp := by
intro o o'
unfold Option.compareWith
cases o <;> cases o' <;> simp
exact eq_of_cmp
instance [LawfulCmpEq α cmp] : LawfulCmpEq (Option α) (Option.compareWith cmp) where
cmp_rfl := by
intro o
unfold Option.compareWith
cases o <;> simp
def Prod.compareWith
(cmpA : αα → Ordering) (cmpB : β → β → Ordering)
: (α × β) → (α × β) → Ordering :=
fun (a, b) (a', b') => match cmpA a a' with | .eq => cmpB b b' | ord => ord
instance [EqOfCmp α cmpA] [EqOfCmp β cmpB]
: EqOfCmp (α × β) (Prod.compareWith cmpA cmpB) where
eq_of_cmp := by
intro (a, b) (a', b')
dsimp only [Prod.compareWith]
split; next ha => intro hb; rw [eq_of_cmp ha, eq_of_cmp hb]
intros; contradiction
instance [LawfulCmpEq α cmpA] [LawfulCmpEq β cmpB]
: LawfulCmpEq (α × β) (Prod.compareWith cmpA cmpB) where
cmp_rfl := by simp [Prod.compareWith]

View file

@ -0,0 +1,28 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/-- A sequence of calls donated by the key type `κ`. -/
abbrev CallStack κ := List κ
/-- A `CallStack` ending in a cycle. -/
abbrev Cycle κ := CallStack κ
/-- A transformer that equips a monad with a `CallStack` to detect cycles. -/
abbrev CycleT κ m := ReaderT (CallStack κ) <| ExceptT (Cycle κ) m
/--
Add `key` to the monad's `CallStack` before invoking `act`.
If adding `key` produces a cycle, the cyclic call stack is thrown.
-/
@[inline] def guardCycle [BEq κ] [Monad m]
(key : κ) (act : CycleT κ m α) : CycleT κ m α := do
let parents ← read
if parents.contains key then
throw <| key :: (parents.partition (· != key)).1 ++ [key]
else
act (key :: parents)

View file

@ -0,0 +1,149 @@
/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mac Malone
-/
import Lean.Data.RBMap
import Lake.Util.Compare
namespace Lake
open Lean RBNode
/-!
This module includes a dependently typed adaption of the `Lean.RBMap`
defined in `Lean.Data.RBMap` module of the Lean core. Most of the code is
copied directly from there with only minor edits.
-/
instance inhabitedOfEmptyCollection [EmptyCollection α] : Inhabited α where
default := {}
@[specialize] def RBNode.dFind {α : Type u} {β : α → Type v}
(cmp : αα → Ordering) [h : EqOfCmpWrt α β cmp] : RBNode α β → (k : α) → Option (β k)
| leaf, _ => none
| node _ a ky vy b, x =>
match ho:cmp x ky with
| Ordering.lt => dFind cmp a x
| Ordering.gt => dFind cmp b x
| Ordering.eq => some <| cast (by rw [eq_of_cmp_wrt (f := β) ho]) vy
/-- A Dependently typed `RBMap`. -/
def DRBMap (α : Type u) (β : α → Type v) (cmp : αα → Ordering) : Type (max u v) :=
{t : RBNode α β // t.WellFormed cmp }
@[inline] def mkDRBMap (α : Type u) (β : α → Type v) (cmp : αα → Ordering) : DRBMap α β cmp :=
⟨leaf, WellFormed.leafWff⟩
@[inline] def DRBMap.empty {α : Type u} {β : α → Type v} {cmp : αα → Ordering} : DRBMap α β cmp :=
mkDRBMap ..
instance (α : Type u) (β : α → Type v) (cmp : αα → Ordering) : EmptyCollection (DRBMap α β cmp) :=
⟨DRBMap.empty⟩
namespace DRBMap
variable {α : Type u} {β : α → Type v} {σ : Type w} {cmp : αα → Ordering}
def depth (f : Nat → Nat → Nat) (t : DRBMap α β cmp) : Nat :=
t.val.depth f
@[inline] def fold (f : σ → (k : α) → β k → σ) : (init : σ) → DRBMap α β cmp → σ
| b, ⟨t, _⟩ => t.fold f b
@[inline] def revFold (f : σ → (k : α) → β k → σ) : (init : σ) → DRBMap α β cmp → σ
| b, ⟨t, _⟩ => t.revFold f b
@[inline] def foldM [Monad m] (f : σ → (k : α) → β k → m σ) : (init : σ) → DRBMap α β cmp → m σ
| b, ⟨t, _⟩ => t.foldM f b
@[inline] def forM [Monad m] (f : (k : α) → β k → m PUnit) (t : DRBMap α β cmp) : m PUnit :=
t.foldM (fun _ k v => f k v) ⟨⟩
@[inline] protected def forIn [Monad m] (t : DRBMap α β cmp) (init : σ) (f : ((k : α) × β k) → σ → m (ForInStep σ)) : m σ :=
t.val.forIn init (fun a b acc => f ⟨a, b⟩ acc)
instance : ForIn m (DRBMap α β cmp) ((k : α) × β k) where
forIn := DRBMap.forIn
@[inline] def isEmpty : DRBMap α β cmp → Bool
| ⟨leaf, _⟩ => true
| _ => false
@[specialize] def toList : DRBMap α β cmp → List ((k : α) × β k)
| ⟨t, _⟩ => t.revFold (fun ps k v => ⟨k, v⟩::ps) []
@[inline] protected def min : DRBMap α β cmp → Option ((k : α) × β k)
| ⟨t, _⟩ =>
match t.min with
| some ⟨k, v⟩ => some ⟨k, v⟩
| none => none
@[inline] protected def max : DRBMap α β cmp → Option ((k : α) × β k)
| ⟨t, _⟩ =>
match t.max with
| some ⟨k, v⟩ => some ⟨k, v⟩
| none => none
instance [Repr ((k : α) × β k)] : Repr (DRBMap α β cmp) where
reprPrec m prec := Repr.addAppParen ("Lake.drbmapOf " ++ repr m.toList) prec
@[inline] def insert : DRBMap α β cmp → (k : α) → β k → DRBMap α β cmp
| ⟨t, w⟩, k, v => ⟨t.insert cmp k v, WellFormed.insertWff w rfl⟩
@[inline] def erase : DRBMap α β cmp → α → DRBMap α β cmp
| ⟨t, w⟩, k => ⟨t.erase cmp k, WellFormed.eraseWff w rfl⟩
@[specialize] def ofList : List ((k : α) × β k) → DRBMap α β cmp
| [] => mkDRBMap ..
| ⟨k,v⟩::xs => (ofList xs).insert k v
@[inline] def findCore? : DRBMap α β cmp → α → Option ((k : α) × β k)
| ⟨t, _⟩, x => t.findCore cmp x
@[inline] def find? [EqOfCmpWrt α β cmp] : DRBMap α β cmp → (k : α) → Option (β k)
| ⟨t, _⟩, x => RBNode.dFind cmp t x
@[inline] def findD [EqOfCmpWrt α β cmp] (t : DRBMap α β cmp) (k : α) (v₀ : β k) : β k :=
(t.find? k).getD v₀
/-- (lowerBound k) retrieves the kv pair of the largest key smaller than or equal to `k`,
if it exists. -/
@[inline] def lowerBound : DRBMap α β cmp → α → Option ((k : α) × β k)
| ⟨t, _⟩, x => t.lowerBound cmp x none
@[inline] def contains [EqOfCmpWrt α β cmp] (t : DRBMap α β cmp) (k : α) : Bool :=
(t.find? k).isSome
@[inline] def fromList (l : List ((k : α) × β k)) (cmp : αα → Ordering) : DRBMap α β cmp :=
l.foldl (fun r p => r.insert p.1 p.2) (mkDRBMap α β cmp)
@[inline] def all : DRBMap α β cmp → ((k : α) → β k → Bool) → Bool
| ⟨t, _⟩, p => t.all p
@[inline] def any : DRBMap α β cmp → ((k : α) → β k → Bool) → Bool
| ⟨t, _⟩, p => t.any p
def size (m : DRBMap α β cmp) : Nat :=
m.fold (fun sz _ _ => sz+1) 0
def maxDepth (t : DRBMap α β cmp) : Nat :=
t.val.depth Nat.max
@[inline] def min! [Inhabited ((k : α) × β k)] (t : DRBMap α β cmp) : (k : α) × β k :=
match t.min with
| some p => p
| none => panic! "map is empty"
@[inline] def max! [Inhabited ((k : α) × β k)] (t : DRBMap α β cmp) : (k : α) × β k :=
match t.max with
| some p => p
| none => panic! "map is empty"
@[inline] def find! [EqOfCmpWrt α β cmp] (t : DRBMap α β cmp) (k : α) [Inhabited (β k)] : β k :=
match t.find? k with
| some b => b
| none => panic! "key is not in the map"
end DRBMap
def drbmapOf {α : Type u} {β : α → Type v} (l : List ((k : α) × (β k))) (cmp : αα → Ordering) : DRBMap α β cmp :=
DRBMap.fromList l cmp

View file

@ -0,0 +1,22 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/-- An exception plus state monad transformer (ι.e., `ExceptT` + `StateT`). -/
abbrev EStateT.{u,v} (ε : Type u) (σ : Type u) (m : Type u → Type v) :=
ExceptT ε <| StateT σ m
namespace EStateT
variable {ε : Type u} {σ : Type u} {m : Type u → Type v}
@[inline] def run (init : σ) (self : EStateT ε σ m α) : m (Except ε α × σ) :=
ExceptT.run self |>.run init
@[inline] def run' [Functor m] (init : σ) (self : EStateT ε σ m α) : m (Except ε α) :=
ExceptT.run self |>.run' init
end EStateT

View file

@ -0,0 +1,92 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/--
A monad transformer that equips a monad with a value.
This is a generalization of `ReaderT` where the value is not
necessarily directly readable through the monad.
-/
def EquipT (ρ : Type u) (m : Type v → Type w) (α : Type v) :=
ρ → m α
variable {ρ : Type u} {m : Type v → Type w}
instance {α : Type v} [Inhabited (m α)] : Inhabited (EquipT ρ m α) where
default := fun _ => default
namespace EquipT
@[inline] protected
def run {α : Type v} (self : EquipT ρ m α) (r : ρ) : m α :=
self r
@[inline] protected
def map [Functor m] {α β : Type v} (f : α → β) (self : EquipT ρ m α) : EquipT ρ m β :=
fun fetch => Functor.map f (self fetch)
instance [Functor m] : Functor (EquipT ρ m) where
map := EquipT.map
@[inline] protected
def pure [Pure m] {α : Type v} (a : α) : EquipT ρ m α :=
fun _ => pure a
instance [Pure m] : Pure (EquipT ρ m) where
pure := EquipT.pure
@[inline] protected
def compose {α₁ α₂ β : Type v} (f : m α₁ → (Unit → m α₂) → m β) (x₁ : EquipT ρ m α₁) (x₂ : Unit → EquipT ρ m α₂) : EquipT ρ m β :=
fun fetch => f (x₁ fetch) (fun _ => x₂ () fetch)
@[inline] protected
def seq [Seq m] {α β : Type v} : EquipT ρ m (α → β) → (Unit → EquipT ρ m α) → EquipT ρ m β :=
EquipT.compose Seq.seq
instance [Seq m] : Seq (EquipT ρ m) where
seq := EquipT.seq
instance [Applicative m] : Applicative (EquipT ρ m) := {}
@[inline] protected
def bind [Bind m] {α β : Type v} (self : EquipT ρ m α) (f : α → EquipT ρ m β) : EquipT ρ m β :=
fun fetch => bind (self fetch) fun a => f a fetch
instance [Bind m] : Bind (EquipT ρ m) where
bind := EquipT.bind
instance [Monad m] : Monad (EquipT ρ m) := {}
@[inline] protected
def lift {α : Type v} (t : m α) : EquipT ρ m α :=
fun _ => t
instance : MonadLift m (EquipT ρ m) where
monadLift := EquipT.lift
@[inline] protected
def failure [Alternative m] {α : Type v} : EquipT ρ m α :=
fun _ => failure
@[inline] protected
def orElse [Alternative m] {α : Type v} : EquipT ρ m α → (Unit → EquipT ρ m α) → EquipT ρ m α :=
EquipT.compose Alternative.orElse
instance [Alternative m] : Alternative (EquipT ρ m) where
failure := EquipT.failure
orElse := EquipT.orElse
@[inline] protected
def throw {ε : Type v} [MonadExceptOf ε m] {α : Type v} (e : ε) : EquipT ρ m α :=
fun _ => throw e
@[inline] protected
def tryCatch {ε : Type v} [MonadExceptOf ε m] {α : Type v} (self : EquipT ρ m α) (c : ε → EquipT ρ m α) : EquipT ρ m α :=
fun f => tryCatchThe ε (self f) fun e => (c e) f
instance (ε) [MonadExceptOf ε m] : MonadExceptOf ε (EquipT ρ m) where
throw := EquipT.throw
tryCatch := EquipT.tryCatch

View file

@ -0,0 +1,41 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
class MonadError (m : Type u → Type v) where
error {α : Type u} : String → m α
export MonadError (error)
instance [MonadLift m n] [MonadError m] : MonadError n where
error msg := liftM (m := m) <| error msg
instance : MonadError IO where
error msg := throw <| IO.userError msg
instance : MonadError (EIO String) where
error msg := throw msg
instance : MonadError (Except String) where
error msg := throw msg
/--
Perform an EIO action.
If it throws an error, invoke `error` with its string representation.
-/
protected def MonadError.runEIO [Monad m]
[MonadError m] [MonadLiftT BaseIO m] [ToString ε] (x : EIO ε α) : m α := do
match (← x.toBaseIO) with
| Except.ok a => pure a
| Except.error e => error (toString e)
/--
Perform an IO action.
If it throws an error, invoke `error` with its string representation.
-/
@[inline] protected def MonadError.runIO
[Monad m] [MonadError m] [MonadLiftT BaseIO m] (x : IO α) : m α :=
MonadError.runEIO x

View file

@ -0,0 +1,21 @@
/-
Copyright (c) 2022 Mac Malone All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Elab.Eval
namespace Lake
open Lean Elab
unsafe def unsafeEvalTerm (α) [ToExpr α] (term : Syntax) : TermElabM α := do
Term.evalTerm α (toTypeExpr α) term .unsafe
@[implemented_by unsafeEvalTerm]
opaque evalTerm (α) [ToExpr α] (term : Syntax) : TermElabM α
/-! ## ToExpr Instances -/
instance : ToExpr System.FilePath where
toExpr p := mkApp (mkConst ``System.FilePath.mk) (toExpr p.toString)
toTypeExpr := mkConst ``System.FilePath

View file

@ -0,0 +1,21 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/-- A process exit / return code. -/
abbrev ExitCode := UInt32
class MonadExit (m : Type u → Type v) where
exit {α : Type u} : ExitCode → m α
export MonadExit (exit)
instance [MonadLift m n] [MonadExit m] : MonadExit n where
exit rc := liftM (m := m) <| exit rc
/-- Exit with `ExitCode` if it is not 0. Otherwise, continue. -/
@[inline] def exitIfErrorCode [Pure m] [MonadExit m] (rc : ExitCode) : m Unit :=
if rc != 0 then exit rc else pure ()

View file

@ -0,0 +1,178 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Parser.Command
/-!
# Open Type Families in Lean
This module contains utilities for defining **open type families** in Lean.
The concept of type families originated in Haskell with the paper
[*Type checking with open type functions*][1] by Schrijvers *et al.* and
is essentially just a fancy name for a function from an input *index* to an
output type. However, it tends to imply some additional restrictions on syntax
or functionality as opposed to a proper type function.The design here has some
such limitations so the name was similarly adopted.
Type families come in two forms: open and closed.
A *closed* type family is an ordinary total function.
An *open* type family, on the other hand, is a partial function that allows
additional input to output mappings to be defined as needed.
Lean does not (currently) directly support open type families.
However, it does support type class *functional dependencies* (via `outParam`),
and simple open type families can be modeled through functional dependencies,
which is what we do here.
[1]: https://doi.org/10.1145/1411204.1411215
## Defining Families
In this approach, to define an open type family, one first defines an `opaque`
type function with a single argument that serves as the key:
```lean
opaque FooFam (key : Name) : Type
```
Note that, unlike Haskell, the key need not be a type. Lean's dependent type
theory does not have Haskell's strict separation of types and data and thus
we can use data as an index as well.
Then, to add a mapping to this family, one defines an axioms:
```lean
axiom FooFam.bar : FooFam `bar = Nat
```
To finish, one also defines an instance of the `FamilyDef` type class
defined in this module using the axiom like so:
```lean
instance : FamilyDef FooFam `bar Nat := ⟨FooFam.bar⟩
```
This module provides a `family_def` macro to define both the axiom and the
instance in one go like so:
```lean
family_def bar : FooFam `bar := Nat
```
## Type Inference
The signature of the type class `FamilyDef` is
```
FamilyDef {α : Type u} (Fam : α → Type v) (a : α) (β : outParam $ Type v) : Prop
```
The key part being that `β` is an `outParam` so Lean's type class synthesis will
smartly infer the defined type `Nat` when given the key of `` `bar``. Thus, if
we have a function define like so:
```
def foo (key : α) [FamilyDef FooFam key β] : β := ...
```
Lean will smartly infer that the type of ``foo `bar`` is `Nat`.
However, filling in the right hand side of `foo` is not quite so easy.
``FooFam `bar = Nat`` is only true propositionally, so we have to manually
`cast` a `Nat` to ``FooFam `bar``and provide the proof (and the same is true
vice versa). Thus, this module provides two definitions, `toFamily : β → Fam a`
and `ofFamily : Fam a → β`, to help with this conversion.
## Full Example
Putting this all together, one can do something like the following:
```lean
opaque FooFam (key : Name) : Type
abbrev FooMap := DRBMap Name FooFam Name.quickCmp
def FooMap.insert (self : FooMap) (key : Name) [FamilyDef FooFam key α] (a : α) : FooMap :=
DRBMap.insert self key (toFamily a)
def FooMap.find? (self : FooMap) (key : Name) [FamilyDef FooFam key α] : Option α :=
ofFamily <$> DRBMap.find? self key
family_def bar : FooFam `bar := Nat
family_def baz : FooFam `baz := String
def foo := Id.run do
let mut map : FooMap := {}
map := map.insert `bar 5
map := map.insert `baz "str"
return map.find? `bar
#eval foo -- 5
```
## Type Safety
In order to maintain type safety, `a = b → Fam a = Fam b` must actually hold.
That is, one must not define mappings to two different types with equivalent
keys. Since mappings are defined through axioms, Lean WILL NOT catch violations
of this rule itself, so extra care must be taken when defining mappings.
In Lake, this is solved by having its open type families be indexed by a
`Lean.Name` and defining each mapping using a name literal `name` and the
declaration ``axiom Fam.name : Fam `name = α``. This causes a name clash
if two keys overlap and thereby produces an error.
-/
open Lean
namespace Lake
/-! ## API -/
/--
Defines a single mapping of the **open type family** `Fam`, namely `Fam a = β`.
See the module documentation of `Lake.Util.Family` for details on what an open
type family is in Lake.
-/
class FamilyDef {α : Type u} (Fam : α → Type v) (a : α) (β : semiOutParam $ Type v) : Prop where
family_key_eq_type : Fam a = β
/-- Like `FamilyDef`, but `β` is an `outParam`. -/
class FamilyOut {α : Type u} (Fam : α → Type v) (a : α) (β : outParam $ Type v) : Prop where
family_key_eq_type : Fam a = β
-- Simplifies proofs involving open type families
attribute [simp] FamilyOut.family_key_eq_type
instance [FamilyDef Fam a β] : FamilyOut Fam a β where
family_key_eq_type := FamilyDef.family_key_eq_type
/-- Cast a datum from its individual type to its general family. -/
@[macro_inline] def toFamily [FamilyOut Fam a β] (b : β) : Fam a :=
cast FamilyOut.family_key_eq_type.symm b
/-- Cast a datum from its general family to its individual type. -/
@[macro_inline] def ofFamily [FamilyOut Fam a β] (b : Fam a) : β :=
cast FamilyOut.family_key_eq_type b
/--
The syntax:
```lean
family_def foo : Fam 0 := Nat
```
Declares a new mapping for the open type family `Fam` type via the
production of an axiom `Fam.foo : Data 0 = Nat` and an instance of `FamilyDef`
that uses this axiom for key `0`.
-/
scoped macro (name := familyDef) doc?:optional(Parser.Command.docComment)
"family_def " id:ident " : " fam:ident key:term " := " ty:term : command => do
let tid := extractMacroScopes fam.getId |>.name
if let (tid, _) :: _ ← Macro.resolveGlobalName tid then
let app := Syntax.mkApp fam #[key]
let axm := mkIdentFrom fam <| `_root_ ++ tid ++ id.getId
`($[$doc?]? @[simp] axiom $axm : $app = $ty
instance : FamilyDef $fam $key $ty := ⟨$axm⟩)
else
Macro.throwErrorAt fam s!"unknown family '{tid}'"

111
src/lake/Lake/Util/Git.lean Normal file
View file

@ -0,0 +1,111 @@
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake.Util.Proc
import Lake.Util.Lift
open System
namespace Lake
namespace Git
def defaultRemote :=
"origin"
def upstreamBranch :=
"master"
/--
Try to turn a remote URL into a URL that can be used to e.g.,
make GitHub API requests. That is, do not accept SSH URLS and
drop an ending `.git`.
-/
def filterUrl? (url : String) : Option String :=
if url.startsWith "git" then
none
else if url.endsWith ".git" then
some <| url.dropRight 4
else
some url
def isFullObjectName (rev : String) : Bool :=
rev.length == 40 && rev.all fun c => c.isDigit || ('a' <= c && c <= 'f')
end Git
structure GitRepo where
dir : FilePath
instance : ToString GitRepo := ⟨(·.dir.toString)⟩
namespace GitRepo
def cwd : GitRepo := ⟨"."⟩
@[inline] def dirExists (repo : GitRepo) : BaseIO Bool :=
repo.dir.isDir
@[inline] def captureGit (args : Array String) (repo : GitRepo) : LogIO String :=
captureProc {cmd := "git", args, cwd := repo.dir}
@[inline] def captureGit? (args : Array String) (repo : GitRepo) : BaseIO (Option String) :=
captureProc? {cmd := "git", args, cwd := repo.dir}
@[inline] def execGit (args : Array String) (repo : GitRepo) : LogIO PUnit :=
proc {cmd := "git", args, cwd := repo.dir} (quiet := true)
@[inline] def testGit (args : Array String) (repo : GitRepo) : BaseIO Bool :=
testProc {cmd := "git", args, cwd := repo.dir}
@[inline] def clone (url : String) (repo : GitRepo) : LogIO PUnit :=
proc {cmd := "git", args := #["clone", url, repo.dir.toString]} (quiet := true)
@[inline] def quietInit (repo : GitRepo) : LogIO PUnit :=
repo.execGit #["init", "-q"]
@[inline] def fetch (repo : GitRepo) (remote := Git.defaultRemote) : LogIO PUnit :=
repo.execGit #["fetch", remote]
@[inline] def checkoutBranch (branch : String) (repo : GitRepo) : LogIO PUnit :=
repo.execGit #["checkout", "-B", branch]
@[inline] def checkoutDetach (hash : String) (repo : GitRepo) : LogIO PUnit :=
repo.execGit #["checkout", "--detach", hash]
@[inline] def resolveRevision? (rev : String) (repo : GitRepo) : BaseIO (Option String) := do
repo.captureGit? #["rev-parse", "--verify", rev]
@[inline] def resolveRevision (rev : String) (repo : GitRepo) : LogIO String := do
repo.captureGit #["rev-parse", "--verify", rev]
@[inline] def headRevision (repo : GitRepo) : LogIO String :=
repo.resolveRevision "HEAD"
@[inline] def headRevision? (repo : GitRepo) : BaseIO (Option String) :=
repo.resolveRevision? "HEAD"
def resolveRemoteRevision (rev : String) (remote := Git.defaultRemote) (repo : GitRepo) : LogIO String := do
if Git.isFullObjectName rev then return rev
if let some rev ← repo.resolveRevision? s!"{remote}/{rev}" then return rev
if let some rev ← repo.resolveRevision? rev then return rev
error s!"cannot find revision {rev} in repository {repo}"
def findRemoteRevision (repo : GitRepo) (rev? : Option String := none) (remote := Git.defaultRemote) : LogIO String := do
repo.fetch remote; repo.resolveRemoteRevision (rev?.getD Git.upstreamBranch) remote
@[inline] def branchExists (rev : String) (repo : GitRepo) : BaseIO Bool := do
repo.testGit #["show-ref", "--verify", s!"refs/heads/{rev}"]
@[inline] def revisionExists (rev : String) (repo : GitRepo) : BaseIO Bool := do
repo.testGit #["rev-parse", "--verify", rev ++ "^{commit}"]
@[inline] def findTag? (rev : String := "HEAD") (repo : GitRepo) : BaseIO (Option String) := do
repo.captureGit? #["describe", "--tags", "--exact-match", rev]
@[inline] def getRemoteUrl? (remote := Git.defaultRemote) (repo : GitRepo) : BaseIO (Option String) := do
repo.captureGit? #["remote", "get-url", remote]
def getFilteredRemoteUrl? (remote := Git.defaultRemote) (repo : GitRepo) : BaseIO (Option String) := OptionT.run do
Git.filterUrl? (← repo.getRemoteUrl? remote)

View file

@ -0,0 +1,39 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.OptionIO
namespace Lake
instance [Pure m] : MonadLiftT Id m where
monadLift act := pure act.run
instance [Alternative m] : MonadLiftT Option m where
monadLift
| some a => pure a
| none => failure
instance [Pure m] [MonadExceptOf ε m] : MonadLiftT (Except ε) m where
monadLift
| .ok a => pure a
| .error e => throw e
instance [Bind m] [MonadReaderOf ρ m] [MonadLiftT n m] : MonadLiftT (ReaderT ρ n) m where
monadLift act := do act (← read)
instance [Monad m] [MonadStateOf σ m] [MonadLiftT n m] : MonadLiftT (StateT σ n) m where
monadLift act := do let (a, s) ← act (← get); set s; pure a
instance [Monad m] [Alternative m] [MonadLiftT n m] : MonadLiftT (OptionT n) m where
monadLift act := act.run >>= liftM
instance [Monad m] [MonadExceptOf ε m] [MonadLiftT n m] : MonadLiftT (ExceptT ε n) m where
monadLift act := act.run >>= liftM
instance [Monad m] [MonadExceptOf ε m] [MonadLiftT BaseIO m] : MonadLiftT (EIO ε) m where
monadLift act := act.toBaseIO >>= liftM
instance [Monad m] [Alternative m] [MonadLiftT BaseIO m] : MonadLiftT OptionIO m where
monadLift act := act.toBaseIO >>= liftM

112
src/lake/Lake/Util/Log.lean Normal file
View file

@ -0,0 +1,112 @@
/-
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.Util.Error
import Lake.Util.OptionIO
namespace Lake
inductive LogLevel
| info
| warning
| error
inductive Verbosity : Type u
| quiet
| normal
| verbose
deriving BEq
instance : Inhabited Verbosity := ⟨.normal⟩
/-! # Class -/
class MonadLog (m : Type u → Type v) where
getVerbosity : m Verbosity
log (message : String) (level : LogLevel) : m PUnit
export MonadLog (log getVerbosity)
def getIsVerbose [Functor m] [MonadLog m] : m Bool :=
getVerbosity <&> (· == .verbose)
def getIsQuiet [Functor m] [MonadLog m] : m Bool :=
getVerbosity <&> (· == .quiet)
@[inline] def logVerbose [Monad m] [MonadLog m] (message : String) : m PUnit := do
if (← getIsVerbose) then log message .info
@[inline] def logInfo [Monad m] [MonadLog m] (message : String) : m PUnit := do
if !(← getIsQuiet) then log message .info
abbrev logWarning [MonadLog m] (message : String) : m PUnit :=
log message .warning
abbrev logError [MonadLog m] (message : String) : m PUnit :=
log message .error
namespace MonadLog
def nop [Pure m] : MonadLog m :=
⟨pure .normal, fun _ _ => pure ()⟩
instance [Pure m] : Inhabited (MonadLog m) := ⟨MonadLog.nop⟩
def io [MonadLiftT BaseIO m] (verbosity := Verbosity.normal) : MonadLog m where
getVerbosity := (pure verbosity : BaseIO _)
log msg
| .info => IO.println msg.trim |>.catchExceptions fun _ => pure ()
| .warning => IO.eprintln s!"warning: {msg.trim}" |>.catchExceptions fun _ => pure ()
| .error => IO.eprintln s!"error: {msg.trim}" |>.catchExceptions fun _ => pure ()
def eio [MonadLiftT BaseIO m] (verbosity := Verbosity.normal) : MonadLog m where
getVerbosity := (pure verbosity : BaseIO _)
log msg
| .info => IO.eprintln s!"info: {msg.trim}" |>.catchExceptions fun _ => pure ()
| .warning => IO.eprintln s!"warning: {msg.trim}" |>.catchExceptions fun _ => pure ()
| .error => IO.eprintln s!"error: {msg.trim}" |>.catchExceptions fun _ => pure ()
def lift [MonadLiftT m n] (self : MonadLog m) : MonadLog n where
getVerbosity := liftM <| self.getVerbosity
log msg lv := liftM <| self.log msg lv
instance [MonadLift m n] [methods : MonadLog m] : MonadLog n := lift methods
/-- Log the given error message and then fail. -/
protected def error [Alternative m] [MonadLog m] (msg : String) : m α :=
logError msg *> failure
end MonadLog
/-! # Transformers -/
abbrev MonadLogT (m : Type u → Type v) (n : Type v → Type w) :=
ReaderT (MonadLog m) n
instance [Pure n] [Inhabited α] : Inhabited (MonadLogT m n α) :=
⟨fun _ => pure Inhabited.default⟩
instance [Monad n] [MonadLiftT m n] : MonadLog (MonadLogT m n) where
getVerbosity := do (← read).getVerbosity
log msg lv := do (← read).log msg lv
abbrev MonadLogT.adaptMethods [Monad n]
(f : MonadLog m → MonadLog m') (self : MonadLogT m' n α) : MonadLogT m n α :=
ReaderT.adapt f self
abbrev MonadLogT.ignoreLog [Pure m] (self : MonadLogT m n α) : n α :=
self MonadLog.nop
abbrev LogIO :=
MonadLogT BaseIO OptionIO
instance : MonadError LogIO := ⟨MonadLog.error⟩
instance : MonadLift IO LogIO := ⟨MonadError.runIO⟩
def LogIO.captureLog (self : LogIO α) (verbosity := Verbosity.normal) : BaseIO (String × Option α) :=
IO.FS.withIsolatedStreams <| self (MonadLog.eio verbosity) |>.toBaseIO
abbrev LogT (m : Type → Type) :=
MonadLogT m m

View file

@ -0,0 +1,82 @@
/-
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.Util.Log
import Lake.Util.Exit
import Lake.Util.Error
import Lake.Util.Lift
namespace Lake
/--
The monad in Lake for `main`-like functions.
Supports IO, logging, and `exit`.
-/
def MainM := EIO ExitCode
instance : Monad MainM := inferInstanceAs (Monad (EIO ExitCode))
instance : MonadFinally MainM := inferInstanceAs (MonadFinally (EIO ExitCode))
instance : MonadLift BaseIO MainM := inferInstanceAs (MonadLift BaseIO (EIO ExitCode))
namespace MainM
/-! # Basics -/
@[inline] protected def mk (x : EIO ExitCode α) : MainM α :=
x
@[inline] protected def toEIO (self : MainM α) : EIO ExitCode α :=
self
@[inline] protected def toBaseIO (self : MainM α) : BaseIO (Except ExitCode α) :=
self.toEIO.toBaseIO
protected def run (self : MainM α) : BaseIO ExitCode :=
self.toBaseIO.map fun | Except.ok _ => 0 | Except.error rc => rc
/-! # Exits -/
/-- Exit with given return code. -/
protected def exit (rc : ExitCode) : MainM α :=
MainM.mk <| throw rc
instance : MonadExit MainM := ⟨MainM.exit⟩
/-- Try this and catch exits. -/
protected def tryCatchExit (f : ExitCode → MainM α) (self : MainM α) : MainM α :=
self.toEIO.tryCatch f
/-- Try this and catch error codes (i.e., non-zero exits). -/
protected def tryCatchError (f : ExitCode → MainM α) (self : MainM α) : MainM α :=
self.tryCatchExit fun rc => if rc = 0 then exit 0 else f rc
/-- Exit with a generic error code (i.e., 1). -/
protected def failure : MainM α :=
exit 1
/-- If this exits with an error code (i.e., not 0), perform other. -/
protected def orElse (self : MainM α) (other : Unit → MainM α) : MainM α :=
self.tryCatchExit fun rc => if rc = 0 then exit 0 else other ()
instance : Alternative MainM where
failure := MainM.failure
orElse := MainM.orElse
/-! # Logging and IO -/
instance : MonadLog MainM := MonadLog.eio
/-- Print out a error line with the given message and then exit with an error code. -/
protected def error (msg : String) (rc : ExitCode := 1) : MainM α := do
logError msg
exit rc
instance : MonadError MainM := ⟨MainM.error⟩
instance : MonadLift IO MainM := ⟨MonadError.runEIO⟩
def runLogIO (x : LogIO α) (verbosity := Verbosity.normal) : MainM α :=
liftM <| x.run <| MonadLog.eio verbosity
instance : MonadLift LogIO MainM := ⟨runLogIO⟩

View file

@ -0,0 +1,72 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Data.NameMap
import Lake.Util.Compare
open Lean
namespace Lake
export Lean (Name NameMap)
@[inline] def NameMap.empty : NameMap α := RBMap.empty
instance : ForIn m (NameMap α) (Name × α) where
forIn self init f := self.forIn init f
/-! # Name Helpers -/
namespace Name
open Lean.Name
@[simp] protected theorem beq_false (m n : Name) : (m == n) = false ↔ ¬ (m = n) := by
rw [← beq_iff_eq m n]; cases m == n <;> simp (config := { decide := true })
@[simp] theorem isPrefixOf_self {n : Name} : n.isPrefixOf n := by
cases n <;> simp [isPrefixOf]
@[simp] theorem isPrefixOf_append {n m : Name} : ¬ n.hasMacroScopes → ¬ m.hasMacroScopes → n.isPrefixOf (n ++ m) := by
intro h1 h2
show n.isPrefixOf (n.append m)
simp_all [Name.append]
clear h2; induction m <;> simp [*, Name.appendCore, isPrefixOf]
@[simp] theorem quickCmpAux_iff_eq : ∀ {n n'}, quickCmpAux n n' = .eq ↔ n = n'
| .anonymous, n => by cases n <;> simp [quickCmpAux]
| n, .anonymous => by cases n <;> simp [quickCmpAux]
| .num .., .str .. => by simp [quickCmpAux]
| .str .., .num .. => by simp [quickCmpAux]
| .num p₁ n₁, .num p₂ n₂ => by
simp only [quickCmpAux]; split <;>
simp_all [quickCmpAux_iff_eq, show ∀ p, (p → False) ↔ ¬ p from fun _ => .rfl]
| .str p₁ s₁, .str p₂ s₂ => by
simp only [quickCmpAux]; split <;>
simp_all [quickCmpAux_iff_eq, show ∀ p, (p → False) ↔ ¬ p from fun _ => .rfl]
instance : LawfulCmpEq Name quickCmpAux where
eq_of_cmp := quickCmpAux_iff_eq.mp
cmp_rfl := quickCmpAux_iff_eq.mpr rfl
theorem eq_of_quickCmp {n n' : Name} : n.quickCmp n' = .eq → n = n' := by
unfold Name.quickCmp
intro h_cmp; split at h_cmp
next => exact eq_of_cmp h_cmp
next => contradiction
theorem quickCmp_rfl {n : Name} : n.quickCmp n = .eq := by
unfold Name.quickCmp
split <;> exact cmp_rfl
instance : LawfulCmpEq Name Name.quickCmp where
eq_of_cmp := eq_of_quickCmp
cmp_rfl := quickCmp_rfl
open Syntax
def quoteFrom (ref : Syntax) : Name → Term
| .anonymous => mkCIdentFrom ref ``anonymous
| .str p s => mkApp (mkCIdentFrom ref ``mkStr) #[quoteFrom ref p, quote s]
| .num p v => mkApp (mkCIdentFrom ref ``mkNum) #[quoteFrom ref p, quote v]

View file

@ -0,0 +1,42 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
open System
namespace Lake
/-- The shared library file extension for the `Platform`. -/
def sharedLibExt : String :=
if Platform.isWindows then "dll"
else if Platform.isOSX then "dylib"
else "so"
/-- Convert a library name into its static library file name for the `Platform`. -/
def nameToStaticLib (name : String) : String :=
if Platform.isWindows then s!"{name}.a" else s!"lib{name}.a"
/-- Convert a library name into its shared library file name for the `Platform`. -/
def nameToSharedLib (name : String) : String :=
if Platform.isWindows then s!"{name}.dll"
else if Platform.isOSX then s!"lib{name}.dylib"
else s!"lib{name}.so"
/--
The environment variable that stores the search path
used to find shared libraries on the `Platform`.
-/
def sharedLibPathEnvVar :=
if Platform.isWindows then
"PATH"
else if Platform.isOSX then
"DYLD_LIBRARY_PATH"
else
"LD_LIBRARY_PATH"
/-- Gets a `SearchPath` from an environment variable. -/
def getSearchPath (envVar : String) : BaseIO SearchPath := do
match (← IO.getEnv envVar) with
| some path => pure <| SearchPath.parse path
| none => pure []

View file

@ -0,0 +1,52 @@
/-
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.Util.Binder
import Lean.Parser.Command
/-!
This module provides utilities for defining simple opaque types
for forward declarations. Types are first declared with `declare_opaque_type`
and then later filled in with `hydrate_opaque_type` once the corresponding
non-opaque type has been defined.
-/
namespace Lake
open Lean Parser Command
macro (name := declareOpaqueType)
doc?:optional(docComment) "declare_opaque_type " id:ident bs:binder* : command => do
let (bs, args) ← expandBinders bs
let nonemptyTypeId := id.getId.modifyBase (· ++ `nonemptyType)
let nonemptyType := mkIdentFrom id nonemptyTypeId
let nonemptyTypeApp := Syntax.mkApp nonemptyType args
`(
opaque $nonemptyType $[$bs]* : NonemptyType.{0}
$[$doc?:docComment]? def $id $[$bs]* : Type := $nonemptyTypeApp |>.type
instance : Nonempty $(Syntax.mkApp id args) := $nonemptyTypeApp |>.property
)
macro (name := hydrateOpaqueType)
"hydrate_opaque_type " oty:ident ty:ident args:ident* : command =>
let mk := mkIdent `mk
let unsafeMk := mkIdent `unsafeMk
let get := mkIdent `get
let unsafeGet := mkIdent `unsafeGet
let get_mk := mkIdent `get_mk
`(
namespace $oty
unsafe def $unsafeMk : $ty $args* → $oty $args* := unsafeCast
@[implemented_by $unsafeMk] opaque $mk : $ty $args* → $oty $args*
instance : Coe ($ty $args*) ($oty $args*) := ⟨$mk⟩
unsafe def $unsafeGet : $oty $args* → $ty $args* := unsafeCast
@[implemented_by $unsafeGet] opaque $get $[{$args}]* : $oty $args* → $ty $args*
instance : Coe ($oty $args*) ($ty $args*) := ⟨$get⟩
instance [Inhabited ($ty $args*)] : Inhabited ($oty $args*) := ⟨$mk default⟩
@[simp] axiom $get_mk $[{$args}]* {x : $ty $args*} : $get ($mk x) = x
end $oty
)

View file

@ -0,0 +1,44 @@
/-
Copyright (c) 2021 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/-- Conceptually identical `OptionT BaseIO`, but practically more efficient. -/
def OptionIO := EIO PUnit
instance : Monad OptionIO := inferInstanceAs (Monad (EIO PUnit))
instance : MonadLift BaseIO OptionIO := inferInstanceAs (MonadLift BaseIO (EIO PUnit))
namespace OptionIO
@[inline] def mk (x : EIO PUnit α) : OptionIO α :=
x
@[inline] def toBaseIO (self : OptionIO α) : BaseIO (Option α) :=
fun s => match self s with
| EStateM.Result.ok a s => EStateM.Result.ok (some a) s
| EStateM.Result.error _ s => EStateM.Result.ok none s
@[inline] def toEIO (self : OptionIO α) : EIO PUnit α :=
self
@[inline] def toIO (f : Unit → IO.Error) (self : OptionIO α) : IO α :=
self.toEIO.toIO f
@[inline] def catchFailure (f : Unit → BaseIO α) (self : OptionIO α) : BaseIO α :=
self.toEIO.catchExceptions f
protected def failure : OptionIO α :=
mk <| throw ()
protected def orElse (self : OptionIO α) (f : Unit → OptionIO α) : OptionIO α :=
mk <| tryCatch self.toEIO f
instance : Alternative OptionIO where
failure := OptionIO.failure
orElse := OptionIO.orElse
def asTask (self : OptionIO α) (prio := Task.Priority.dedicated) : BaseIO (Task (Option α)) :=
self.toBaseIO.asTask prio

View file

@ -0,0 +1,56 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Data.HashSet
open Lean
namespace Lake
/-- A `HashSet` that preserves insertion order. -/
structure OrdHashSet (α) [Hashable α] [BEq α] where
toHashSet : HashSet α
toArray : Array α
namespace OrdHashSet
variable [Hashable α] [BEq α]
def empty : OrdHashSet α :=
⟨.empty, .empty⟩
def mkEmpty (size : Nat) : OrdHashSet α :=
⟨.empty, .mkEmpty size⟩
def insert (self : OrdHashSet α) (a : α) : OrdHashSet α :=
if self.toHashSet.contains a then
self
else
⟨self.toHashSet.insert a, self.toArray.push a⟩
def appendArray (self : OrdHashSet α) (arr : Array α) :=
arr.foldl (·.insert ·) self
instance : HAppend (OrdHashSet α) (Array α) (OrdHashSet α) := ⟨OrdHashSet.appendArray⟩
protected def append (self other : OrdHashSet α) :=
self.appendArray other.toArray
instance : Append (OrdHashSet α) := ⟨OrdHashSet.append⟩
def ofArray (arr : Array α) : OrdHashSet α :=
mkEmpty arr.size |>.appendArray arr
@[inline] def foldl (f : β → α → β) (init : β) (self : OrdHashSet α) : β :=
self.toArray.foldl f init
@[inline] def foldlM [Monad m] (f : β → α → m β) (init : β) (self : OrdHashSet α) : m β :=
self.toArray.foldlM f init
@[inline] def foldr (f : α → β → β) (init : β) (self : OrdHashSet α) : β :=
self.toArray.foldr f init
@[inline] def foldrM [Monad m] (f : α → β → m β) (init : β) (self : OrdHashSet α) : m β :=
self.toArray.foldrM f init

View file

@ -0,0 +1,45 @@
/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import Lean.Attributes
open Lean
namespace Lake
structure OrderedTagAttribute where
attr : AttributeImpl
ext : PersistentEnvExtension Name Name (Array Name)
deriving Inhabited
def registerOrderedTagAttribute (name : Name) (descr : String)
(validate : Name → AttrM Unit := fun _ => pure ()) (ref : Name := by exact decl_name%) : IO OrderedTagAttribute := do
let ext ← registerPersistentEnvExtension {
name := ref
mkInitial := pure {}
addImportedFn := fun _ _ => pure {}
addEntryFn := fun s n => s.push n
exportEntriesFn := fun es => es
statsFn := fun s => "tag attribute" ++ Format.line ++ "number of local entries: " ++ format s.size
}
let attrImpl : AttributeImpl := {
ref := ref
name := name
descr := descr
add := fun decl stx kind => do
Attribute.Builtin.ensureNoArgs stx
unless kind == AttributeKind.global do throwError "invalid attribute '{name}', must be global"
let env ← getEnv
unless (env.getModuleIdxFor? decl).isNone do
throwError "invalid attribute '{name}', declaration is in an imported module"
validate decl
modifyEnv fun env => ext.addEntry env decl
}
registerBuiltinAttribute attrImpl
return { attr := attrImpl, ext }
def OrderedTagAttribute.hasTag (attr : OrderedTagAttribute) (env : Environment) (decl : Name) : Bool :=
match env.getModuleIdxFor? decl with
| some modIdx => (attr.ext.getModuleEntries env modIdx).binSearchContains decl Name.quickLt
| none => (attr.ext.getState env).contains decl

View file

@ -0,0 +1,70 @@
/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich, Mac Malone
-/
import Lake.Util.Log
namespace Lake
@[specialize] def logProcCmd [Monad m]
(args : IO.Process.SpawnArgs) (log : String → m PUnit) : m Unit := do
let envStr := String.join <| args.env.toList.map fun (k, v) =>
if k == "PATH" then "PATH " else s!"{k}={v.getD ""} " -- PATH too big
let cmdStr := " ".intercalate (args.cmd :: args.args.toList)
log <| "> " ++ envStr ++
match args.cwd with
| some cwd => s!"{cmdStr} # in directory {cwd}"
| none => cmdStr
@[specialize] def logProcOutput [Monad m]
(out : IO.Process.Output) (log : String → m PUnit) : m Unit := do
unless out.stdout.isEmpty do
log s!"stdout:\n{out.stdout}"
unless out.stderr.isEmpty do
log s!"stderr:\n{out.stderr}"
@[specialize] def logProcWith [Monad m]
(args : IO.Process.SpawnArgs) (out : IO.Process.Output)
(log : String → m PUnit) (logOutput := log) : m Unit := do
logProcCmd args log
logProcOutput out logOutput
def proc (args : IO.Process.SpawnArgs) (quiet := false) : LogIO Unit := do
match (← IO.Process.output args |>.toBaseIO) with
| .ok out =>
if out.exitCode = 0 then
logProcWith args out logVerbose (logOutput := if quiet then logVerbose else logInfo)
else
logProcWith args out logError
error s!"external command `{args.cmd}` exited with code {out.exitCode}"
| .error err =>
error s!"failed to execute `{args.cmd}`: {err}"
def captureProc (args : IO.Process.SpawnArgs) : LogIO String := do
match (← IO.Process.output args |>.toBaseIO) with
| .ok out =>
if out.exitCode = 0 then
return out.stdout.trim -- remove, e.g., newline at end
else
logProcWith args out logError
error s!"external command `{args.cmd}` exited with code {out.exitCode}"
| .error err =>
error s!"failed to execute `{args.cmd}`: {err}"
def captureProc? (args : IO.Process.SpawnArgs) : BaseIO (Option String) := do
EIO.catchExceptions (h := fun _ => pure none) do
let out ← IO.Process.output args
if out.exitCode = 0 then
return some out.stdout.trim -- remove, e.g., newline at end
else
return none
def testProc (args : IO.Process.SpawnArgs) : BaseIO Bool :=
EIO.catchExceptions (h := fun _ => pure false) do
let child ← IO.Process.spawn {
args with
stdout := IO.Process.Stdio.null
stderr := IO.Process.Stdio.null
}
return (← child.wait) == 0

View file

@ -0,0 +1,38 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
namespace Lake
/-- A monad equipped with a dependently typed key-value store for a particular key. -/
class MonadStore1 {κ : Type u} (k : κ) (α : outParam $ Type v) (m : Type v → Type w) where
fetch? : m (Option α)
store : α → m PUnit
export MonadStore1 (fetch? store)
/-- A monad equipped with a dependently typed key-object store. -/
class MonadDStore (κ : Type u) (β : outParam $ κ → Type v) (m : Type v → Type w) where
fetch? : (key : κ) → m (Option (β key))
store : (key : κ) → β key → m PUnit
instance [MonadDStore κ β m] : MonadStore1 k (β k) m where
fetch? := MonadDStore.fetch? k
store o := MonadDStore.store k o
/-- A monad equipped with a key-object store. -/
abbrev MonadStore κ α m := MonadDStore κ (fun _ => α) m
instance [MonadLift m n] [MonadDStore κ β m] : MonadDStore κ β n where
fetch? k := liftM (m := m) <| fetch? k
store k a := liftM (m := m) <| store k a
@[inline] def fetchOrCreate [Monad m]
(key : κ) [MonadStore1 key α m] (create : m α) : m α := do
if let some val ← fetch? key then
return val
else
let val ← create
store key val
return val

View file

@ -0,0 +1,26 @@
/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.DRBMap
import Lake.Util.Family
import Lake.Util.Store
open Lean
namespace Lake
instance [Monad m] [EqOfCmpWrt κ β cmp] : MonadDStore κ β (StateT (DRBMap κ β cmp) m) where
fetch? k := return (← get).find? k
store k a := modify (·.insert k a)
instance [Monad m] : MonadStore κ α (StateT (RBMap κ α cmp) m) where
fetch? k := return (← get).find? k
store k a := modify (·.insert k a)
instance [Monad m] : MonadStore Name α (StateT (NameMap α) m) :=
inferInstanceAs (MonadStore _ _ (StateT (RBMap ..) _))
@[inline] instance [MonadDStore κ β m] [t : FamilyOut β k α] : MonadStore1 k α m where
fetch? := cast (by rw [t.family_key_eq_type]) <| fetch? (m := m) k
store a := store k <| cast t.family_key_eq_type.symm a

Some files were not shown because too many files have changed in this diff Show more