diff --git a/stage0/.gitattributes b/stage0/.gitattributes deleted file mode 100644 index 2231a26365..0000000000 --- a/stage0/.gitattributes +++ /dev/null @@ -1 +0,0 @@ -* -text -diff linguist-generated=true diff --git a/stage0/library/CMakeLists.txt b/stage0/library/CMakeLists.txt deleted file mode 100644 index 57f7944e81..0000000000 --- a/stage0/library/CMakeLists.txt +++ /dev/null @@ -1 +0,0 @@ -add_library (stage0 OBJECT ./Init/Coe.c ./Init/Control.c ./Init/Control/Alternative.c ./Init/Control/Applicative.c ./Init/Control/Conditional.c ./Init/Control/EState.c ./Init/Control/Except.c ./Init/Control/Functor.c ./Init/Control/Id.c ./Init/Control/Lift.c ./Init/Control/Monad.c ./Init/Control/MonadFail.c ./Init/Control/Option.c ./Init/Control/Reader.c ./Init/Control/State.c ./Init/Core.c ./Init/Data.c ./Init/Data/Array.c ./Init/Data/Array/Basic.c ./Init/Data/Array/BinSearch.c ./Init/Data/Array/QSort.c ./Init/Data/AssocList.c ./Init/Data/Basic.c ./Init/Data/BinomialHeap.c ./Init/Data/BinomialHeap/Basic.c ./Init/Data/ByteArray.c ./Init/Data/ByteArray/Basic.c ./Init/Data/Char.c ./Init/Data/Char/Basic.c ./Init/Data/DList.c ./Init/Data/Fin.c ./Init/Data/Fin/Basic.c ./Init/Data/HashMap.c ./Init/Data/HashMap/Basic.c ./Init/Data/HashSet.c ./Init/Data/Hashable.c ./Init/Data/Int.c ./Init/Data/Int/Basic.c ./Init/Data/List.c ./Init/Data/List/Basic.c ./Init/Data/List/BasicAux.c ./Init/Data/List/Control.c ./Init/Data/List/Instances.c ./Init/Data/Nat.c ./Init/Data/Nat/Basic.c ./Init/Data/Nat/Bitwise.c ./Init/Data/Nat/Control.c ./Init/Data/Nat/Div.c ./Init/Data/Option.c ./Init/Data/Option/Basic.c ./Init/Data/Option/BasicAux.c ./Init/Data/Option/Instances.c ./Init/Data/PersistentArray.c ./Init/Data/PersistentArray/Basic.c ./Init/Data/PersistentHashMap.c ./Init/Data/PersistentHashMap/Basic.c ./Init/Data/PersistentHashSet.c ./Init/Data/Queue.c ./Init/Data/Queue/Basic.c ./Init/Data/RBMap.c ./Init/Data/RBMap/Basic.c ./Init/Data/RBMap/BasicAux.c ./Init/Data/RBTree.c ./Init/Data/RBTree/Basic.c ./Init/Data/Random.c ./Init/Data/Repr.c ./Init/Data/Stack.c ./Init/Data/Stack/Basic.c ./Init/Data/String.c ./Init/Data/String/Basic.c ./Init/Data/ToString.c ./Init/Data/UInt.c ./Init/Default.c ./Init/Fix.c ./Init/Lean.c ./Init/Lean/Attributes.c ./Init/Lean/AuxRecursor.c ./Init/Lean/Class.c ./Init/Lean/Compiler.c ./Init/Lean/Compiler/ClosedTermCache.c ./Init/Lean/Compiler/ConstFolding.c ./Init/Lean/Compiler/ExportAttr.c ./Init/Lean/Compiler/ExternAttr.c ./Init/Lean/Compiler/IR.c ./Init/Lean/Compiler/IR/Basic.c ./Init/Lean/Compiler/IR/Borrow.c ./Init/Lean/Compiler/IR/Boxing.c ./Init/Lean/Compiler/IR/Checker.c ./Init/Lean/Compiler/IR/CompilerM.c ./Init/Lean/Compiler/IR/CtorLayout.c ./Init/Lean/Compiler/IR/ElimDeadBranches.c ./Init/Lean/Compiler/IR/ElimDeadVars.c ./Init/Lean/Compiler/IR/EmitC.c ./Init/Lean/Compiler/IR/EmitUtil.c ./Init/Lean/Compiler/IR/ExpandResetReuse.c ./Init/Lean/Compiler/IR/Format.c ./Init/Lean/Compiler/IR/FreeVars.c ./Init/Lean/Compiler/IR/LiveVars.c ./Init/Lean/Compiler/IR/NormIds.c ./Init/Lean/Compiler/IR/PushProj.c ./Init/Lean/Compiler/IR/RC.c ./Init/Lean/Compiler/IR/ResetReuse.c ./Init/Lean/Compiler/IR/SimpCase.c ./Init/Lean/Compiler/IR/UnboxResult.c ./Init/Lean/Compiler/ImplementedByAttr.c ./Init/Lean/Compiler/InitAttr.c ./Init/Lean/Compiler/InlineAttrs.c ./Init/Lean/Compiler/NameMangling.c ./Init/Lean/Compiler/NeverExtractAttr.c ./Init/Lean/Compiler/Specialize.c ./Init/Lean/Compiler/Util.c ./Init/Lean/Declaration.c ./Init/Lean/Elaborator.c ./Init/Lean/Elaborator/Alias.c ./Init/Lean/Elaborator/Basic.c ./Init/Lean/Elaborator/Command.c ./Init/Lean/Elaborator/ElabStrategyAttrs.c ./Init/Lean/Elaborator/PreTerm.c ./Init/Lean/Elaborator/ResolveName.c ./Init/Lean/Elaborator/Term.c ./Init/Lean/Environment.c ./Init/Lean/EqnCompiler.c ./Init/Lean/EqnCompiler/MatchPattern.c ./Init/Lean/Expr.c ./Init/Lean/Format.c ./Init/Lean/KVMap.c ./Init/Lean/LBool.c ./Init/Lean/LOption.c ./Init/Lean/Level.c ./Init/Lean/Linter.c ./Init/Lean/LocalContext.c ./Init/Lean/Message.c ./Init/Lean/Meta.c ./Init/Lean/Meta/Basic.c ./Init/Lean/Meta/Check.c ./Init/Lean/Meta/Exception.c ./Init/Lean/Meta/ExprDefEq.c ./Init/Lean/Meta/FunInfo.c ./Init/Lean/Meta/InferType.c ./Init/Lean/Meta/LevelDefEq.c ./Init/Lean/Meta/Offset.c ./Init/Lean/Meta/WHNF.c ./Init/Lean/MetavarContext.c ./Init/Lean/Modifiers.c ./Init/Lean/MonadCache.c ./Init/Lean/Name.c ./Init/Lean/NameGenerator.c ./Init/Lean/Options.c ./Init/Lean/Parser.c ./Init/Lean/Parser/Command.c ./Init/Lean/Parser/Identifier.c ./Init/Lean/Parser/Level.c ./Init/Lean/Parser/Module.c ./Init/Lean/Parser/Parser.c ./Init/Lean/Parser/Term.c ./Init/Lean/Parser/Transform.c ./Init/Lean/Parser/Trie.c ./Init/Lean/Path.c ./Init/Lean/Position.c ./Init/Lean/ProjFns.c ./Init/Lean/ReducibilityAttrs.c ./Init/Lean/Runtime.c ./Init/Lean/SMap.c ./Init/Lean/Scopes.c ./Init/Lean/Syntax.c ./Init/Lean/ToExpr.c ./Init/Lean/Trace.c ./Init/Lean/TypeClass.c ./Init/Lean/TypeClass/Basic.c ./Init/Lean/TypeClass/Context.c ./Init/Lean/TypeClass/Synth.c ./Init/Lean/Util.c ./Init/Lean/WHNF.c ./Init/System.c ./Init/System/FilePath.c ./Init/System/IO.c ./Init/System/Platform.c ./Init/Util.c ./Init/WF.c) diff --git a/stage0/src/CMakeLists.txt b/stage0/src/CMakeLists.txt index 8a84c40006..f8335313ed 100644 --- a/stage0/src/CMakeLists.txt +++ b/stage0/src/CMakeLists.txt @@ -182,8 +182,7 @@ if("${CMAKE_C_COMPILER}" MATCHES "emcc") set(CFLAGS_EMSCRIPTEN "-Oz -O3") set(LEAN_EXTRA_CXX_FLAGS "${LEAN_EXTRA_CXX_FLAGS} ${CFLAGS_EMSCRIPTEN} -D LEAN_EMSCRIPTEN") set(LEAN_EXTRA_LINKER_FLAGS "${LEAN_EXTRA_LINKER_FLAGS} --memory-init-file 0 --llvm-lto 1 -s ALLOW_MEMORY_GROWTH=1 -s DISABLE_EXCEPTION_CATCHING=0 ${CFLAGS_EMSCRIPTEN}") - set(LEAN_JS_LIBRARY "${CMAKE_CURRENT_SOURCE_DIR}/../library" CACHE STRING - "location of olean files for lean.js") + set(LEAN_JS_LIBRARY "${CMAKE_CURRENT_SOURCE_DIR}" CACHE STRING "location of olean files for lean.js") endif() if (CMAKE_CROSSCOMPILING_EMULATOR) # emscripten likes to quote "node" @@ -490,7 +489,7 @@ configure_file("${LEAN_SOURCE_DIR}/version.h.in" "${LEAN_BINARY_DIR}/version.h") configure_file("${LEAN_SOURCE_DIR}/config.h.in" "${LEAN_SOURCE_DIR}/config.h") install(FILES "${LEAN_SOURCE_DIR}/config.h" DESTINATION "${INCLUDE_DIR}") if(NOT STAGE0) - configure_file("${LEAN_SOURCE_DIR}/../library/Makefile.in" "${LEAN_SOURCE_DIR}/../library/Makefile") + configure_file("${LEAN_SOURCE_DIR}/Init/Makefile.in" "${LEAN_SOURCE_DIR}/Init/Makefile") endif() include_directories("${LEAN_BINARY_DIR}") @@ -512,10 +511,10 @@ add_subdirectory(library/compiler) set(LEAN_OBJS ${LEAN_OBJS} $) add_subdirectory(frontends/lean) set(LEAN_OBJS ${LEAN_OBJS} $) -add_subdirectory(init) -set(LEAN_OBJS ${LEAN_OBJS} $) +add_subdirectory(initialize) +set(LEAN_OBJS ${LEAN_OBJS} $) if(STAGE0) - add_subdirectory(../library stdlib) + add_subdirectory(../stdlib stdlib) set(LEAN_OBJS ${LEAN_OBJS} $) endif() if(EMSCRIPTEN) @@ -622,23 +621,11 @@ add_style_check_target(style "${LEAN_SOURCES}") add_test(NAME style_check COMMAND "${PYTHON_EXECUTABLE}" "${LEAN_SOURCE_DIR}/cmake/Modules/cpplint.py" ${LEAN_SOURCES}) endif() -# add_custom_target( -# leanpkg ALL -# COMMAND "${LEAN_SOURCE_DIR}/../bin/lean" --make ${LEAN_EXTRA_MAKE_OPTS} -# DEPENDS standard_lib -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../leanpkg" -# ) - add_custom_target(clean-stdlib - WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../library" - COMMAND find . -name *.olean -delete - COMMAND find . -name *.depend -delete - COMMAND rm -r ../src/stage1 "${CMAKE_BINARY_DIR}/stage1" || true - ) - -add_custom_target(clean-leanpkg - WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../leanpkg" - COMMAND "${CMAKE_COMMAND}" -P "${CMAKE_MODULE_PATH}/CleanOlean.cmake" + WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/Init" + COMMAND find . -name '*.olean' -delete + COMMAND find . -name '*.depend' -delete + COMMAND rm -r ../stage1 "${CMAKE_BINARY_DIR}/stage1" || true ) add_custom_target(clean-olean @@ -654,18 +641,10 @@ install(FILES "${CMAKE_SOURCE_DIR}/../bin/leanpkg" DESTINATION bin PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE) -install(DIRECTORY "${CMAKE_SOURCE_DIR}/../library" DESTINATION "${LIBRARY_DIR}" +install(DIRECTORY "${CMAKE_SOURCE_DIR}/Init" DESTINATION "${LIBRARY_DIR}" FILES_MATCHING PATTERN "*.lean" PATTERN "*.olean" - PATTERN "leanpkg.toml" - PATTERN "*.md") - -install(DIRECTORY "${CMAKE_SOURCE_DIR}/../leanpkg" DESTINATION "${LIBRARY_DIR}" - FILES_MATCHING - PATTERN "*.lean" - PATTERN "*.olean" - PATTERN "leanpkg.toml" PATTERN "*.md") install(DIRECTORY "${CMAKE_SOURCE_DIR}/runtime" DESTINATION "${INCLUDE_DIR}" diff --git a/stage0/src/Init/Coe.lean b/stage0/src/Init/Coe.lean new file mode 100644 index 0000000000..2da50508a9 --- /dev/null +++ b/stage0/src/Init/Coe.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ + +/- +The Elaborator tries to insert coercions automatically. +Only instances of HasCoe type class are considered in the process. + +Lean also provides a "lifting" operator: ↑a. +It uses all instances of HasLift type class. +Every HasCoe instance is also a HasLift instance. + +We recommend users only use HasCoe for coercions that do not produce a lot +of ambiguity. + +All coercions and lifts can be identified with the constant coe. + +We use the HasCoeToFun type class for encoding coercions from +a Type to a Function space. + +We use the HasCoeToSort type class for encoding coercions from +a Type to a sort. +-/ +prelude +import Init.Data.List.Basic +universes u v + +class HasLift (a : Sort u) (b : Sort v) := +(lift : a → b) + +/-- Auxiliary class that contains the transitive closure of HasLift. -/ +class HasLiftT (a : Sort u) (b : Sort v) := +(lift : a → b) + +class HasCoe (a : Sort u) (b : Sort v) := +(coe : a → b) + +/-- Auxiliary class that contains the transitive closure of HasCoe. -/ +class HasCoeT (a : Sort u) (b : Sort v) := +(coe : a → b) + +class HasCoeToFun (a : Sort u) : Sort (max u (v+1)) := +(F : a → Sort v) (coe : ∀ x, F x) + +class HasCoeToSort (a : Sort u) : Type (max u (v+1)) := +(S : Sort v) (coe : a → S) + +@[inline] def lift {a : Sort u} {b : Sort v} [HasLift a b] : a → b := +@HasLift.lift a b _ + +@[inline] def liftT {a : Sort u} {b : Sort v} [HasLiftT a b] : a → b := +@HasLiftT.lift a b _ + +@[inline] def coeB {a : Sort u} {b : Sort v} [HasCoe a b] : a → b := +@HasCoe.coe a b _ + +@[inline] def coeT {a : Sort u} {b : Sort v} [HasCoeT a b] : a → b := +@HasCoeT.coe a b _ + +@[inline] def coeFnB {a : Sort u} [HasCoeToFun.{u, v} a] : ∀ (x : a), HasCoeToFun.F.{u, v} x := +HasCoeToFun.coe + +/- User Level coercion operators -/ + +@[reducible, inline] def coe {a : Sort u} {b : Sort v} [HasLiftT a b] : a → b := +liftT + +@[reducible, inline] def coeFn {a : Sort u} [HasCoeToFun.{u, v} a] : ∀ (x : a), HasCoeToFun.F.{u, v} x := +HasCoeToFun.coe + +@[reducible, inline] def coeSort {a : Sort u} [HasCoeToSort.{u, v} a] : a → HasCoeToSort.S.{u, v} a := +HasCoeToSort.coe + +/- Notation -/ + +universes u₁ u₂ u₃ + +/- Transitive closure for HasLift, HasCoe, HasCoeToFun -/ + +instance liftTrans {a : Sort u₁} {b : Sort u₂} {c : Sort u₃} [HasLiftT b c] [HasLift a b] : HasLiftT a c := +⟨fun x => liftT (lift x : b)⟩ + +instance liftRefl {a : Sort u} : HasLiftT a a := +⟨id⟩ + +instance coeTrans {a : Sort u₁} {b : Sort u₂} {c : Sort u₃} [HasCoeT b c] [HasCoe a b] : HasCoeT a c := +⟨fun x => coeT (coeB x : b)⟩ + +instance coeBase {a : Sort u} {b : Sort v} [HasCoe a b] : HasCoeT a b := +⟨coeB⟩ + +/- We add this instance directly into HasCoeT to avoid non-termination. + + Suppose coeOption had Type (HasCoe a (Option a)). + Then, we can loop when searching a coercion from α to β (HasCoeT α β) + 1- coeTrans at (HasCoeT α β) + (HasCoe α ?b₁) and (HasCoeT ?b₁ c) + 2- coeOption at (HasCoe α ?b₁) + ?b₁ := Option α + 3- coeTrans at (HasCoeT (Option α) β) + (HasCoe (Option α) ?b₂) and (HasCoeT ?b₂ β) + 4- coeOption at (HasCoe (Option α) ?b₂) + ?b₂ := Option (Option α)) + ... +-/ +instance coeOption {a : Type u} : HasCoeT a (Option a) := +⟨fun x => some x⟩ + +/- Auxiliary transitive closure for HasCoe which does not contain + instances such as coeOption. + + They would produce non-termination when combined with coeFnTrans and coeSortTrans. +-/ +class HasCoeTAux (a : Sort u) (b : Sort v) := +(coe : a → b) + +instance coeTransAux {a : Sort u₁} {b : Sort u₂} {c : Sort u₃} [HasCoeTAux b c] [HasCoe a b] : HasCoeTAux a c := +⟨fun x => @HasCoeTAux.coe b c _ (coeB x)⟩ + +instance coeBaseAux {a : Sort u} {b : Sort v} [HasCoe a b] : HasCoeTAux a b := +⟨coeB⟩ + +instance coeFnTrans {a : Sort u₁} {b : Sort u₂} [HasCoeToFun.{u₂, u₃} b] [HasCoeTAux a b] : HasCoeToFun.{u₁, u₃} a := +{ F := fun x => @HasCoeToFun.F.{u₂, u₃} b _ (@HasCoeTAux.coe a b _ x), + coe := fun x => coeFn (@HasCoeTAux.coe a b _ x) } + +instance coeSortTrans {a : Sort u₁} {b : Sort u₂} [HasCoeToSort.{u₂, u₃} b] [HasCoeTAux a b] : HasCoeToSort.{u₁, u₃} a := +{ S := HasCoeToSort.S.{u₂, u₃} b, + coe := fun x => coeSort (@HasCoeTAux.coe a b _ x) } + +/- Every coercion is also a lift -/ + +instance coeToLift {a : Sort u} {b : Sort v} [HasCoeT a b] : HasLiftT a b := +⟨coeT⟩ + +/- basic coercions -/ + +instance coeBoolToProp : HasCoe Bool Prop := +⟨fun y => y = true⟩ + +/- Tactics such as the simplifier only unfold reducible constants when checking whether two terms are definitionally + equal or a Term is a proposition. The motivation is performance. + In particular, when simplifying `p -> q`, the tactic `simp` only visits `p` if it can establish that it is a proposition. + Thus, we mark the following instance as @[reducible], otherwise `simp` will not visit `↑p` when simplifying `↑p -> q`. +-/ +@[reducible] instance coeSortBool : HasCoeToSort Bool := +⟨Prop, fun y => y = true⟩ + +instance coeDecidableEq (x : Bool) : Decidable (coe x) := +inferInstanceAs (Decidable (x = true)) + +instance coeSubtype {a : Sort u} {p : a → Prop} : HasCoe {x // p x} a := +⟨Subtype.val⟩ + +/- basic lifts -/ + +universes ua ua₁ ua₂ ub ub₁ ub₂ + +/- Remark: we can't use [HasLiftT a₂ a₁] since it will produce non-termination whenever a type class resolution + problem does not have a solution. -/ +instance liftFn {a₁ : Sort ua₁} {a₂ : Sort ua₂} {b₁ : Sort ub₁} {b₂ : Sort ub₂} [HasLiftT b₁ b₂] [HasLift a₂ a₁] : HasLift (a₁ → b₁) (a₂ → b₂) := +⟨fun f x => coe (f (coe x))⟩ + +instance liftFnRange {a : Sort ua} {b₁ : Sort ub₁} {b₂ : Sort ub₂} [HasLiftT b₁ b₂] : HasLift (a → b₁) (a → b₂) := +⟨fun f x => coe (f x)⟩ + +instance liftFnDom {a₁ : Sort ua₁} {a₂ : Sort ua₂} {b : Sort ub} [HasLift a₂ a₁] : HasLift (a₁ → b) (a₂ → b) := +⟨fun f x => f (coe x)⟩ + +instance liftPair {a₁ : Type ua₁} {a₂ : Type ub₂} {b₁ : Type ub₁} {b₂ : Type ub₂} [HasLiftT a₁ a₂] [HasLiftT b₁ b₂] : HasLift (a₁ × b₁) (a₂ × b₂) := +⟨fun p => Prod.casesOn p (fun x y => (coe x, coe y))⟩ + +instance liftPair₁ {a₁ : Type ua₁} {a₂ : Type ua₂} {b : Type ub} [HasLiftT a₁ a₂] : HasLift (a₁ × b) (a₂ × b) := +⟨fun p => Prod.casesOn p (fun x y => (coe x, y))⟩ + +instance liftPair₂ {a : Type ua} {b₁ : Type ub₁} {b₂ : Type ub₂} [HasLiftT b₁ b₂] : HasLift (a × b₁) (a × b₂) := +⟨fun p => Prod.casesOn p (fun x y => (x, coe y))⟩ + +instance liftList {a : Type u} {b : Type v} [HasLiftT a b] : HasLift (List a) (List b) := +⟨fun l => List.map (@coe a b _) l⟩ diff --git a/stage0/src/Init/Control.lean b/stage0/src/Init/Control.lean new file mode 100644 index 0000000000..4e5551ee91 --- /dev/null +++ b/stage0/src/Init/Control.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Applicative +import Init.Control.Functor +import Init.Control.Alternative +import Init.Control.Monad +import Init.Control.Lift +import Init.Control.State +import Init.Control.Id +import Init.Control.Except +import Init.Control.Reader +import Init.Control.Option +import Init.Control.Conditional diff --git a/stage0/src/Init/Control/Alternative.lean b/stage0/src/Init/Control/Alternative.lean new file mode 100644 index 0000000000..6b5754dfb8 --- /dev/null +++ b/stage0/src/Init/Control/Alternative.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Core +import Init.Control.Applicative +universes u v + +class Alternative (f : Type u → Type v) extends Applicative f : Type (max (u+1) v) := +(failure : ∀ {α : Type u}, f α) +(orelse : ∀ {α : Type u}, f α → f α → f α) + +instance alternativeHasOrelse (f : Type u → Type v) (α : Type u) [Alternative f] : HasOrelse (f α) := +⟨Alternative.orelse⟩ + +section +variables {f : Type u → Type v} [Alternative f] {α : Type u} + +@[inline] def failure : f α := +Alternative.failure f + +@[inline] def guard {f : Type → Type v} [Alternative f] (p : Prop) [Decidable p] : f Unit := +if p then pure () else failure + +@[inline] def assert {f : Type → Type v} [Alternative f] (p : Prop) [Decidable p] : f (Inhabited p) := +if h : p then pure ⟨h⟩ else failure + +/- Later we define a coercion from Bool to Prop, but this version will still be useful. + Given (t : tactic Bool), we can write t >>= guardb -/ +@[inline] def guardb {f : Type → Type v} [Alternative f] : Bool → f Unit +| true => pure () +| false => failure + +@[inline] def optional (x : f α) : f (Option α) := +some <$> x <|> pure none + +end diff --git a/stage0/src/Init/Control/Applicative.lean b/stage0/src/Init/Control/Applicative.lean new file mode 100644 index 0000000000..2de9cd3cdf --- /dev/null +++ b/stage0/src/Init/Control/Applicative.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Control.Functor +open Function +universes u v + +class HasPure (f : Type u → Type v) := +(pure {} {α : Type u} : α → f α) + +export HasPure (pure) + +class HasSeq (f : Type u → Type v) : Type (max (u+1) v) := +(seq : ∀ {α β : Type u}, f (α → β) → f α → f β) + +infixl <*> := HasSeq.seq + +class HasSeqLeft (f : Type u → Type v) : Type (max (u+1) v) := +(seqLeft : ∀ {α β : Type u}, f α → f β → f α) + +infixl <* := HasSeqLeft.seqLeft + +class HasSeqRight (f : Type u → Type v) : Type (max (u+1) v) := +(seqRight : ∀ {α β : Type u}, f α → f β → f β) + +infixr *> := HasSeqRight.seqRight + +class Applicative (f : Type u → Type v) extends Functor f, HasPure f, HasSeq f, HasSeqLeft f, HasSeqRight f := +(map := fun _ _ x y => pure x <*> y) +(seqLeft := fun α β a b => const β <$> a <*> b) +(seqRight := fun α β a b => const α id <$> a <*> b) + +@[macroInline] +def when {m : Type → Type u} [Applicative m] (c : Prop) [h : Decidable c] (t : m Unit) : m Unit := +if c then t else pure () + +@[macroInline] +def unless {m : Type → Type u} [Applicative m] (c : Prop) [h : Decidable c] (e : m Unit) : m Unit := +if c then pure () else e diff --git a/stage0/src/Init/Control/Conditional.lean b/stage0/src/Init/Control/Conditional.lean new file mode 100644 index 0000000000..9e6b4d3269 --- /dev/null +++ b/stage0/src/Init/Control/Conditional.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Control.Monad +import Init.Data.Option.Basic +universes u v + +class HasToBool (α : Type u) := +(toBool : α → Bool) + +export HasToBool (toBool) + +instance : HasToBool Bool := ⟨id⟩ +instance {α} : HasToBool (Option α) := ⟨Option.toBool⟩ + +@[macroInline] def bool {β : Type u} {α : Type v} [HasToBool β] (f t : α) (b : β) : α := +match toBool b with +| true => t +| false => f + +@[macroInline] def orM {m : Type u → Type v} {β : Type u} [Monad m] [HasToBool β] (x y : m β) : m β := +do b ← x; + match toBool b with + | true => pure b + | false => y + +@[macroInline] def andM {m : Type u → Type v} {β : Type u} [Monad m] [HasToBool β] (x y : m β) : m β := +do b ← x; + match toBool b with + | true => y + | false => pure b + +infixl ` <||> `:30 := orM +infixl ` <&&> `:35 := andM + +@[macroInline] def notM {m : Type → Type v} [Applicative m] (x : m Bool) : m Bool := +not <$> x diff --git a/stage0/src/Init/Control/EState.lean b/stage0/src/Init/Control/EState.lean new file mode 100644 index 0000000000..bbf958d614 --- /dev/null +++ b/stage0/src/Init/Control/EState.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.State +import Init.Control.Except +universes u v + +namespace EStateM + +inductive Result (ε σ α : Type u) +| ok {} : α → σ → Result +| error {} : ε → σ → Result + +variables {ε σ α : Type u} + +protected def Result.toString [HasToString ε] [HasToString α] : Result ε σ α → String +| Result.ok a _ => "ok: " ++ toString a +| Result.error e _ => "error: " ++ toString e + +protected def Result.repr [HasRepr ε] [HasRepr α] : Result ε σ α → String +| Result.error e _ => "(error " ++ repr e ++ ")" +| Result.ok a _ => "(ok " ++ repr a ++ ")" + +instance [HasToString ε] [HasToString α] : HasToString (Result ε σ α) := ⟨Result.toString⟩ +instance [HasRepr ε] [HasRepr α] : HasRepr (Result ε σ α) := ⟨Result.repr⟩ + +end EStateM + +def EStateM (ε σ α : Type u) := σ → EStateM.Result ε σ α + +namespace EStateM + +variables {ε σ α β : Type u} + +instance [Inhabited ε] : Inhabited (EStateM ε σ α) := +⟨fun s => Result.error (arbitrary ε) s⟩ + +@[inline] protected def pure (a : α) : EStateM ε σ α := +fun s => Result.ok a s + +@[inline] protected def set (s : σ) : EStateM ε σ PUnit := +fun _ => Result.ok ⟨⟩ s + +@[inline] protected def get : EStateM ε σ σ := +fun s => Result.ok s s + +@[inline] protected def modifyGet (f : σ → α × σ) : EStateM ε σ α := +fun s => + match f s with + | (a, s) => Result.ok a s + +@[inline] protected def throw (e : ε) : EStateM ε σ α := +fun s => Result.error e s + +/-- Auxiliary instance for saving/restoring the "backtrackable" part of the state. -/ +class Backtrackable (δ : outParam $ Type u) (σ : Type u) := +(save : σ → δ) +(restore : σ → δ → σ) + +@[inline] protected def catch {δ} [Backtrackable δ σ] {α} (x : EStateM ε σ α) (handle : ε → EStateM ε σ α) : EStateM ε σ α := +fun s => + let d := Backtrackable.save s; + match x s with + | Result.error e s => handle e (Backtrackable.restore s d) + | ok => ok + +@[inline] protected def orelse {δ} [Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) : EStateM ε σ α := +fun s => + let d := Backtrackable.save s; + match x₁ s with + | Result.error _ s => x₂ (Backtrackable.restore s d) + | ok => ok + +/-- Alternative orelse operator that allows to select which exception should be used. + The default is to use the first exception since the standard `orelse` uses the second. -/ +@[inline] protected def orelse' {δ} [Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) (useFirstEx := true) : EStateM ε σ α := +fun s => + let d := Backtrackable.save s; + match x₁ s with + | Result.error e₁ s₁ => + match x₂ (Backtrackable.restore s₁ d) with + | Result.error e₂ s₂ => Result.error (if useFirstEx then e₁ else e₂) s₂ + | ok => ok + | ok => ok + +@[inline] def adaptExcept {ε' : Type u} [HasLift ε ε'] (x : EStateM ε σ α) : EStateM ε' σ α := +fun s => match x s with + | Result.error e s => Result.error (lift e) s + | Result.ok a s => Result.ok a s + +@[inline] protected def bind (x : EStateM ε σ α) (f : α → EStateM ε σ β) : EStateM ε σ β := +fun s => match x s with + | Result.ok a s => f a s + | Result.error e s => Result.error e s + +@[inline] protected def map (f : α → β) (x : EStateM ε σ α) : EStateM ε σ β := +fun s => match x s with + | Result.ok a s => Result.ok (f a) s + | Result.error e s => Result.error e s + +@[inline] protected def seqRight (x : EStateM ε σ α) (y : EStateM ε σ β) : EStateM ε σ β := +fun s => match x s with + | Result.ok _ s => y s + | Result.error e s => Result.error e s + +instance : Monad (EStateM ε σ) := +{ bind := @EStateM.bind _ _, pure := @EStateM.pure _ _, map := @EStateM.map _ _, seqRight := @EStateM.seqRight _ _ } + +instance {δ} [Backtrackable δ σ] : HasOrelse (EStateM ε σ α) := +{ orelse := @EStateM.orelse _ _ _ _ _ } + +instance : MonadState σ (EStateM ε σ) := +{ set := @EStateM.set _ _, get := @EStateM.get _ _, modifyGet := @EStateM.modifyGet _ _ } + +instance {δ} [Backtrackable δ σ] : MonadExcept ε (EStateM ε σ) := +{ throw := @EStateM.throw _ _, catch := @EStateM.catch _ _ _ _ } + +@[inline] def adaptState {σ₁ σ₂} (split : σ → σ₁ × σ₂) (merge : σ₁ → σ₂ → σ) (x : EStateM ε σ₁ α) : EStateM ε σ α := +fun s => + let (s₁, s₂) := split s; + match x s₁ with + | Result.ok a s₁ => Result.ok a (merge s₁ s₂) + | Result.error e s₁ => Result.error e (merge s₁ s₂) + +instance {ε σ σ'} : MonadStateAdapter σ σ' (EStateM ε σ) (EStateM ε σ') := +⟨fun σ'' α => EStateM.adaptState⟩ + +@[inline] def fromStateM {ε σ α : Type} (x : StateM σ α) : EStateM ε σ α := +fun s => + match x.run s with + | (a, s') => EStateM.Result.ok a s' + +@[inline] def run (x : EStateM ε σ α) (s : σ) : Result ε σ α := +x s + +@[inline] def run' (x : EStateM ε σ α) (s : σ) : Option α := +match run x s with +| Result.ok v _ => some v +| Result.error _ _ => none + +@[inline] def dummySave : σ → PUnit := +fun _ => ⟨⟩ + +@[inline] def dummyRestore : σ → PUnit → σ := +fun s _ => s + +/- Dummy default instance -/ +instance nonBacktrackable : Backtrackable PUnit σ := +{ save := dummySave, + restore := dummyRestore } + +end EStateM diff --git a/stage0/src/Init/Control/Except.lean b/stage0/src/Init/Control/Except.lean new file mode 100644 index 0000000000..69e423915d --- /dev/null +++ b/stage0/src/Init/Control/Except.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jared Roesch, Sebastian Ullrich + +The Except monad transformer. +-/ +prelude +import Init.Control.Alternative +import Init.Control.Lift +import Init.Data.ToString +import Init.Control.MonadFail +universes u v w + +inductive Except (ε : Type u) (α : Type v) +| error {} : ε → Except +| ok {} : α → Except + +attribute [unbox] Except + +instance {ε α : Type} [Inhabited ε] : Inhabited (Except ε α) := +⟨Except.error (arbitrary ε)⟩ + +section +variables {ε : Type u} {α : Type v} + +protected def Except.toString [HasToString ε] [HasToString α] : Except ε α → String +| Except.error e => "(error " ++ toString e ++ ")" +| Except.ok a => "(ok " ++ toString a ++ ")" + +protected def Except.repr [HasRepr ε] [HasRepr α] : Except ε α → String +| Except.error e => "(error " ++ repr e ++ ")" +| Except.ok a => "(ok " ++ repr a ++ ")" + +instance [HasToString ε] [HasToString α] : HasToString (Except ε α) := +⟨Except.toString⟩ + +instance [HasRepr ε] [HasRepr α] : HasRepr (Except ε α) := +⟨Except.repr⟩ +end + +namespace Except +variables {ε : Type u} + +@[inline] protected def return {α : Type v} (a : α) : Except ε α := +Except.ok a + +@[inline] protected def map {α β : Type v} (f : α → β) : Except ε α → Except ε β +| Except.error err => Except.error err +| Except.ok v => Except.ok $ f v + +@[inline] protected def mapError {ε' : Type u} {α : Type v} (f : ε → ε') : Except ε α → Except ε' α +| Except.error err => Except.error $ f err +| Except.ok v => Except.ok v + +@[inline] protected def bind {α β : Type v} (ma : Except ε α) (f : α → Except ε β) : Except ε β := +match ma with +| (Except.error err) => Except.error err +| (Except.ok v) => f v + +@[inline] protected def toBool {α : Type v} : Except ε α → Bool +| Except.ok _ => true +| Except.error _ => false + +@[inline] protected def toOption {α : Type v} : Except ε α → Option α +| Except.ok a => some a +| Except.error _ => none + +@[inline] protected def catch {α : Type u} (ma : Except ε α) (handle : ε → Except ε α) : Except ε α := +match ma with +| Except.ok a => Except.ok a +| Except.error e => handle e + +instance : Monad (Except ε) := +{ pure := @Except.return _, bind := @Except.bind _, map := @Except.map _ } +end Except + +def ExceptT (ε : Type u) (m : Type u → Type v) (α : Type u) : Type v := +m (Except ε α) + +@[inline] def ExceptT.mk {ε : Type u} {m : Type u → Type v} {α : Type u} (x : m (Except ε α)) : ExceptT ε m α := +x + +@[inline] def ExceptT.run {ε : Type u} {m : Type u → Type v} {α : Type u} (x : ExceptT ε m α) : m (Except ε α) := +x + +namespace ExceptT +variables {ε : Type u} {m : Type u → Type v} [Monad m] + +@[inline] protected def pure {α : Type u} (a : α) : ExceptT ε m α := +ExceptT.mk $ pure (Except.ok a) + +@[inline] protected def bindCont {α β : Type u} (f : α → ExceptT ε m β) : Except ε α → m (Except ε β) +| Except.ok a => f a +| Except.error e => pure (Except.error e) + +@[inline] protected def bind {α β : Type u} (ma : ExceptT ε m α) (f : α → ExceptT ε m β) : ExceptT ε m β := +ExceptT.mk $ ma >>= ExceptT.bindCont f + +@[inline] protected def map {α β : Type u} (f : α → β) (x : ExceptT ε m α) : ExceptT ε m β := +ExceptT.mk $ x >>= fun a => match a with + | (Except.ok a) => pure $ Except.ok (f a) + | (Except.error e) => pure $ Except.error e + +@[inline] protected def lift {α : Type u} (t : m α) : ExceptT ε m α := +ExceptT.mk $ Except.ok <$> t + +instance exceptTOfExcept : HasMonadLift (Except ε) (ExceptT ε m) := +⟨fun α e => ExceptT.mk $ pure e⟩ + +instance : HasMonadLift m (ExceptT ε m) := +⟨@ExceptT.lift _ _ _⟩ + +@[inline] protected def catch {α : Type u} (ma : ExceptT ε m α) (handle : ε → ExceptT ε m α) : ExceptT ε m α := +ExceptT.mk $ ma >>= fun res => match res with + | Except.ok a => pure (Except.ok a) + | Except.error e => (handle e) + +instance (m') [Monad m'] : MonadFunctor m m' (ExceptT ε m) (ExceptT ε m') := +⟨fun _ f x => f x⟩ + +instance : Monad (ExceptT ε m) := +{ pure := @ExceptT.pure _ _ _, bind := @ExceptT.bind _ _ _, map := @ExceptT.map _ _ _ } + +@[inline] protected def adapt {ε' α : Type u} (f : ε → ε') : ExceptT ε m α → ExceptT ε' m α := +fun x => ExceptT.mk $ Except.mapError f <$> x +end ExceptT + +/-- An implementation of [MonadError](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Except.html#t:MonadError) -/ +class MonadExcept (ε : outParam (Type u)) (m : Type v → Type w) := +(throw {} {α : Type v} : ε → m α) +(catch {} {α : Type v} : m α → (ε → m α) → m α) + +namespace MonadExcept +variables {ε : Type u} {m : Type v → Type w} + +@[inline] protected def orelse [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) : m α := +catch t₁ $ fun _ => t₂ + +/-- Alternative orelse operator that allows to select which exception should be used. + The default is to use the first exception since the standard `orelse` uses the second. -/ +@[inline] def orelse' [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) (useFirstEx := true) : m α := +catch t₁ $ fun e₁ => catch t₂ $ fun e₂ => throw (if useFirstEx then e₁ else e₂) + +@[inline] def liftExcept {ε' : Type u} [MonadExcept ε m] [HasLiftT ε' ε] [Monad m] {α : Type v} : Except ε' α → m α +| Except.error e => throw (coe e) +| Except.ok a => pure a +end MonadExcept + +export MonadExcept (throw catch) + +instance (m : Type u → Type v) (ε : Type u) [Monad m] : MonadExcept ε (ExceptT ε m) := +{ throw := fun α e => ExceptT.mk $ pure (Except.error e), + catch := @ExceptT.catch ε _ _ } + +instance (ε) : MonadExcept ε (Except ε) := +{ throw := fun α => Except.error, catch := @Except.catch _ } + +/-- Adapt a Monad stack, changing its top-most error Type. + + Note: This class can be seen as a simplification of the more "principled" definition + ``` + class MonadExceptFunctor (ε ε' : outParam (Type u)) (n n' : Type u → Type u) := + (map {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ExceptT ε m α → ExceptT ε' m α) → n α → n' α) + ``` +-/ +class MonadExceptAdapter (ε ε' : outParam (Type u)) (m m' : Type u → Type v) := +(adaptExcept {} {α : Type u} : (ε → ε') → m α → m' α) +export MonadExceptAdapter (adaptExcept) + +section +variables {ε ε' : Type u} {m m' : Type u → Type v} + +instance monadExceptAdapterTrans {n n' : Type u → Type v} [MonadFunctor m m' n n'] [MonadExceptAdapter ε ε' m m'] : MonadExceptAdapter ε ε' n n' := +⟨fun α f => monadMap (fun α => (adaptExcept f : m α → m' α))⟩ + +instance [Monad m] : MonadExceptAdapter ε ε' (ExceptT ε m) (ExceptT ε' m) := +⟨fun α => ExceptT.adapt⟩ +end + +instance (ε m out) [MonadRun out m] : MonadRun (fun α => out (Except ε α)) (ExceptT ε m) := +⟨fun α => run⟩ + +-- useful for implicit failures in do-notation +instance (m : Type → Type) [Monad m] : MonadFail (ExceptT String m) := +⟨fun _ => throw⟩ + +/-- Execute `x` and then execute `finalizer` even if `x` threw an exception -/ +@[inline] def finally {ε α β : Type u} {m : Type u → Type v} [Monad m] [MonadExcept ε m] (x : m α) (finalizer : m β) : m α := +catch + (do a ← x; finalizer; pure a) + (fun e => do finalizer; throw e) diff --git a/stage0/src/Init/Control/Functor.lean b/stage0/src/Init/Control/Functor.lean new file mode 100644 index 0000000000..46235c3bcf --- /dev/null +++ b/stage0/src/Init/Control/Functor.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) Luke Nelson and Jared Roesch. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Luke Nelson, Jared Roesch, Sebastian Ullrich, Leonardo de Moura +-/ +prelude +import Init.Core +open Function +universes u v + +class Functor (f : Type u → Type v) : Type (max (u+1) v) := +(map : ∀ {α β : Type u}, (α → β) → f α → f β) +(mapConst : ∀ {α β : Type u}, α → f β → f α := fun α β => map ∘ const β) + +infixr `<$>` := Functor.map +infixr `<$` := Functor.mapConst + +@[reducible] def Functor.mapConstRev {f : Type u → Type v} [Functor f] {α β : Type u} : f β → α → f α := +fun a b => b <$ a +infixr `$>` := Functor.mapConstRev + +@[reducible] def Functor.mapRev {f : Type u → Type v} [Functor f] {α β : Type u} : f α → (α → β) → f β := +fun a f => f <$> a +infixl `<&>` := Functor.mapRev diff --git a/stage0/src/Init/Control/Id.lean b/stage0/src/Init/Control/Id.lean new file mode 100644 index 0000000000..7bbe9f963c --- /dev/null +++ b/stage0/src/Init/Control/Id.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sebastian Ullrich + +The identity Monad. +-/ +prelude +import Init.Control.Lift +universe u + +def Id (type : Type u) : Type u := type + +@[inline] def Id.pure {α : Type u} (x : α) : Id α := +x + +@[inline] def Id.bind {α β : Type u} (x : Id α) (f : α → Id β) : Id β := +f x + +@[inline] def Id.map {α β : Type u} (f : α → β) (x : Id α) : Id β := +f x + +instance : Monad Id := +{ pure := @Id.pure, bind := @Id.bind, map := @Id.map } + +@[inline] def Id.run {α : Type u} (x : Id α) : α := +x + +instance : MonadRun id Id := +⟨@Id.run⟩ diff --git a/stage0/src/Init/Control/Lift.lean b/stage0/src/Init/Control/Lift.lean new file mode 100644 index 0000000000..263adde8eb --- /dev/null +++ b/stage0/src/Init/Control/Lift.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2016 Gabriel Ebner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Ebner, Sebastian Ullrich + +Classy functions for lifting monadic actions of different shapes. + +This theory is roughly modeled after the Haskell 'layers' package https://hackage.haskell.org/package/layers-0.1. +Please see https://hackage.haskell.org/package/layers-0.1/docs/Documentation-Layers-Overview.html for an exhaustive discussion of the different approaches to lift functions. +-/ +prelude +import Init.Coe +import Init.Control.Monad + +universes u v w + +/-- A Function for lifting a computation from an inner Monad to an outer Monad. + Like [MonadTrans](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Class.html), + but `n` does not have to be a monad transformer. + Alternatively, an implementation of [MonadLayer](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLayer) without `layerInvmap` (so far). -/ +class HasMonadLift (m : Type u → Type v) (n : Type u → Type w) := +(monadLift {} : ∀ {α}, m α → n α) + +/-- The reflexive-transitive closure of `HasMonadLift`. + `monadLift` is used to transitively lift monadic computations such as `StateT.get` or `StateT.put s`. + Corresponds to [MonadLift](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLift). -/ +class HasMonadLiftT (m : Type u → Type v) (n : Type u → Type w) := +(monadLift {} : ∀ {α}, m α → n α) + +export HasMonadLiftT (monadLift) + +/-- A coercion that may reduce the need for explicit lifting. + Because of [limitations of the current coercion resolution](https://github.com/leanprover/Lean/issues/1402), this definition is not marked as a global instance and should be marked locally instead. -/ +@[reducible] def hasMonadLiftToHasCoe {m n} [HasMonadLiftT m n] {α} : HasCoe (m α) (n α) := +⟨monadLift⟩ + +instance hasMonadLiftTTrans (m n o) [HasMonadLift n o] [HasMonadLiftT m n] : HasMonadLiftT m o := +⟨fun α ma => HasMonadLift.monadLift (monadLift ma : n α)⟩ + +instance hasMonadLiftTRefl (m) : HasMonadLiftT m m := +⟨fun α => id⟩ + +theorem monadLiftRefl {m : Type u → Type v} {α} : (monadLift : m α → m α) = id := rfl + + +/-- A Functor in the control of monads. Can be used to lift Monad-transforming functions. + Based on pipes' [MFunctor](https://hackage.haskell.org/package/pipes-2.4.0/docs/Control-MFunctor.html), + but not restricted to monad transformers. + Alternatively, an implementation of [MonadTransFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadTransFunctor). + + + Remark: other libraries equate `m` and `m'`, and `n` and `n'`. We need to distinguish them to be able to implement + gadgets such as `MonadStateAdapter` and `MonadReaderAdapter`. -/ +class MonadFunctor (m m' : Type u → Type v) (n n' : Type u → Type w) := +(monadMap {} {α : Type u} : (∀ {β}, m β → m' β) → n α → n' α) + +/-- The reflexive-transitive closure of `MonadFunctor`. + `monadMap` is used to transitively lift Monad morphisms such as `StateT.zoom`. + A generalization of [MonadLiftFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadLiftFunctor), which can only lift endomorphisms (i.e. m = m', n = n'). -/ +class MonadFunctorT (m m' : Type u → Type v) (n n' : Type u → Type w) := +(monadMap {} {α : Type u} : (∀ {β}, m β → m' β) → n α → n' α) + +export MonadFunctorT (monadMap) + +instance monadFunctorTTrans (m m' n n' o o') [MonadFunctorT m m' n n'] [MonadFunctor n n' o o'] : + MonadFunctorT m m' o o' := +⟨fun α f => MonadFunctor.monadMap (fun β => (monadMap @f : n β → n' β))⟩ + +instance monadFunctorTRefl (m m') : MonadFunctorT m m' m m' := +⟨fun α f => f⟩ + +theorem monadMapRefl {m m' : Type u → Type v} (f : ∀ {β}, m β → m' β) {α} : (monadMap @f : m α → m' α) = f := rfl + +/-- Run a Monad stack to completion. + `run` should be the composition of the transformers' individual `run` functions. + This class mostly saves some typing when using highly nested Monad stacks: + ``` + @[reducible] def MyMonad := ReaderT myCfg $ StateT myState $ ExceptT myErr id + -- def MyMonad.run {α : Type} (x : MyMonad α) (cfg : myCfg) (st : myState) := ((x.run cfg).run st).run + def MyMonad.run {α : Type} (x : MyMonad α) := MonadRun.run x + ``` + -/ +class MonadRun (out : outParam $ Type u → Type v) (m : Type u → Type v) := +(run {} {α : Type u} : m α → out α) + +export MonadRun (run) diff --git a/stage0/src/Init/Control/Monad.lean b/stage0/src/Init/Control/Monad.lean new file mode 100644 index 0000000000..8c08a95714 --- /dev/null +++ b/stage0/src/Init/Control/Monad.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) Luke Nelson and Jared Roesch. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Luke Nelson, Jared Roesch, Sebastian Ullrich +-/ +prelude +import Init.Control.Applicative +universes u v w + +open Function + +class HasBind (m : Type u → Type v) := +(bind : ∀ {α β : Type u}, m α → (α → m β) → m β) + +export HasBind (bind) + +infixr `>>=` := bind + +@[inline] def mcomp {α : Type u} {β δ : Type v} {m : Type v → Type w} [HasBind m] (f : α → m β) (g : β → m δ) : α → m δ := +fun a => f a >>= g + +infixr `>=>` := mcomp + +class Monad (m : Type u → Type v) extends Applicative m, HasBind m : Type (max (u+1) v) := +(map := fun α β f x => x >>= pure ∘ f) +(seq := fun α β f x => f >>= (fun y => y <$> x)) +(seqLeft := fun α β x y => x >>= fun a => y >>= fun _ => pure a) +(seqRight := fun α β x y => x >>= fun _ => y) + +instance monadInhabited' {α : Type u} {m : Type u → Type v} [Monad m] : Inhabited (α → m α) := +⟨pure⟩ + +instance monadInhabited {α : Type u} {m : Type u → Type v} [Monad m] [Inhabited α] : Inhabited (m α) := +⟨pure $ arbitrary _⟩ + +def joinM {m : Type u → Type u} [Monad m] {α : Type u} (a : m (m α)) : m α := +bind a id + +@[macroInline] +def condM {m : Type → Type u} [Monad m] {α : Type} (mbool : m Bool) (tm fm : m α) : m α := +do b ← mbool; cond b tm fm + +@[macroInline] +def whenM {m : Type → Type u} [Monad m] (c : m Bool) (t : m Unit) : m Unit := +condM c t (pure ()) + +@[macroInline] +def unlessM {m : Type → Type u} [Monad m] (c : m Bool) (t : m Unit) : m Unit := +condM c (pure ()) t diff --git a/stage0/src/Init/Control/MonadFail.lean b/stage0/src/Init/Control/MonadFail.lean new file mode 100644 index 0000000000..877af50dff --- /dev/null +++ b/stage0/src/Init/Control/MonadFail.lean @@ -0,0 +1,19 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Lift +import Init.Data.String.Basic + +universes u v + +class MonadFail (m : Type u → Type v) := +(fail {} : ∀ {a}, String → m a) + +def matchFailed {α : Type u} {m : Type u → Type v} [MonadFail m] : m α := +MonadFail.fail "match failed" + +instance monadFailLift (m n : Type u → Type v) [HasMonadLift m n] [MonadFail m] [Monad n] : MonadFail n := +{ fail := fun α s => monadLift (MonadFail.fail s : m α) } diff --git a/stage0/src/Init/Control/Option.lean b/stage0/src/Init/Control/Option.lean new file mode 100644 index 0000000000..93a088210e --- /dev/null +++ b/stage0/src/Init/Control/Option.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Control.Alternative +import Init.Control.Lift +import Init.Control.Except + +universes u v + +def OptionT (m : Type u → Type v) (α : Type u) : Type v := +m (Option α) + +@[inline] def OptionT.run {m : Type u → Type v} {α : Type u} (x : OptionT m α) : m (Option α) := +x + +namespace OptionT + variables {m : Type u → Type v} [Monad m] {α β : Type u} + + @[inline] protected def bindCont {α β : Type u} (f : α → OptionT m β) : Option α → m (Option β) + | some a => f a + | none => pure none + + @[inline] protected def bind (ma : OptionT m α) (f : α → OptionT m β) : OptionT m β := + (ma >>= OptionT.bindCont f : m (Option β)) + + @[inline] protected def pure (a : α) : OptionT m α := + (pure (some a) : m (Option α)) + + instance : Monad (OptionT m) := + { pure := @OptionT.pure _ _, bind := @OptionT.bind _ _ } + + protected def orelse (ma : OptionT m α) (mb : OptionT m α) : OptionT m α := + (do { some a ← ma | mb; + pure (some a) } : m (Option α)) + + @[inline] protected def fail : OptionT m α := + (pure none : m (Option α)) + + instance : Alternative (OptionT m) := + { failure := @OptionT.fail m _, + orelse := @OptionT.orelse m _, + ..OptionT.Monad } + + @[inline] protected def lift (ma : m α) : OptionT m α := + (some <$> ma : m (Option α)) + + instance : HasMonadLift m (OptionT m) := + ⟨@OptionT.lift _ _⟩ + + @[inline] protected def monadMap {m'} [Monad m'] {α} (f : ∀ {α}, m α → m' α) : OptionT m α → OptionT m' α := + fun x => f x + + instance (m') [Monad m'] : MonadFunctor m m' (OptionT m) (OptionT m') := + ⟨fun α => OptionT.monadMap⟩ + + protected def catch (ma : OptionT m α) (handle : Unit → OptionT m α) : OptionT m α := + (do { some a ← ma | (handle ()); + pure a } : m (Option α)) + + instance : MonadExcept Unit (OptionT m) := + { throw := fun _ _ => OptionT.fail, catch := @OptionT.catch _ _ } + + instance (m out) [MonadRun out m] : MonadRun (fun α => out (Option α)) (OptionT m) := + ⟨fun α => MonadRun.run⟩ +end OptionT diff --git a/stage0/src/Init/Control/Reader.lean b/stage0/src/Init/Control/Reader.lean new file mode 100644 index 0000000000..53f67ab9fc --- /dev/null +++ b/stage0/src/Init/Control/Reader.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sebastian Ullrich + +The Reader monad transformer for passing immutable State. +-/ + +prelude +import Init.Control.Lift +import Init.Control.Id +import Init.Control.Alternative +import Init.Control.Except +universes u v w + +/-- An implementation of [ReaderT](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Reader.html#t:ReaderT) -/ +def ReaderT (ρ : Type u) (m : Type u → Type v) (α : Type u) : Type (max u v) := +ρ → m α + +@[inline] def ReaderT.run {ρ : Type u} {m : Type u → Type v} {α : Type u} (x : ReaderT ρ m α) (r : ρ) : m α := +x r + +@[reducible] def Reader (ρ : Type u) := ReaderT ρ id + +namespace ReaderT +section +variables {ρ : Type u} {m : Type u → Type v} [Monad m] {α β : Type u} + +@[inline] protected def read : ReaderT ρ m ρ := +pure + +@[inline] protected def pure (a : α) : ReaderT ρ m α := +fun r => pure a + +@[inline] protected def bind (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) : ReaderT ρ m β := +fun r => do a ← x r; f a r + +@[inline] protected def map (f : α → β) (x : ReaderT ρ m α) : ReaderT ρ m β := +fun r => f <$> x r + +instance : Monad (ReaderT ρ m) := +{ pure := @ReaderT.pure _ _ _, bind := @ReaderT.bind _ _ _, map := @ReaderT.map _ _ _ } + +@[inline] protected def lift (a : m α) : ReaderT ρ m α := +fun r => a + +instance (m) [Monad m] : HasMonadLift m (ReaderT ρ m) := +⟨@ReaderT.lift ρ m _⟩ + +instance (ρ m m') [Monad m] [Monad m'] : MonadFunctor m m' (ReaderT ρ m) (ReaderT ρ m') := +⟨fun _ f x r => f (x r)⟩ + +@[inline] protected def adapt {ρ' : Type u} [Monad m] {α : Type u} (f : ρ' → ρ) : ReaderT ρ m α → ReaderT ρ' m α := +fun x r => x (f r) + +@[inline] protected def orelse [Alternative m] {α : Type u} (x₁ x₂ : ReaderT ρ m α) : ReaderT ρ m α := +fun s => x₁ s <|> x₂ s + +@[inline] protected def failure [Alternative m] {α : Type u} : ReaderT ρ m α := +fun s => failure + +instance [Alternative m] : Alternative (ReaderT ρ m) := +{ failure := @ReaderT.failure _ _ _ _, + orelse := @ReaderT.orelse _ _ _ _, + ..ReaderT.Monad } + +instance (ε) [Monad m] [MonadExcept ε m] : MonadExcept ε (ReaderT ρ m) := +{ throw := fun α => ReaderT.lift ∘ throw, + catch := fun α x c r => catch (x r) (fun e => (c e) r) } +end +end ReaderT + +/-- An implementation of [MonadReader](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader). + It does not contain `local` because this Function cannot be lifted using `monadLift`. + Instead, the `MonadReaderAdapter` class provides the more general `adaptReader` Function. + + Note: This class can be seen as a simplification of the more "principled" definition + ``` + class MonadReader (ρ : outParam (Type u)) (n : Type u → Type u) := + (lift {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ReaderT ρ m α) → n α) + ``` + -/ +class MonadReader (ρ : outParam (Type u)) (m : Type u → Type v) := +(read {} : m ρ) + +export MonadReader (read) + +instance monadReaderTrans {ρ : Type u} {m : Type u → Type v} {n : Type u → Type w} + [HasMonadLift m n] [MonadReader ρ m] : MonadReader ρ n := +⟨monadLift (MonadReader.read : m ρ)⟩ + +instance {ρ : Type u} {m : Type u → Type v} [Monad m] : MonadReader ρ (ReaderT ρ m) := +⟨ReaderT.read⟩ + + +/-- Adapt a Monad stack, changing the Type of its top-most environment. + + This class is comparable to [Control.Lens.Magnify](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Magnify), but does not use lenses (why would it), and is derived automatically for any transformer implementing `MonadFunctor`. + + Note: This class can be seen as a simplification of the more "principled" definition + ``` + class MonadReaderFunctor (ρ ρ' : outParam (Type u)) (n n' : Type u → Type u) := + (map {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ReaderT ρ m α → ReaderT ρ' m α) → n α → n' α) + ``` + -/ +class MonadReaderAdapter (ρ ρ' : outParam (Type u)) (m m' : Type u → Type v) := +(adaptReader {} {α : Type u} : (ρ' → ρ) → m α → m' α) +export MonadReaderAdapter (adaptReader) + +section +variables {ρ ρ' : Type u} {m m' : Type u → Type v} + +instance monadReaderAdapterTrans {n n' : Type u → Type v} [MonadFunctor m m' n n'] [MonadReaderAdapter ρ ρ' m m'] : MonadReaderAdapter ρ ρ' n n' := +⟨fun α f => monadMap (fun α => (adaptReader f : m α → m' α))⟩ + +instance [Monad m] : MonadReaderAdapter ρ ρ' (ReaderT ρ m) (ReaderT ρ' m) := +⟨fun α => ReaderT.adapt⟩ +end + +instance (ρ : Type u) (m out) [MonadRun out m] : MonadRun (fun α => ρ → out α) (ReaderT ρ m) := +⟨fun α x => run ∘ x⟩ + +class MonadReaderRunner (ρ : Type u) (m m' : Type u → Type u) := +(runReader {} {α : Type u} : m α → ρ → m' α) +export MonadReaderRunner (runReader) + +section +variables {ρ ρ' : Type u} {m m' : Type u → Type u} + +instance monadReaderRunnerTrans {n n' : Type u → Type u} [MonadFunctor m m' n n'] [MonadReaderRunner ρ m m'] : MonadReaderRunner ρ n n' := +⟨fun α x r => monadMap (fun (α) (y : m α) => (runReader y r : m' α)) x⟩ + +instance ReaderT.MonadStateRunner [Monad m] : MonadReaderRunner ρ (ReaderT ρ m) m := +⟨fun α x r => x r⟩ +end diff --git a/stage0/src/Init/Control/State.lean b/stage0/src/Init/Control/State.lean new file mode 100644 index 0000000000..27bf0cb227 --- /dev/null +++ b/stage0/src/Init/Control/State.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich + +The State monad transformer. +-/ +prelude +import Init.Control.Alternative +import Init.Control.Lift +import Init.Control.Id +import Init.Control.Except +universes u v w + +def StateT (σ : Type u) (m : Type u → Type v) (α : Type u) : Type (max u v) := +σ → m (α × σ) + +@[inline] def StateT.run {σ : Type u} {m : Type u → Type v} {α : Type u} (x : StateT σ m α) (s : σ) : m (α × σ) := +x s + +@[inline] def StateT.run' {σ : Type u} {m : Type u → Type v} [Functor m] {α : Type u} (x : StateT σ m α) (s : σ) : m α := +Prod.fst <$> x s + +@[reducible] def StateM (σ α : Type u) : Type u := StateT σ Id α + +namespace StateT +section +variables {σ : Type u} {m : Type u → Type v} +variables [Monad m] {α β : Type u} + +@[inline] protected def pure (a : α) : StateT σ m α := +fun s => pure (a, s) + +@[inline] protected def bind (x : StateT σ m α) (f : α → StateT σ m β) : StateT σ m β := +fun s => do (a, s) ← x s; f a s + +@[inline] protected def map (f : α → β) (x : StateT σ m α) : StateT σ m β := +fun s => do (a, s) ← x s; pure (f a, s) + +instance : Monad (StateT σ m) := +{ pure := @StateT.pure _ _ _, bind := @StateT.bind _ _ _, map := @StateT.map _ _ _ } + +@[inline] protected def orelse [Alternative m] {α : Type u} (x₁ x₂ : StateT σ m α) : StateT σ m α := +fun s => x₁ s <|> x₂ s + +@[inline] protected def failure [Alternative m] {α : Type u} : StateT σ m α := +fun s => failure + +instance [Alternative m] : Alternative (StateT σ m) := +{ failure := @StateT.failure _ _ _ _, + orelse := @StateT.orelse _ _ _ _, + .. StateT.Monad } + +@[inline] protected def get : StateT σ m σ := +fun s => pure (s, s) + +@[inline] protected def set : σ → StateT σ m PUnit := +fun s' s => pure (⟨⟩, s') + +@[inline] protected def modifyGet (f : σ → α × σ) : StateT σ m α := +fun s => pure (f s) + +@[inline] protected def lift {α : Type u} (t : m α) : StateT σ m α := +fun s => do a ← t; pure (a, s) + +instance : HasMonadLift m (StateT σ m) := +⟨@StateT.lift σ m _⟩ + +instance (σ m m') [Monad m] [Monad m'] : MonadFunctor m m' (StateT σ m) (StateT σ m') := +⟨fun _ f x s => f (x s)⟩ + +@[inline] protected def adapt {σ σ' σ'' α : Type u} {m : Type u → Type v} [Monad m] (split : σ → σ' × σ'') + (join : σ' → σ'' → σ) (x : StateT σ' m α) : StateT σ m α := +fun st => do + let (st, ctx) := split st; + (a, st') ← x st; + pure (a, join st' ctx) + +instance (ε) [MonadExcept ε m] : MonadExcept ε (StateT σ m) := +{ throw := fun α => StateT.lift ∘ throw, + catch := fun α x c s => catch (x s) (fun e => c e s) } +end +end StateT + +/-- An implementation of [MonadState](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-State-Class.html). + In contrast to the Haskell implementation, we use overlapping instances to derive instances + automatically from `monadLift`. -/ +class MonadState (σ : outParam (Type u)) (m : Type u → Type v) := +/- Obtain the top-most State of a Monad stack. -/ +(get {} : m σ) +/- Set the top-most State of a Monad stack. -/ +(set {} : σ → m PUnit) +/- Map the top-most State of a Monad stack. + + Note: `modifyGet f` may be preferable to `do s <- get; let (a, s) := f s; put s; pure a` + because the latter does not use the State linearly (without sufficient inlining). -/ +(modifyGet {} {α : Type u} : (σ → α × σ) → m α) + +export MonadState (get set modifyGet) + +section +variables {σ : Type u} {m : Type u → Type v} + +@[inline] def modify [MonadState σ m] (f : σ → σ) : m PUnit := +modifyGet (fun s => (PUnit.unit, f s)) + +@[inline] def getModify [MonadState σ m] [Monad m] (f : σ → σ) : m σ := +do s ← get; modify f; pure s + +-- NOTE: The Ordering of the following two instances determines that the top-most `StateT` Monad layer +-- will be picked first +instance monadStateTrans {n : Type u → Type w} [MonadState σ m] [HasMonadLift m n] : MonadState σ n := +{ get := monadLift (MonadState.get : m _), + set := fun st => monadLift (MonadState.set st : m _), + modifyGet := fun α f => monadLift (MonadState.modifyGet f : m _) } + +instance [Monad m] : MonadState σ (StateT σ m) := +{ get := StateT.get, + set := StateT.set, + modifyGet := @StateT.modifyGet _ _ _ } + +end + +/-- Adapt a Monad stack, changing the Type of its top-most State. + + This class is comparable to [Control.Lens.Zoom](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Zoom), but does not use lenses (yet?), and is derived automatically for any transformer implementing `MonadFunctor`. + + For zooming into a part of the State, the `split` Function should split σ into the part σ' and the "context" σ'' so that the potentially modified σ' and the context can be rejoined by `join` in the end. + In the simplest case, the context can be chosen as the full outer State (ie. `σ'' = σ`), which makes `split` and `join` simpler to define. However, note that the State will not be used linearly in this case. + + Example: + ``` + def zoomFst {α σ σ' : Type} : State σ α → State (σ × σ') α := + adaptState id Prod.mk + ``` + + The Function can also zoom out into a "larger" State, where the new parts are supplied by `split` and discarded by `join` in the end. The State is therefore not used linearly anymore but merely affinely, which is not a practically relevant distinction in Lean. + + Example: + ``` + def withSnd {α σ σ' : Type} (snd : σ') : State (σ × σ') α → State σ α := + adaptState (fun st => ((st, snd), ())) (fun ⟨st,snd⟩ _ => st) + ``` + + Note: This class can be seen as a simplification of the more "principled" definition + ``` + class MonadStateFunctor (σ σ' : outParam (Type u)) (n n' : Type u → Type u) := + (map {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], StateT σ m α → StateT σ' m α) → n α → n' α) + ``` + which better describes the intent of "we can map a `StateT` anywhere in the Monad stack". + If we look at the unfolded Type of the first argument `∀ m [Monad m], (σ → m (α × σ)) → σ' → m (α × σ')`, we see that it has the lens Type `∀ f [Functor f], (α → f α) → β → f β` with `f` specialized to `fun σ => m (α × σ)` (exercise: show that this is a lawful Functor). We can build all lenses we are insterested in from the functions `split` and `join` as + ``` + fun f _ st => let (st, ctx) := split st in + (fun st' => join st' ctx) <$> f st + ``` + -/ +class MonadStateAdapter (σ σ' : outParam (Type u)) (m m' : Type u → Type v) := +(adaptState {} {σ'' α : Type u} (split : σ' → σ × σ'') (join : σ → σ'' → σ') : m α → m' α) +export MonadStateAdapter (adaptState) + +section +variables {σ σ' : Type u} {m m' : Type u → Type v} + +@[inline] def MonadStateAdapter.adaptState' [MonadStateAdapter σ σ' m m'] {α : Type u} (toSigma : σ' → σ) (fromSigma : σ → σ') : m α → m' α := +adaptState (fun st => (toSigma st, PUnit.unit)) (fun st _ => fromSigma st) +export MonadStateAdapter (adaptState') + +instance monadStateAdapterTrans {n n' : Type u → Type v} [MonadStateAdapter σ σ' m m'] [MonadFunctor m m' n n'] : MonadStateAdapter σ σ' n n' := +⟨fun σ'' α split join => monadMap (fun α => (adaptState split join : m α → m' α))⟩ + +instance [Monad m] : MonadStateAdapter σ σ' (StateT σ m) (StateT σ' m) := +⟨fun σ'' α => StateT.adapt⟩ +end + +instance (σ : Type u) (m out : Type u → Type v) [MonadRun out m] [Functor m] : MonadRun (fun α => σ → out α) (StateT σ m) := +⟨fun α x => run ∘ StateT.run' x⟩ + +class MonadStateRunner (σ : Type u) (m m' : Type u → Type u) := +(runState {} {α : Type u} : m α → σ → m' α) +export MonadStateRunner (runState) + +section +variables {σ σ' : Type u} {m m' : Type u → Type u} + +instance monadStateRunnerTrans {n n' : Type u → Type u} [MonadStateRunner σ m m'] [MonadFunctor m m' n n'] : MonadStateRunner σ n n' := +⟨fun α x s => monadMap (fun (α) (y : m α) => (runState y s : m' α)) x⟩ + +instance StateT.MonadStateRunner [Monad m] : MonadStateRunner σ (StateT σ m) m := +⟨fun α x s => Prod.fst <$> x s⟩ +end diff --git a/stage0/src/Init/Core.lean b/stage0/src/Init/Core.lean new file mode 100644 index 0000000000..154214d6f5 --- /dev/null +++ b/stage0/src/Init/Core.lean @@ -0,0 +1,1764 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +notation, basic datatypes and type classes +-/ +prelude + +notation `Prop` := Sort 0 +notation f ` $ `:1 a:0 := f a + +/- Logical operations and relations -/ + +reserve prefix `¬`:40 +reserve infixr ` ∧ `:35 +reserve infixr ` /\ `:35 +reserve infixr ` \/ `:30 +reserve infixr ` ∨ `:30 +reserve infix ` <-> `:20 +reserve infix ` ↔ `:20 +reserve infix ` = `:50 +reserve infix ` == `:50 +reserve infix ` != `:50 +reserve infix ` ~= `:50 +reserve infix ` ≅ `:50 +reserve infix ` ≠ `:50 +reserve infix ` ≈ `:50 +reserve infixr ` ▸ `:75 + +/- types and Type constructors -/ + +reserve infixr ` × `:35 + +/- arithmetic operations -/ + +reserve infixl ` + `:65 +reserve infixl ` - `:65 +reserve infixl ` * `:70 +reserve infixl ` / `:70 +reserve infixl ` % `:70 +reserve infixl ` %ₙ `:70 +reserve prefix `-`:100 +reserve infixr ` ^ `:80 + +reserve infixr ` ∘ `:90 + +reserve infix ` <= `:50 +reserve infix ` ≤ `:50 +reserve infix ` < `:50 +reserve infix ` >= `:50 +reserve infix ` ≥ `:50 +reserve infix ` > `:50 + +/- boolean operations -/ + +reserve prefix `!`:40 +reserve infixl ` && `:35 +reserve infixl ` || `:30 + +/- other symbols -/ + +reserve infixl ` ++ `:65 +reserve infixr ` :: `:67 + +/- Control -/ +reserve infixr ` <|> `:2 +reserve infixr ` >>= `:55 +reserve infixr ` >=> `:55 +reserve infixl ` <*> `:60 +reserve infixl ` <* ` :60 +reserve infixr ` *> ` :60 +reserve infixr ` >> ` :60 +reserve infixr ` <$> `:100 +reserve infixr ` <$ ` :100 +reserve infixr ` $> ` :100 +reserve infixl ` <&> `:100 + +universes u v w + +/-- Auxiliary unsafe constant used by the Compiler when erasing proofs from code. -/ +unsafe axiom lcProof {α : Prop} : α +/-- Auxiliary unsafe constant used by the Compiler to mark unreachable code. -/ +unsafe axiom lcUnreachable {α : Sort u} : α + +@[inline] def id {α : Sort u} (a : α) : α := a + +def inline {α : Sort u} (a : α) : α := a + +@[inline] def flip {α : Sort u} {β : Sort v} {φ : Sort w} (f : α → β → φ) : β → α → φ := +fun b a => f a b + +/- +The kernel definitional equality test (t =?= s) has special support for idDelta applications. +It implements the following rules + + 1) (idDelta t) =?= t + 2) t =?= (idDelta t) + 3) (idDelta t) =?= s IF (unfoldOf t) =?= s + 4) t =?= idDelta s IF t =?= (unfoldOf s) + +This is mechanism for controlling the delta reduction (aka unfolding) used in the kernel. + +We use idDelta applications to address performance problems when Type checking +theorems generated by the equation Compiler. +-/ +@[inline] def idDelta {α : Sort u} (a : α) : α := +a + +/-- Gadget for optional parameter support. -/ +@[reducible] def optParam (α : Sort u) (default : α) : Sort u := +α + +/-- Gadget for marking output parameters in type classes. -/ +@[reducible] def outParam (α : Sort u) : Sort u := α + +/-- Auxiliary Declaration used to implement the notation (a : α) -/ +@[reducible] def typedExpr (α : Sort u) (a : α) : α := a + +/- `idRhs` is an auxiliary Declaration used in the equation Compiler to address performance + issues when proving equational theorems. The equation Compiler uses it as a marker. -/ +@[macroInline, reducible] def idRhs (α : Sort u) (a : α) : α := a + +inductive PUnit : Sort u +| unit : PUnit + +/-- An abbreviation for `PUnit.{0}`, its most common instantiation. + This Type should be preferred over `PUnit` where possible to avoid + unnecessary universe parameters. -/ +abbrev Unit : Type := PUnit + +@[matchPattern] abbrev Unit.unit : Unit := PUnit.unit + +/- Remark: thunks have an efficient implementation in the runtime. -/ +structure Thunk (α : Type u) : Type u := +(fn : Unit → α) + +attribute [extern "lean_mk_thunk"] Thunk.mk + +@[noinline, extern "lean_thunk_pure"] +protected def Thunk.pure {α : Type u} (a : α) : Thunk α := +⟨fun _ => a⟩ +@[noinline, extern "lean_thunk_get_own"] +protected def Thunk.get {α : Type u} (x : @& Thunk α) : α := +x.fn () +@[noinline, extern "lean_thunk_map"] +protected def Thunk.map {α : Type u} {β : Type v} (f : α → β) (x : Thunk α) : Thunk β := +⟨fun _ => f x.get⟩ +@[noinline, extern "lean_thunk_bind"] +protected def Thunk.bind {α : Type u} {β : Type v} (x : Thunk α) (f : α → Thunk β) : Thunk β := +⟨fun _ => (f x.get).get⟩ + +/- Remark: tasks have an efficient implementation in the runtime. -/ +structure Task (α : Type u) : Type u := +(fn : Unit → α) + +attribute [extern "lean_mk_task"] Task.mk + +@[noinline, extern "lean_task_pure"] +protected def Task.pure {α : Type u} (a : α) : Task α := +⟨fun _ => a⟩ +@[noinline, extern "lean_task_get"] +protected def Task.get {α : Type u} (x : @& Task α) : α := +x.fn () +@[noinline, extern "lean_task_map"] +protected def Task.map {α : Type u} {β : Type v} (f : α → β) (x : Task α) : Task β := +⟨fun _ => f x.get⟩ +@[noinline, extern "lean_task_bind"] +protected def Task.bind {α : Type u} {β : Type v} (x : Task α) (f : α → Task β) : Task β := +⟨fun _ => (f x.get).get⟩ + +inductive True : Prop +| intro : True + +inductive False : Prop + +inductive Empty : Type + +def Not (a : Prop) : Prop := a → False +prefix `¬` := Not + +inductive Eq {α : Sort u} (a : α) : α → Prop +| refl : Eq a + +@[elabAsEliminator, inline, reducible] +def Eq.ndrec.{u1, u2} {α : Sort u2} {a : α} {C : α → Sort u1} (m : C a) {b : α} (h : Eq a b) : C b := +@Eq.rec α a (fun α _ => C α) m b h + +@[elabAsEliminator, inline, reducible] +def Eq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {C : α → Sort u1} {b : α} (h : Eq a b) (m : C a) : C b := +@Eq.rec α a (fun α _ => C α) m b h + +/- +Initialize the Quotient Module, which effectively adds the following definitions: + +constant Quot {α : Sort u} (r : α → α → Prop) : Sort u + +constant Quot.mk {α : Sort u} (r : α → α → Prop) (a : α) : Quot r + +constant Quot.lift {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) : + (∀ a b : α, r a b → Eq (f a) (f b)) → Quot r → β + +constant Quot.ind {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} : + (∀ a : α, β (Quot.mk r a)) → ∀ q : Quot r, β q +-/ +init_quot + +inductive Heq {α : Sort u} (a : α) : ∀ {β : Sort u}, β → Prop +| refl : Heq a + +structure Prod (α : Type u) (β : Type v) := +(fst : α) (snd : β) + +attribute [unbox] Prod + +/-- Similar to `Prod`, but α and β can be propositions. + We use this Type internally to automatically generate the brecOn recursor. -/ +structure PProd (α : Sort u) (β : Sort v) := +(fst : α) (snd : β) + +structure And (a b : Prop) : Prop := +intro :: (left : a) (right : b) + +structure Iff (a b : Prop) : Prop := +intro :: (mp : a → b) (mpr : b → a) + +/- Eq basic support -/ + +infix `=` := Eq + +@[matchPattern] def rfl {α : Sort u} {a : α} : a = a := Eq.refl a + +@[elabAsEliminator] +theorem Eq.subst {α : Sort u} {P : α → Prop} {a b : α} (h₁ : a = b) (h₂ : P a) : P b := +Eq.ndrec h₂ h₁ + +infixr `▸` := Eq.subst + +theorem Eq.trans {α : Sort u} {a b c : α} (h₁ : a = b) (h₂ : b = c) : a = c := +h₂ ▸ h₁ + +theorem Eq.symm {α : Sort u} {a b : α} (h : a = b) : b = a := +h ▸ rfl + +infix `~=` := Heq +infix `≅` := Heq + +@[matchPattern] def Heq.rfl {α : Sort u} {a : α} : a ≅ a := Heq.refl a + +theorem eqOfHeq {α : Sort u} {a a' : α} (h : a ≅ a') : a = a' := +have ∀ (α' : Sort u) (a' : α') (h₁ : @Heq α a α' a') (h₂ : α = α'), (Eq.recOn h₂ a : α') = a' := + fun (α' : Sort u) (a' : α') (h₁ : @Heq α a α' a') => Heq.recOn h₁ (fun (h₂ : α = α) => rfl); +show (Eq.ndrecOn (Eq.refl α) a : α) = a' from + this α a' h (Eq.refl α) + +inductive Sum (α : Type u) (β : Type v) +| inl {} (val : α) : Sum +| inr {} (val : β) : Sum + +inductive PSum (α : Sort u) (β : Sort v) +| inl {} (val : α) : PSum +| inr {} (val : β) : PSum + +inductive Or (a b : Prop) : Prop +| inl {} (h : a) : Or +| inr {} (h : b) : Or + +def Or.introLeft {a : Prop} (b : Prop) (ha : a) : Or a b := +Or.inl ha + +def Or.introRight (a : Prop) {b : Prop} (hb : b) : Or a b := +Or.inr hb + +structure Sigma {α : Type u} (β : α → Type v) := +mk :: (fst : α) (snd : β fst) + +attribute [unbox] Sigma + +structure PSigma {α : Sort u} (β : α → Sort v) := +mk :: (fst : α) (snd : β fst) + +inductive Bool : Type +| false : Bool +| true : Bool + +/- Remark: Subtype must take a Sort instead of Type because of the axiom strongIndefiniteDescription. -/ +structure Subtype {α : Sort u} (p : α → Prop) := +(val : α) (property : p val) + +inductive Exists {α : Sort u} (p : α → Prop) : Prop +| intro (w : α) (h : p w) : Exists + +class inductive Decidable (p : Prop) +| isFalse (h : ¬p) : Decidable +| isTrue (h : p) : Decidable + +@[reducible] def DecidablePred {α : Sort u} (r : α → Prop) := +∀ (a : α), Decidable (r a) + +@[reducible] def DecidableRel {α : Sort u} (r : α → α → Prop) := +∀ (a b : α), Decidable (r a b) + +class DecidableEq (α : Sort u) := +{decEq : ∀ (a b : α), Decidable (a = b)} + +export DecidableEq (decEq) + +@[inline] instance decidableOfDecidableEq {α : Sort u} (a b : α) [DecidableEq α] : Decidable (a = b) := +decEq a b + +inductive Option (α : Type u) +| none {} : Option +| some (val : α) : Option + +attribute [unbox] Option + +export Option (none some) +export Bool (false true) + +inductive List (T : Type u) +| nil {} : List +| cons (hd : T) (tl : List) : List + +infixr `::` := List.cons + +inductive Nat +| zero : Nat +| succ (n : Nat) : Nat + +/- Auxiliary axiom used to implement `sorry`. + TODO: add this theorem on-demand. That is, + we should only add it if after the first error. -/ +unsafe axiom sorryAx (α : Sort u) (synthetic := true) : α + +/- Declare builtin and reserved notation -/ + +class HasZero (α : Type u) := (zero : α) +class HasOne (α : Type u) := (one : α) +class HasAdd (α : Type u) := (add : α → α → α) +class HasMul (α : Type u) := (mul : α → α → α) +class HasNeg (α : Type u) := (neg : α → α) +class HasSub (α : Type u) := (sub : α → α → α) +class HasDiv (α : Type u) := (div : α → α → α) +class HasMod (α : Type u) := (mod : α → α → α) +class HasModn (α : Type u) := (modn : α → Nat → α) +class HasLessEq (α : Type u) := (LessEq : α → α → Prop) +class HasLess (α : Type u) := (Less : α → α → Prop) +class HasBeq (α : Type u) := (beq : α → α → Bool) +class HasAppend (α : Type u) := (append : α → α → α) +class HasOrelse (α : Type u) := (orelse : α → α → α) +class HasAndthen (α : Type u) := (andthen : α → α → α) +class HasEquiv (α : Sort u) := (Equiv : α → α → Prop) +class HasEmptyc (α : Type u) := (emptyc : α) + +class HasPow (α : Type u) (β : Type v) := +(pow : α → β → α) + +export HasAndthen (andthen) +export HasPow (pow) + +infix `+` := HasAdd.add +infix `*` := HasMul.mul +infix `-` := HasSub.sub +infix `/` := HasDiv.div +infix `%` := HasMod.mod +infix `%ₙ` := HasModn.modn +prefix `-` := HasNeg.neg +infix `<=` := HasLessEq.LessEq +infix `≤` := HasLessEq.LessEq +infix `<` := HasLess.Less +infix `==` := HasBeq.beq +infix `++` := HasAppend.append +notation `∅` := HasEmptyc.emptyc _ +infix `≈` := HasEquiv.Equiv +infixr `^` := HasPow.pow +infixr `/\` := And +infixr `∧` := And +infixr `\/` := Or +infixr `∨` := Or +infix `<->` := Iff +infix `↔` := Iff +-- notation `exists` binders `, ` r:(scoped P, Exists P) := r +-- notation `∃` binders `, ` r:(scoped P, Exists P) := r +infixr `<|>` := HasOrelse.orelse +infixr `>>` := HasAndthen.andthen + +export HasAppend (append) + +@[reducible] def GreaterEq {α : Type u} [HasLessEq α] (a b : α) : Prop := HasLessEq.LessEq b a +@[reducible] def Greater {α : Type u} [HasLess α] (a b : α) : Prop := HasLess.Less b a + +infix `>=` := GreaterEq +infix `≥` := GreaterEq +infix `>` := Greater + +@[inline] def bit0 {α : Type u} [s : HasAdd α] (a : α) : α := a + a +@[inline] def bit1 {α : Type u} [s₁ : HasOne α] [s₂ : HasAdd α] (a : α) : α := (bit0 a) + 1 + +attribute [matchPattern] HasZero.zero HasOne.one bit0 bit1 HasAdd.add HasNeg.neg + +/- Nat basic instances -/ +@[extern "lean_nat_add"] +protected def Nat.add : (@& Nat) → (@& Nat) → Nat +| a, Nat.zero => a +| a, Nat.succ b => Nat.succ (Nat.add a b) + +/- We mark the following definitions as pattern to make sure they can be used in recursive equations, + and reduced by the equation Compiler. -/ +attribute [matchPattern] Nat.add Nat.add._main + +instance : HasZero Nat := ⟨Nat.zero⟩ + +instance : HasOne Nat := ⟨Nat.succ (Nat.zero)⟩ + +instance : HasAdd Nat := ⟨Nat.add⟩ + +/- Auxiliary constant used by equation compiler. -/ +constant hugeFuel : Nat := 10000 + +def std.priority.default : Nat := 1000 +def std.priority.max : Nat := 0xFFFFFFFF + +protected def Nat.prio := std.priority.default + 100 + +/- + Global declarations of right binding strength + + If a Module reassigns these, it will be incompatible with other modules that adhere to these + conventions. + + When hovering over a symbol, use "C-c C-k" to see how to input it. +-/ +def std.prec.max : Nat := 1024 -- the strength of application, identifiers, (, [, etc. +def std.prec.arrow : Nat := 25 + +/- +The next def is "max + 10". It can be used e.g. for postfix operations that should +be stronger than application. +-/ + +def std.prec.maxPlus : Nat := std.prec.max + 10 + +infixr `×` := Prod +-- notation for n-ary tuples + +/- Some type that is not a scalar value in our runtime. + TODO: mark opaque -/ +structure NonScalar := +(val : Nat) + +/- sizeof -/ + +class HasSizeof (α : Sort u) := +(sizeof : α → Nat) + +export HasSizeof (sizeof) + +/- +Declare sizeof instances and theorems for types declared before HasSizeof. +From now on, the inductive Compiler will automatically generate sizeof instances and theorems. +-/ + +/- Every Type `α` has a default HasSizeof instance that just returns 0 for every element of `α` -/ +protected def default.sizeof (α : Sort u) : α → Nat +| a => 0 + +instance defaultHasSizeof (α : Sort u) : HasSizeof α := +⟨default.sizeof α⟩ + +protected def Nat.sizeof : Nat → Nat +| n => n + +instance : HasSizeof Nat := +⟨Nat.sizeof⟩ + +protected def Prod.sizeof {α : Type u} {β : Type v} [HasSizeof α] [HasSizeof β] : (Prod α β) → Nat +| ⟨a, b⟩ => 1 + sizeof a + sizeof b + +instance (α : Type u) (β : Type v) [HasSizeof α] [HasSizeof β] : HasSizeof (Prod α β) := +⟨Prod.sizeof⟩ + +protected def Sum.sizeof {α : Type u} {β : Type v} [HasSizeof α] [HasSizeof β] : (Sum α β) → Nat +| Sum.inl a => 1 + sizeof a +| Sum.inr b => 1 + sizeof b + +instance (α : Type u) (β : Type v) [HasSizeof α] [HasSizeof β] : HasSizeof (Sum α β) := +⟨Sum.sizeof⟩ + +protected def PSum.sizeof {α : Type u} {β : Type v} [HasSizeof α] [HasSizeof β] : (PSum α β) → Nat +| PSum.inl a => 1 + sizeof a +| PSum.inr b => 1 + sizeof b + +instance (α : Type u) (β : Type v) [HasSizeof α] [HasSizeof β] : HasSizeof (PSum α β) := +⟨PSum.sizeof⟩ + +protected def Sigma.sizeof {α : Type u} {β : α → Type v} [HasSizeof α] [∀ a, HasSizeof (β a)] : Sigma β → Nat +| ⟨a, b⟩ => 1 + sizeof a + sizeof b + +instance (α : Type u) (β : α → Type v) [HasSizeof α] [∀ a, HasSizeof (β a)] : HasSizeof (Sigma β) := +⟨Sigma.sizeof⟩ + +protected def PSigma.sizeof {α : Type u} {β : α → Type v} [HasSizeof α] [∀ a, HasSizeof (β a)] : PSigma β → Nat +| ⟨a, b⟩ => 1 + sizeof a + sizeof b + +instance (α : Type u) (β : α → Type v) [HasSizeof α] [∀ a, HasSizeof (β a)] : HasSizeof (PSigma β) := +⟨PSigma.sizeof⟩ + +protected def PUnit.sizeof : PUnit → Nat +| u => 1 + +instance : HasSizeof PUnit := ⟨PUnit.sizeof⟩ + +protected def Bool.sizeof : Bool → Nat +| b => 1 + +instance : HasSizeof Bool := ⟨Bool.sizeof⟩ + +protected def Option.sizeof {α : Type u} [HasSizeof α] : Option α → Nat +| none => 1 +| some a => 1 + sizeof a + +instance (α : Type u) [HasSizeof α] : HasSizeof (Option α) := +⟨Option.sizeof⟩ + +protected def List.sizeof {α : Type u} [HasSizeof α] : List α → Nat +| List.nil => 1 +| List.cons a l => 1 + sizeof a + List.sizeof l + +instance (α : Type u) [HasSizeof α] : HasSizeof (List α) := +⟨List.sizeof⟩ + +protected def Subtype.sizeof {α : Type u} [HasSizeof α] {p : α → Prop} : Subtype p → Nat +| ⟨a, _⟩ => sizeof a + +instance {α : Type u} [HasSizeof α] (p : α → Prop) : HasSizeof (Subtype p) := +⟨Subtype.sizeof⟩ + +theorem natAddZero (n : Nat) : n + 0 = n := rfl + +theorem optParamEq (α : Sort u) (default : α) : optParam α default = α := rfl + +/-- Like `by applyInstance`, but not dependent on the tactic framework. -/ +@[reducible] def inferInstance {α : Type u} [i : α] : α := i +@[reducible, elabSimple] def inferInstanceAs (α : Type u) [i : α] : α := i + +/- Boolean operators -/ + +@[macroInline] def cond {a : Type u} : Bool → a → a → a +| true, x, y => x +| false, x, y => y + +@[macroInline] def or : Bool → Bool → Bool +| true, _ => true +| false, b => b + +@[macroInline] def and : Bool → Bool → Bool +| false, _ => false +| true, b => b + +@[macroInline] def not : Bool → Bool +| true => false +| false => true + +@[macroInline] def xor : Bool → Bool → Bool +| true, b => not b +| false, b => b + +prefix `!` := not +infix `||` := or +infix `&&` := and + +@[extern c inline "#1 || #2"] def strictOr (b₁ b₂ : Bool) := b₁ || b₂ +@[extern c inline "#1 && #2"] def strictAnd (b₁ b₂ : Bool) := b₁ && b₂ + +@[inline] def bne {α : Type u} [HasBeq α] (a b : α) : Bool := +!(a == b) + +infix `!=` := bne + +/- Logical connectives an equality -/ + +def implies (a b : Prop) := a → b + +theorem implies.trans {p q r : Prop} (h₁ : implies p q) (h₂ : implies q r) : implies p r := +fun hp => h₂ (h₁ hp) + +def trivial : True := ⟨⟩ + +@[macroInline] def False.elim {C : Sort u} (h : False) : C := +False.rec (fun _ => C) h + +@[macroInline] def absurd {a : Prop} {b : Sort v} (h₁ : a) (h₂ : ¬a) : b := +False.elim (h₂ h₁) + +theorem mt {a b : Prop} (h₁ : a → b) (h₂ : ¬b) : ¬a := +fun ha => h₂ (h₁ ha) + +theorem notFalse : ¬False := id + +-- proof irrelevance is built in +theorem proofIrrel {a : Prop} (h₁ h₂ : a) : h₁ = h₂ := rfl + +theorem id.def {α : Sort u} (a : α) : id a = a := rfl + +@[macroInline] def Eq.mp {α β : Sort u} (h₁ : α = β) (h₂ : α) : β := +Eq.recOn h₁ h₂ + +@[macroInline] def Eq.mpr {α β : Sort u} : (α = β) → β → α := +fun h₁ h₂ => Eq.recOn (Eq.symm h₁) h₂ + +@[elabAsEliminator] +theorem Eq.substr {α : Sort u} {p : α → Prop} {a b : α} (h₁ : b = a) (h₂ : p a) : p b := +Eq.subst (Eq.symm h₁) h₂ + +theorem congr {α : Sort u} {β : Sort v} {f₁ f₂ : α → β} {a₁ a₂ : α} (h₁ : f₁ = f₂) (h₂ : a₁ = a₂) : f₁ a₁ = f₂ a₂ := +Eq.subst h₁ (Eq.subst h₂ rfl) + +theorem congrFun {α : Sort u} {β : α → Sort v} {f g : ∀ x, β x} (h : f = g) (a : α) : f a = g a := +Eq.subst h (Eq.refl (f a)) + +theorem congrArg {α : Sort u} {β : Sort v} {a₁ a₂ : α} (f : α → β) (h : a₁ = a₂) : f a₁ = f a₂ := +congr rfl h + +theorem transRelLeft {α : Sort u} {a b c : α} (r : α → α → Prop) (h₁ : r a b) (h₂ : b = c) : r a c := +h₂ ▸ h₁ + +theorem transRelRight {α : Sort u} {a b c : α} (r : α → α → Prop) (h₁ : a = b) (h₂ : r b c) : r a c := +h₁.symm ▸ h₂ + +theorem ofEqTrue {p : Prop} (h : p = True) : p := +h.symm ▸ trivial + +theorem notOfEqFalse {p : Prop} (h : p = False) : ¬p := +fun hp => h ▸ hp + +@[macroInline] def cast {α β : Sort u} (h : α = β) (a : α) : β := +Eq.rec a h + +theorem castProofIrrel {α β : Sort u} (h₁ h₂ : α = β) (a : α) : cast h₁ a = cast h₂ a := rfl + +theorem castEq {α : Sort u} (h : α = α) (a : α) : cast h a = a := rfl + +@[reducible] def Ne {α : Sort u} (a b : α) := ¬(a = b) +infix `≠` := Ne + +theorem Ne.def {α : Sort u} (a b : α) : a ≠ b = ¬ (a = b) := rfl + +section Ne +variable {α : Sort u} +variables {a b : α} {p : Prop} + +theorem Ne.intro (h : a = b → False) : a ≠ b := h + +theorem Ne.elim (h : a ≠ b) : a = b → False := h + +theorem Ne.irrefl (h : a ≠ a) : False := h rfl + +theorem Ne.symm (h : a ≠ b) : b ≠ a := +fun h₁ => h (h₁.symm) + +theorem falseOfNe : a ≠ a → False := Ne.irrefl + +theorem neFalseOfSelf : p → p ≠ False := +fun (hp : p) (Heq : p = False) => Heq ▸ hp + +theorem neTrueOfNot : ¬p → p ≠ True := +fun (hnp : ¬p) (Heq : p = True) => (Heq ▸ hnp) trivial + +theorem trueNeFalse : ¬True = False := +neFalseOfSelf trivial +end Ne + +theorem eqFalseOfNeTrue : ∀ {b : Bool}, b ≠ true → b = false +| true, h => False.elim (h rfl) +| false, h => rfl + +theorem eqTrueOfNeFalse : ∀ {b : Bool}, b ≠ false → b = true +| true, h => rfl +| false, h => False.elim (h rfl) + +section +variables {α β φ : Sort u} {a a' : α} {b b' : β} {c : φ} + +@[elabAsEliminator] +theorem Heq.ndrec.{u1, u2} {α : Sort u2} {a : α} {C : ∀ {β : Sort u2}, β → Sort u1} (m : C a) {β : Sort u2} {b : β} (h : a ≅ b) : C b := +@Heq.rec α a (fun β b _ => C b) m β b h + +@[elabAsEliminator] +theorem Heq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {C : ∀ {β : Sort u2}, β → Sort u1} {β : Sort u2} {b : β} (h : a ≅ b) (m : C a) : C b := +@Heq.rec α a (fun β b _ => C b) m β b h + +theorem Heq.elim {α : Sort u} {a : α} {p : α → Sort v} {b : α} (h₁ : a ≅ b) (h₂ : p a) : p b := +Eq.recOn (eqOfHeq h₁) h₂ + +theorem Heq.subst {p : ∀ (T : Sort u), T → Prop} (h₁ : a ≅ b) (h₂ : p α a) : p β b := +Heq.ndrecOn h₁ h₂ + +theorem Heq.symm (h : a ≅ b) : b ≅ a := +Heq.ndrecOn h (Heq.refl a) + +theorem heqOfEq (h : a = a') : a ≅ a' := +Eq.subst h (Heq.refl a) + +theorem Heq.trans (h₁ : a ≅ b) (h₂ : b ≅ c) : a ≅ c := +Heq.subst h₂ h₁ + +theorem heqOfHeqOfEq (h₁ : a ≅ b) (h₂ : b = b') : a ≅ b' := +Heq.trans h₁ (heqOfEq h₂) + +theorem heqOfEqOfHeq (h₁ : a = a') (h₂ : a' ≅ b) : a ≅ b := +Heq.trans (heqOfEq h₁) h₂ + +def typeEqOfHeq (h : a ≅ b) : α = β := +Heq.ndrecOn h (Eq.refl α) +end + +theorem eqRecHeq {α : Sort u} {φ : α → Sort v} : ∀ {a a' : α} (h : a = a') (p : φ a), (Eq.recOn h p : φ a') ≅ p +| a, _, rfl, p => Heq.refl p + +theorem ofHeqTrue {a : Prop} (h : a ≅ True) : a := +ofEqTrue (eqOfHeq h) + +theorem castHeq : ∀ {α β : Sort u} (h : α = β) (a : α), cast h a ≅ a +| α, _, rfl, a => Heq.refl a + +variables {a b c d : Prop} + +theorem And.elim (h₁ : a ∧ b) (h₂ : a → b → c) : c := +And.rec h₂ h₁ + +theorem And.swap : a ∧ b → b ∧ a := +fun ⟨ha, hb⟩ => ⟨hb, ha⟩ + +def And.symm := @And.swap + +theorem Or.elim (h₁ : a ∨ b) (h₂ : a → c) (h₃ : b → c) : c := +Or.rec h₂ h₃ h₁ + +theorem Or.swap (h : a ∨ b) : b ∨ a := +Or.elim h Or.inr Or.inl + +def Or.symm := @Or.swap + +/- xor -/ +def Xor (a b : Prop) : Prop := (a ∧ ¬ b) ∨ (b ∧ ¬ a) + +theorem Iff.elim (h₁ : (a → b) → (b → a) → c) (h₂ : a ↔ b) : c := +Iff.rec h₁ h₂ + +theorem Iff.left : (a ↔ b) → a → b := Iff.mp + +theorem Iff.right : (a ↔ b) → b → a := Iff.mpr + +theorem iffIffImpliesAndImplies (a b : Prop) : (a ↔ b) ↔ (a → b) ∧ (b → a) := +Iff.intro (fun h => And.intro h.mp h.mpr) (fun h => Iff.intro h.left h.right) + +theorem Iff.refl (a : Prop) : a ↔ a := +Iff.intro (fun h => h) (fun h => h) + +theorem Iff.rfl {a : Prop} : a ↔ a := +Iff.refl a + +theorem Iff.trans (h₁ : a ↔ b) (h₂ : b ↔ c) : a ↔ c := +Iff.intro + (fun ha => Iff.mp h₂ (Iff.mp h₁ ha)) + (fun hc => Iff.mpr h₁ (Iff.mpr h₂ hc)) + +theorem Iff.symm (h : a ↔ b) : b ↔ a := +Iff.intro (Iff.right h) (Iff.left h) + +theorem Iff.comm : (a ↔ b) ↔ (b ↔ a) := +Iff.intro Iff.symm Iff.symm + +theorem Eq.toIff {a b : Prop} (h : a = b) : a ↔ b := +Eq.recOn h Iff.rfl + +theorem neqOfNotIff {a b : Prop} : ¬(a ↔ b) → a ≠ b := +fun h₁ h₂ => +have a ↔ b from Eq.subst h₂ (Iff.refl a); +absurd this h₁ + +theorem notIffNotOfIff (h₁ : a ↔ b) : ¬a ↔ ¬b := +Iff.intro + (fun (hna : ¬ a) (hb : b) => hna (Iff.right h₁ hb)) + (fun (hnb : ¬ b) (ha : a) => hnb (Iff.left h₁ ha)) + +theorem ofIffTrue (h : a ↔ True) : a := +Iff.mp (Iff.symm h) trivial + +theorem notOfIffFalse : (a ↔ False) → ¬a := Iff.mp + +theorem iffTrueIntro (h : a) : a ↔ True := +Iff.intro + (fun hl => trivial) + (fun hr => h) + +theorem iffFalseIntro (h : ¬a) : a ↔ False := +Iff.intro h (False.rec (fun _ => a)) + +theorem notNotIntro (ha : a) : ¬¬a := +fun hna => hna ha + +theorem notTrue : (¬ True) ↔ False := +iffFalseIntro (notNotIntro trivial) + +/- or resolution rulses -/ + +theorem resolveLeft {a b : Prop} (h : a ∨ b) (na : ¬ a) : b := +Or.elim h (fun ha => absurd ha na) id + +theorem negResolveLeft {a b : Prop} (h : ¬ a ∨ b) (ha : a) : b := +Or.elim h (fun na => absurd ha na) id + +theorem resolveRight {a b : Prop} (h : a ∨ b) (nb : ¬ b) : a := +Or.elim h id (fun hb => absurd hb nb) + +theorem negResolveRight {a b : Prop} (h : a ∨ ¬ b) (hb : b) : a := +Or.elim h id (fun nb => absurd hb nb) + +/- Exists -/ + +theorem Exists.elim {α : Sort u} {p : α → Prop} {b : Prop} + (h₁ : Exists (fun x => p x)) (h₂ : ∀ (a : α), p a → b) : b := +Exists.rec h₂ h₁ + +/- Decidable -/ + +@[inlineIfReduce, nospecialize] def Decidable.decide (p : Prop) [h : Decidable p] : Bool := +Decidable.casesOn h (fun h₁ => false) (fun h₂ => true) + +export Decidable (isTrue isFalse decide) + +instance beqOfEq {α : Type u} [DecidableEq α] : HasBeq α := +⟨fun a b => decide (a = b)⟩ + +theorem decideTrueEqTrue (h : Decidable True) : @decide True h = true := +Decidable.casesOn h (fun h => False.elim (Iff.mp notTrue h)) (fun _ => rfl) + +theorem decideFalseEqFalse (h : Decidable False) : @decide False h = false := +Decidable.casesOn h (fun h => rfl) (fun h => False.elim h) + +instance : Decidable True := +isTrue trivial + +instance : Decidable False := +isFalse notFalse + +-- We use "dependent" if-then-else to be able to communicate the if-then-else condition +-- to the branches +@[macroInline] def dite (c : Prop) [h : Decidable c] {α : Sort u} : (c → α) → (¬ c → α) → α := +fun t e => Decidable.casesOn h e t + +/- if-then-else -/ + +@[macroInline] def ite (c : Prop) [h : Decidable c] {α : Sort u} (t e : α) : α := +Decidable.casesOn h (fun hnc => e) (fun hc => t) + +namespace Decidable +variables {p q : Prop} + +def recOnTrue [h : Decidable p] {h₁ : p → Sort u} {h₂ : ¬p → Sort u} (h₃ : p) (h₄ : h₁ h₃) + : (Decidable.recOn h h₂ h₁ : Sort u) := +Decidable.casesOn h (fun h => False.rec _ (h h₃)) (fun h => h₄) + +def recOnFalse [h : Decidable p] {h₁ : p → Sort u} {h₂ : ¬p → Sort u} (h₃ : ¬p) (h₄ : h₂ h₃) + : (Decidable.recOn h h₂ h₁ : Sort u) := +Decidable.casesOn h (fun h => h₄) (fun h => False.rec _ (h₃ h)) + +@[macroInline] def byCases {q : Sort u} [s : Decidable p] (h1 : p → q) (h2 : ¬p → q) : q := +match s with +| isTrue h => h1 h +| isFalse h => h2 h + +theorem em (p : Prop) [Decidable p] : p ∨ ¬p := +byCases Or.inl Or.inr + +theorem byContradiction [Decidable p] (h : ¬p → False) : p := +byCases id (fun np => False.elim (h np)) + +theorem ofNotNot [Decidable p] : ¬ ¬ p → p := +fun hnn => byContradiction (fun hn => absurd hn hnn) + +theorem notNotIff (p) [Decidable p] : (¬ ¬ p) ↔ p := +Iff.intro ofNotNot notNotIntro + +theorem notAndIffOrNot (p q : Prop) [d₁ : Decidable p] [d₂ : Decidable q] : ¬ (p ∧ q) ↔ ¬ p ∨ ¬ q := +Iff.intro +(fun h => match d₁, d₂ with + | isTrue h₁, isTrue h₂ => absurd (And.intro h₁ h₂) h + | _, isFalse h₂ => Or.inr h₂ + | isFalse h₁, _ => Or.inl h₁) +(fun (h) ⟨hp, hq⟩ => Or.elim h (fun h => h hp) (fun h => h hq)) + +end Decidable + +section +variables {p q : Prop} +@[inline] def decidableOfDecidableOfIff (hp : Decidable p) (h : p ↔ q) : Decidable q := +if hp : p then isTrue (Iff.mp h hp) +else isFalse (Iff.mp (notIffNotOfIff h) hp) + +@[inline] def decidableOfDecidableOfEq (hp : Decidable p) (h : p = q) : Decidable q := +decidableOfDecidableOfIff hp h.toIff +end + +section +variables {p q : Prop} + +@[macroInline] instance [Decidable p] [Decidable q] : Decidable (p ∧ q) := +if hp : p then + if hq : q then isTrue ⟨hp, hq⟩ + else isFalse (fun h => hq (And.right h)) +else isFalse (fun h => hp (And.left h)) + +@[macroInline] instance [Decidable p] [Decidable q] : Decidable (p ∨ q) := +if hp : p then isTrue (Or.inl hp) else + if hq : q then isTrue (Or.inr hq) else + isFalse (fun h => Or.elim h hp hq) + +instance [Decidable p] : Decidable (¬p) := +if hp : p then isFalse (absurd hp) else isTrue hp + +@[macroInline] instance implies.Decidable [Decidable p] [Decidable q] : Decidable (p → q) := +if hp : p then + if hq : q then isTrue (fun h => hq) + else isFalse (fun h => absurd (h hp) hq) +else isTrue (fun h => absurd h hp) + +instance [Decidable p] [Decidable q] : Decidable (p ↔ q) := +if hp : p then + if hq : q then isTrue ⟨fun _ => hq, fun _ => hp⟩ + else isFalse $ fun h => hq (h.1 hp) +else + if hq : q then isFalse $ fun h => hp (h.2 hq) + else isTrue $ ⟨fun h => absurd h hp, fun h => absurd h hq⟩ + +instance [Decidable p] [Decidable q] : Decidable (Xor p q) := +if hp : p then + if hq : q then isFalse (fun h => Or.elim h (fun ⟨_, h⟩ => h hq : ¬(p ∧ ¬ q)) (fun ⟨_, h⟩ => h hp : ¬(q ∧ ¬ p))) + else isTrue $ Or.inl ⟨hp, hq⟩ +else + if hq : q then isTrue $ Or.inr ⟨hq, hp⟩ + else isFalse (fun h => Or.elim h (fun ⟨h, _⟩ => hp h : ¬(p ∧ ¬ q)) (fun ⟨h, _⟩ => hq h : ¬(q ∧ ¬ p))) + +end + +@[inline] instance {α : Sort u} [DecidableEq α] (a b : α) : Decidable (a ≠ b) := +match decEq a b with +| isTrue h => isFalse $ fun h' => absurd h h' +| isFalse h => isTrue h + +theorem Bool.falseNeTrue (h : false = true) : False := +Bool.noConfusion h + +instance : DecidableEq Bool := +{decEq := fun a b => match a, b with + | false, false => isTrue rfl + | false, true => isFalse Bool.falseNeTrue + | true, false => isFalse (Ne.symm Bool.falseNeTrue) + | true, true => isTrue rfl} + +/- if-then-else expression theorems -/ + +theorem ifPos {c : Prop} [h : Decidable c] (hc : c) {α : Sort u} {t e : α} : (ite c t e) = t := +match h with +| (isTrue hc) => rfl +| (isFalse hnc) => absurd hc hnc + +theorem ifNeg {c : Prop} [h : Decidable c] (hnc : ¬c) {α : Sort u} {t e : α} : (ite c t e) = e := +match h with +| (isTrue hc) => absurd hc hnc +| (isFalse hnc) => rfl + +-- Remark: dite and ite are "defally equal" when we ignore the proofs. +theorem difEqIf (c : Prop) [h : Decidable c] {α : Sort u} (t : α) (e : α) : dite c (fun h => t) (fun h => e) = ite c t e := +match h with +| (isTrue hc) => rfl +| (isFalse hnc) => rfl + +instance {c t e : Prop} [dC : Decidable c] [dT : Decidable t] [dE : Decidable e] : Decidable (if c then t else e) := +match dC with +| (isTrue hc) => dT +| (isFalse hc) => dE + +instance {c : Prop} {t : c → Prop} {e : ¬c → Prop} [dC : Decidable c] [dT : ∀ h, Decidable (t h)] [dE : ∀ h, Decidable (e h)] : Decidable (if h : c then t h else e h) := +match dC with +| (isTrue hc) => dT hc +| (isFalse hc) => dE hc + +/-- Universe lifting operation -/ +structure ULift.{r, s} (α : Type s) : Type (max s r) := +up :: (down : α) + +namespace ULift +/- Bijection between α and ULift.{v} α -/ +theorem upDown {α : Type u} : ∀ (b : ULift.{v} α), up (down b) = b +| up a => rfl + +theorem downUp {α : Type u} (a : α) : down (up.{v} a) = a := rfl +end ULift + +/-- Universe lifting operation from Sort to Type -/ +structure PLift (α : Sort u) : Type u := +up :: (down : α) + +namespace PLift +/- Bijection between α and PLift α -/ +theorem upDown {α : Sort u} : ∀ (b : PLift α), up (down b) = b +| up a => rfl + +theorem downUp {α : Sort u} (a : α) : down (up a) = a := rfl +end PLift + +/- pointed types -/ +structure PointedType := +(type : Type u) (val : type) + +/- Inhabited -/ + +class Inhabited (α : Sort u) := +(default : α) + +constant arbitrary (α : Sort u) [Inhabited α] : α := +Inhabited.default α + +instance Prop.Inhabited : Inhabited Prop := +⟨True⟩ + +instance Fun.Inhabited (α : Sort u) {β : Sort v} [h : Inhabited β] : Inhabited (α → β) := +Inhabited.casesOn h (fun b => ⟨fun a => b⟩) + +instance Forall.Inhabited (α : Sort u) {β : α → Sort v} [∀ x, Inhabited (β x)] : Inhabited (∀ x, β x) := +⟨fun a => arbitrary (β a)⟩ + +instance : Inhabited Bool := ⟨false⟩ + +instance : Inhabited True := ⟨trivial⟩ + +instance : Inhabited Nat := ⟨0⟩ + +instance : Inhabited NonScalar := ⟨⟨arbitrary _⟩⟩ + +instance : Inhabited PointedType := ⟨{type := PUnit, val := ⟨⟩}⟩ + +class inductive Nonempty (α : Sort u) : Prop +| intro (val : α) : Nonempty + +protected def Nonempty.elim {α : Sort u} {p : Prop} (h₁ : Nonempty α) (h₂ : α → p) : p := +Nonempty.rec h₂ h₁ + +instance nonemptyOfInhabited {α : Sort u} [Inhabited α] : Nonempty α := +⟨arbitrary α⟩ + +theorem nonemptyOfExists {α : Sort u} {p : α → Prop} : Exists (fun x => p x) → Nonempty α +| ⟨w, h⟩ => ⟨w⟩ + +/- Subsingleton -/ + +class inductive Subsingleton (α : Sort u) : Prop +| intro (h : ∀ (a b : α), a = b) : Subsingleton + +protected def Subsingleton.elim {α : Sort u} [h : Subsingleton α] : ∀ (a b : α), a = b := +Subsingleton.casesOn h (fun p => p) + +protected def Subsingleton.helim {α β : Sort u} [h : Subsingleton α] (h : α = β) : ∀ (a : α) (b : β), a ≅ b := +Eq.recOn h (fun a b => heqOfEq (Subsingleton.elim a b)) + +instance subsingletonProp (p : Prop) : Subsingleton p := +⟨fun a b => proofIrrel a b⟩ + +instance (p : Prop) : Subsingleton (Decidable p) := +Subsingleton.intro $ fun d₁ => + match d₁ with + | (isTrue t₁) => fun d₂ => + match d₂ with + | (isTrue t₂) => Eq.recOn (proofIrrel t₁ t₂) rfl + | (isFalse f₂) => absurd t₁ f₂ + | (isFalse f₁) => fun d₂ => + match d₂ with + | (isTrue t₂) => absurd t₂ f₁ + | (isFalse f₂) => Eq.recOn (proofIrrel f₁ f₂) rfl + +protected theorem recSubsingleton {p : Prop} [h : Decidable p] {h₁ : p → Sort u} {h₂ : ¬p → Sort u} + [h₃ : ∀ (h : p), Subsingleton (h₁ h)] [h₄ : ∀ (h : ¬p), Subsingleton (h₂ h)] + : Subsingleton (Decidable.casesOn h h₂ h₁) := +match h with +| (isTrue h) => h₃ h +| (isFalse h) => h₄ h + +section relation +variables {α : Sort u} {β : Sort v} (r : β → β → Prop) + +def Reflexive := ∀ x, r x x + +def Symmetric := ∀ {x y}, r x y → r y x + +def Transitive := ∀ {x y z}, r x y → r y z → r x z + +def Equivalence := Reflexive r ∧ Symmetric r ∧ Transitive r + +def Total := ∀ x y, r x y ∨ r y x + +def mkEquivalence (rfl : Reflexive r) (symm : Symmetric r) (trans : Transitive r) : Equivalence r := +⟨rfl, @symm, @trans⟩ + +def Irreflexive := ∀ x, ¬ r x x + +def AntiSymmetric := ∀ {x y}, r x y → r y x → x = y + +def emptyRelation (a₁ a₂ : α) : Prop := False + +def Subrelation (q r : β → β → Prop) := ∀ {x y}, q x y → r x y + +def InvImage (f : α → β) : α → α → Prop := +fun a₁ a₂ => r (f a₁) (f a₂) + +theorem InvImage.Transitive (f : α → β) (h : Transitive r) : Transitive (InvImage r f) := +fun (a₁ a₂ a₃ : α) (h₁ : InvImage r f a₁ a₂) (h₂ : InvImage r f a₂ a₃) => h h₁ h₂ + +theorem InvImage.Irreflexive (f : α → β) (h : Irreflexive r) : Irreflexive (InvImage r f) := +fun (a : α) (h₁ : InvImage r f a a) => h (f a) h₁ + +inductive TC {α : Sort u} (r : α → α → Prop) : α → α → Prop +| base : ∀ a b, r a b → TC a b +| trans : ∀ a b c, TC a b → TC b c → TC a c + +@[elabAsEliminator] +theorem TC.ndrec.{u1, u2} {α : Sort u} {r : α → α → Prop} {C : α → α → Prop} + (m₁ : ∀ (a b : α), r a b → C a b) + (m₂ : ∀ (a b c : α), TC r a b → TC r b c → C a b → C b c → C a c) + {a b : α} (h : TC r a b) : C a b := +@TC.rec α r (fun a b _ => C a b) m₁ m₂ a b h + +@[elabAsEliminator] +theorem TC.ndrecOn.{u1, u2} {α : Sort u} {r : α → α → Prop} {C : α → α → Prop} + {a b : α} (h : TC r a b) + (m₁ : ∀ (a b : α), r a b → C a b) + (m₂ : ∀ (a b c : α), TC r a b → TC r b c → C a b → C b c → C a c) + : C a b := +@TC.rec α r (fun a b _ => C a b) m₁ m₂ a b h + +end relation + +section Binary +variables {α : Type u} {β : Type v} +variable (f : α → α → α) + +def Commutative := ∀ a b, f a b = f b a +def Associative := ∀ a b c, f (f a b) c = f a (f b c) +def RightCommutative (h : β → α → β) := ∀ b a₁ a₂, h (h b a₁) a₂ = h (h b a₂) a₁ +def LeftCommutative (h : α → β → β) := ∀ a₁ a₂ b, h a₁ (h a₂ b) = h a₂ (h a₁ b) + +theorem leftComm : Commutative f → Associative f → LeftCommutative f := +fun hcomm hassoc a b c => +((Eq.symm (hassoc a b c)).trans (hcomm a b ▸ rfl : f (f a b) c = f (f b a) c)).trans (hassoc b a c) + +theorem rightComm : Commutative f → Associative f → RightCommutative f := +fun hcomm hassoc a b c => +((hassoc a b c).trans (hcomm b c ▸ rfl : f a (f b c) = f a (f c b))).trans (Eq.symm (hassoc a c b)) + +end Binary + +/- Subtype -/ + +namespace Subtype +def existsOfSubtype {α : Type u} {p : α → Prop} : { x // p x } → Exists (fun x => p x) +| ⟨a, h⟩ => ⟨a, h⟩ + +variables {α : Type u} {p : α → Prop} + +theorem tagIrrelevant {a : α} (h1 h2 : p a) : mk a h1 = mk a h2 := +rfl + +protected theorem eq : ∀ {a1 a2 : {x // p x}}, val a1 = val a2 → a1 = a2 +| ⟨x, h1⟩, ⟨.(x), h2⟩, rfl => rfl + +theorem eta (a : {x // p x}) (h : p (val a)) : mk (val a) h = a := +Subtype.eq rfl + +instance {α : Type u} {p : α → Prop} {a : α} (h : p a) : Inhabited {x // p x} := +⟨⟨a, h⟩⟩ + +instance {α : Type u} {p : α → Prop} [DecidableEq α] : DecidableEq {x : α // p x} := +{decEq := fun ⟨a, h₁⟩ ⟨b, h₂⟩ => + if h : a = b then isTrue (Subtype.eq h) + else isFalse (fun h' => Subtype.noConfusion h' (fun h' => absurd h' h))} +end Subtype + +/- Sum -/ + +section +variables {α : Type u} {β : Type v} + +instance Sum.inhabitedLeft [h : Inhabited α] : Inhabited (Sum α β) := +⟨Sum.inl (arbitrary α)⟩ + +instance Sum.inhabitedRight [h : Inhabited β] : Inhabited (Sum α β) := +⟨Sum.inr (arbitrary β)⟩ + +instance {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] : DecidableEq (Sum α β) := +{decEq := fun a b => + match a, b with + | (Sum.inl a), (Sum.inl b) => + if h : a = b then isTrue (h ▸ rfl) + else isFalse (fun h' => Sum.noConfusion h' (fun h' => absurd h' h)) + | (Sum.inr a), (Sum.inr b) => + if h : a = b then isTrue (h ▸ rfl) + else isFalse (fun h' => Sum.noConfusion h' (fun h' => absurd h' h)) + | (Sum.inr a), (Sum.inl b) => isFalse (fun h => Sum.noConfusion h) + | (Sum.inl a), (Sum.inr b) => isFalse (fun h => Sum.noConfusion h)} +end + +/- Product -/ + +section +variables {α : Type u} {β : Type v} + +instance [Inhabited α] [Inhabited β] : Inhabited (Prod α β) := +⟨(arbitrary α, arbitrary β)⟩ + +instance [DecidableEq α] [DecidableEq β] : DecidableEq (α × β) := +{decEq := fun ⟨a, b⟩ ⟨a', b'⟩ => + match (decEq a a') with + | (isTrue e₁) => + match (decEq b b') with + | (isTrue e₂) => isTrue (Eq.recOn e₁ (Eq.recOn e₂ rfl)) + | (isFalse n₂) => isFalse (fun h => Prod.noConfusion h (fun e₁' e₂' => absurd e₂' n₂)) + | (isFalse n₁) => isFalse (fun h => Prod.noConfusion h (fun e₁' e₂' => absurd e₁' n₁))} + +instance [HasBeq α] [HasBeq β] : HasBeq (α × β) := +⟨fun ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ => a₁ == a₂ && b₁ == b₂⟩ + +instance [HasLess α] [HasLess β] : HasLess (α × β) := +⟨fun s t => s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)⟩ + +instance prodHasDecidableLt + [HasLess α] [HasLess β] [DecidableEq α] [DecidableEq β] + [∀ (a b : α), Decidable (a < b)] [∀ (a b : β), Decidable (a < b)] + : ∀ (s t : α × β), Decidable (s < t) := +fun t s => Or.Decidable + +theorem Prod.ltDef [HasLess α] [HasLess β] (s t : α × β) : (s < t) = (s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)) := +rfl +end + +def Prod.map.{u₁, u₂, v₁, v₂} {α₁ : Type u₁} {α₂ : Type u₂} {β₁ : Type v₁} {β₂ : Type v₂} + (f : α₁ → α₂) (g : β₁ → β₂) : α₁ × β₁ → α₂ × β₂ +| (a, b) => (f a, g b) + +/- Dependent products -/ + +-- notation `Σ` binders `, ` r:(scoped p, Sigma p) := r +-- notation `Σ'` binders `, ` r:(scoped p, PSigma p) := r + +theorem exOfPsig {α : Type u} {p : α → Prop} : (PSigma (fun x => p x)) → Exists (fun x => p x) +| ⟨x, hx⟩ => ⟨x, hx⟩ + +section +variables {α : Type u} {β : α → Type v} + +protected theorem Sigma.eq : ∀ {p₁ p₂ : Sigma (fun a => β a)} (h₁ : p₁.1 = p₂.1), (Eq.recOn h₁ p₁.2 : β p₂.1) = p₂.2 → p₁ = p₂ +| ⟨a, b⟩, ⟨.(a), .(b)⟩, rfl, rfl => rfl +end + +section +variables {α : Sort u} {β : α → Sort v} + +protected theorem PSigma.eq : ∀ {p₁ p₂ : PSigma β} (h₁ : p₁.1 = p₂.1), (Eq.recOn h₁ p₁.2 : β p₂.1) = p₂.2 → p₁ = p₂ +| ⟨a, b⟩, ⟨.(a), .(b)⟩, rfl, rfl => rfl +end + +/- Universe polymorphic unit -/ + +theorem punitEq (a b : PUnit) : a = b := +PUnit.recOn a (PUnit.recOn b rfl) + +theorem punitEqPUnit (a : PUnit) : a = () := +punitEq a () + +instance : Subsingleton PUnit := +Subsingleton.intro punitEq + +instance : Inhabited PUnit := +⟨⟨⟩⟩ + +instance : DecidableEq PUnit := +{decEq := fun a b => isTrue (punitEq a b)} + +/- Setoid -/ + +class Setoid (α : Sort u) := +(r : α → α → Prop) (iseqv : Equivalence r) + +instance setoidHasEquiv {α : Sort u} [Setoid α] : HasEquiv α := +⟨Setoid.r⟩ + +namespace Setoid +variables {α : Sort u} [Setoid α] + +theorem refl (a : α) : a ≈ a := +match Setoid.iseqv α with +| ⟨hRefl, hSymm, hTrans⟩ => hRefl a + +theorem symm {a b : α} (hab : a ≈ b) : b ≈ a := +match Setoid.iseqv α with +| ⟨hRefl, hSymm, hTrans⟩ => hSymm hab + +theorem trans {a b c : α} (hab : a ≈ b) (hbc : b ≈ c) : a ≈ c := +match Setoid.iseqv α with +| ⟨hRefl, hSymm, hTrans⟩ => hTrans hab hbc +end Setoid + +/- Propositional extensionality -/ + +axiom propext {a b : Prop} : (a ↔ b) → a = b + +theorem eqTrueIntro {a : Prop} (h : a) : a = True := +propext (iffTrueIntro h) + +theorem eqFalseIntro {a : Prop} (h : ¬a) : a = False := +propext (iffFalseIntro h) + +/- Quotients -/ + +-- Iff can now be used to do substitutions in a calculation +theorem iffSubst {a b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b := +Eq.subst (propext h₁) h₂ + +namespace Quot +axiom sound : ∀ {α : Sort u} {r : α → α → Prop} {a b : α}, r a b → Quot.mk r a = Quot.mk r b + +attribute [elabAsEliminator] lift ind + +protected theorem liftBeta {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) (c : ∀ a b, r a b → f a = f b) (a : α) : lift f c (Quot.mk r a) = f a := +rfl + +protected theorem indBeta {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (p : ∀ a, β (Quot.mk r a)) (a : α) : (ind p (Quot.mk r a) : β (Quot.mk r a)) = p a := +rfl + +@[reducible, elabAsEliminator, inline] +protected def liftOn {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β) (c : ∀ a b, r a b → f a = f b) : β := +lift f c q + +@[elabAsEliminator] +protected theorem inductionOn {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (q : Quot r) (h : ∀ a, β (Quot.mk r a)) : β q := +ind h q + +theorem existsRep {α : Sort u} {r : α → α → Prop} (q : Quot r) : Exists (fun a => (Quot.mk r a) = q) := +Quot.inductionOn q (fun a => ⟨a, rfl⟩) + +section +variable {α : Sort u} +variable {r : α → α → Prop} +variable {β : Quot r → Sort v} + +@[reducible, macroInline] +protected def indep (f : ∀ a, β (Quot.mk r a)) (a : α) : PSigma β := +⟨Quot.mk r a, f a⟩ + +protected theorem indepCoherent (f : ∀ a, β (Quot.mk r a)) + (h : ∀ (a b : α) (p : r a b), (Eq.rec (f a) (sound p) : β (Quot.mk r b)) = f b) + : ∀ a b, r a b → Quot.indep f a = Quot.indep f b := +fun a b e => PSigma.eq (sound e) (h a b e) + +protected theorem liftIndepPr1 + (f : ∀ a, β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), (Eq.rec (f a) (sound p) : β (Quot.mk r b)) = f b) + (q : Quot r) : (lift (Quot.indep f) (Quot.indepCoherent f h) q).1 = q := +Quot.ind (fun (a : α) => Eq.refl (Quot.indep f a).1) q + +@[reducible, elabAsEliminator, inline] +protected def rec + (f : ∀ a, β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), (Eq.rec (f a) (sound p) : β (Quot.mk r b)) = f b) + (q : Quot r) : β q := +Eq.ndrecOn (Quot.liftIndepPr1 f h q) ((lift (Quot.indep f) (Quot.indepCoherent f h) q).2) + +@[reducible, elabAsEliminator, inline] +protected def recOn + (q : Quot r) (f : ∀ a, β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), (Eq.rec (f a) (sound p) : β (Quot.mk r b)) = f b) : β q := +Quot.rec f h q + +@[reducible, elabAsEliminator, inline] +protected def recOnSubsingleton + [h : ∀ a, Subsingleton (β (Quot.mk r a))] (q : Quot r) (f : ∀ a, β (Quot.mk r a)) : β q := +Quot.rec f (fun a b h => Subsingleton.elim _ (f b)) q + +@[reducible, elabAsEliminator, inline] +protected def hrecOn + (q : Quot r) (f : ∀ a, β (Quot.mk r a)) (c : ∀ (a b : α) (p : r a b), f a ≅ f b) : β q := +Quot.recOn q f $ + fun a b p => eqOfHeq $ + have p₁ : (Eq.rec (f a) (sound p) : β (Quot.mk r b)) ≅ f a := eqRecHeq (sound p) (f a); + Heq.trans p₁ (c a b p) + +end +end Quot + +def Quotient {α : Sort u} (s : Setoid α) := +@Quot α Setoid.r + +namespace Quotient + +@[inline] +protected def mk {α : Sort u} [s : Setoid α] (a : α) : Quotient s := +Quot.mk Setoid.r a + +def sound {α : Sort u} [s : Setoid α] {a b : α} : a ≈ b → Quotient.mk a = Quotient.mk b := +Quot.sound + +@[reducible, elabAsEliminator] +protected def lift {α : Sort u} {β : Sort v} [s : Setoid α] (f : α → β) : (∀ a b, a ≈ b → f a = f b) → Quotient s → β := +Quot.lift f + +@[elabAsEliminator] +protected theorem ind {α : Sort u} [s : Setoid α] {β : Quotient s → Prop} : (∀ a, β (Quotient.mk a)) → ∀ q, β q := +Quot.ind + +@[reducible, elabAsEliminator, inline] +protected def liftOn {α : Sort u} {β : Sort v} [s : Setoid α] (q : Quotient s) (f : α → β) (c : ∀ a b, a ≈ b → f a = f b) : β := +Quot.liftOn q f c + +@[elabAsEliminator] +protected theorem inductionOn {α : Sort u} [s : Setoid α] {β : Quotient s → Prop} (q : Quotient s) (h : ∀ a, β (Quotient.mk a)) : β q := +Quot.inductionOn q h + +theorem existsRep {α : Sort u} [s : Setoid α] (q : Quotient s) : Exists (fun (a : α) => Quotient.mk a = q) := +Quot.existsRep q + +section +variable {α : Sort u} +variable [s : Setoid α] +variable {β : Quotient s → Sort v} + +@[inline] +protected def rec + (f : ∀ a, β (Quotient.mk a)) (h : ∀ (a b : α) (p : a ≈ b), (Eq.rec (f a) (Quotient.sound p) : β (Quotient.mk b)) = f b) + (q : Quotient s) : β q := +Quot.rec f h q + +@[reducible, elabAsEliminator, inline] +protected def recOn + (q : Quotient s) (f : ∀ a, β (Quotient.mk a)) (h : ∀ (a b : α) (p : a ≈ b), (Eq.rec (f a) (Quotient.sound p) : β (Quotient.mk b)) = f b) : β q := +Quot.recOn q f h + +@[reducible, elabAsEliminator, inline] +protected def recOnSubsingleton + [h : ∀ a, Subsingleton (β (Quotient.mk a))] (q : Quotient s) (f : ∀ a, β (Quotient.mk a)) : β q := +@Quot.recOnSubsingleton _ _ _ h q f + +@[reducible, elabAsEliminator, inline] +protected def hrecOn + (q : Quotient s) (f : ∀ a, β (Quotient.mk a)) (c : ∀ (a b : α) (p : a ≈ b), f a ≅ f b) : β q := +Quot.hrecOn q f c +end + +section +universes uA uB uC +variables {α : Sort uA} {β : Sort uB} {φ : Sort uC} +variables [s₁ : Setoid α] [s₂ : Setoid β] + +@[reducible, elabAsEliminator, inline] +protected def lift₂ + (f : α → β → φ)(c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) + (q₁ : Quotient s₁) (q₂ : Quotient s₂) : φ := +Quotient.lift + (fun (a₁ : α) => Quotient.lift (f a₁) (fun (a b : β) => c a₁ a a₁ b (Setoid.refl a₁)) q₂) + (fun (a b : α) (h : a ≈ b) => + @Quotient.ind β s₂ + (fun (a1 : Quotient s₂) => + (Quotient.lift (f a) (fun (a1 b : β) => c a a1 a b (Setoid.refl a)) a1) + = + (Quotient.lift (f b) (fun (a b1 : β) => c b a b b1 (Setoid.refl b)) a1)) + (fun (a' : β) => c a a' b a' h (Setoid.refl a')) + q₂) + q₁ + +@[reducible, elabAsEliminator, inline] +protected def liftOn₂ + (q₁ : Quotient s₁) (q₂ : Quotient s₂) (f : α → β → φ) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : φ := +Quotient.lift₂ f c q₁ q₂ + +@[elabAsEliminator] +protected theorem ind₂ {φ : Quotient s₁ → Quotient s₂ → Prop} (h : ∀ a b, φ (Quotient.mk a) (Quotient.mk b)) (q₁ : Quotient s₁) (q₂ : Quotient s₂) : φ q₁ q₂ := +Quotient.ind (fun a₁ => Quotient.ind (fun a₂ => h a₁ a₂) q₂) q₁ + +@[elabAsEliminator] +protected theorem inductionOn₂ + {φ : Quotient s₁ → Quotient s₂ → Prop} (q₁ : Quotient s₁) (q₂ : Quotient s₂) (h : ∀ a b, φ (Quotient.mk a) (Quotient.mk b)) : φ q₁ q₂ := +Quotient.ind (fun a₁ => Quotient.ind (fun a₂ => h a₁ a₂) q₂) q₁ + +@[elabAsEliminator] +protected theorem inductionOn₃ + [s₃ : Setoid φ] + {δ : Quotient s₁ → Quotient s₂ → Quotient s₃ → Prop} (q₁ : Quotient s₁) (q₂ : Quotient s₂) (q₃ : Quotient s₃) (h : ∀ a b c, δ (Quotient.mk a) (Quotient.mk b) (Quotient.mk c)) + : δ q₁ q₂ q₃ := +Quotient.ind (fun a₁ => Quotient.ind (fun a₂ => Quotient.ind (fun a₃ => h a₁ a₂ a₃) q₃) q₂) q₁ +end + +section Exact +variable {α : Sort u} + +private def rel [s : Setoid α] (q₁ q₂ : Quotient s) : Prop := +Quotient.liftOn₂ q₁ q₂ + (fun a₁ a₂ => a₁ ≈ a₂) + (fun a₁ a₂ b₁ b₂ a₁b₁ a₂b₂ => + propext (Iff.intro + (fun a₁a₂ => Setoid.trans (Setoid.symm a₁b₁) (Setoid.trans a₁a₂ a₂b₂)) + (fun b₁b₂ => Setoid.trans a₁b₁ (Setoid.trans b₁b₂ (Setoid.symm a₂b₂))))) + +private theorem rel.refl [s : Setoid α] : ∀ (q : Quotient s), rel q q := +fun q => Quot.inductionOn q (fun a => Setoid.refl a) + +private theorem eqImpRel [s : Setoid α] {q₁ q₂ : Quotient s} : q₁ = q₂ → rel q₁ q₂ := +fun h => Eq.ndrecOn h (rel.refl q₁) + +theorem exact [s : Setoid α] {a b : α} : Quotient.mk a = Quotient.mk b → a ≈ b := +fun h => eqImpRel h +end Exact + +section +universes uA uB uC +variables {α : Sort uA} {β : Sort uB} +variables [s₁ : Setoid α] [s₂ : Setoid β] + +@[reducible, elabAsEliminator] +protected def recOnSubsingleton₂ + {φ : Quotient s₁ → Quotient s₂ → Sort uC} [h : ∀ a b, Subsingleton (φ (Quotient.mk a) (Quotient.mk b))] + (q₁ : Quotient s₁) (q₂ : Quotient s₂) (f : ∀ a b, φ (Quotient.mk a) (Quotient.mk b)) : φ q₁ q₂:= +@Quotient.recOnSubsingleton _ s₁ (fun q => φ q q₂) (fun a => Quotient.ind (fun b => h a b) q₂) q₁ + (fun a => Quotient.recOnSubsingleton q₂ (fun b => f a b)) + +end +end Quotient + +section +variable {α : Type u} +variable (r : α → α → Prop) + +inductive EqvGen : α → α → Prop +| rel {} : ∀ x y, r x y → EqvGen x y +| refl {} : ∀ x, EqvGen x x +| symm {} : ∀ x y, EqvGen x y → EqvGen y x +| trans {} : ∀ x y z, EqvGen x y → EqvGen y z → EqvGen x z + +theorem EqvGen.isEquivalence : Equivalence (@EqvGen α r) := +mkEquivalence _ EqvGen.refl EqvGen.symm EqvGen.trans + +def EqvGen.Setoid : Setoid α := +Setoid.mk _ (EqvGen.isEquivalence r) + +theorem Quot.exact {a b : α} (H : Quot.mk r a = Quot.mk r b) : EqvGen r a b := +@Quotient.exact _ (EqvGen.Setoid r) a b (@congrArg _ _ _ _ + (Quot.lift (@Quotient.mk _ (EqvGen.Setoid r)) (fun x y h => Quot.sound (EqvGen.rel x y h))) H) + +theorem Quot.eqvGenSound {r : α → α → Prop} {a b : α} (H : EqvGen r a b) : Quot.mk r a = Quot.mk r b := +EqvGen.recOn H + (fun x y h => Quot.sound h) + (fun x => rfl) + (fun x y _ IH => Eq.symm IH) + (fun x y z _ _ IH₁ IH₂ => Eq.trans IH₁ IH₂) +end + +instance {α : Sort u} {s : Setoid α} [d : ∀ (a b : α), Decidable (a ≈ b)] : DecidableEq (Quotient s) := +{decEq := fun (q₁ q₂ : Quotient s) => + Quotient.recOnSubsingleton₂ q₁ q₂ + (fun a₁ a₂ => + match (d a₁ a₂) with + | (isTrue h₁) => isTrue (Quotient.sound h₁) + | (isFalse h₂) => isFalse (fun h => absurd (Quotient.exact h) h₂))} + +/- Function extensionality -/ + +namespace Function +variables {α : Sort u} {β : α → Sort v} + +def Equiv (f₁ f₂ : ∀ (x : α), β x) : Prop := ∀ x, f₁ x = f₂ x + +protected theorem Equiv.refl (f : ∀ (x : α), β x) : Equiv f f := +fun x => rfl + +protected theorem Equiv.symm {f₁ f₂ : ∀ (x : α), β x} : Equiv f₁ f₂ → Equiv f₂ f₁ := +fun h x => Eq.symm (h x) + +protected theorem Equiv.trans {f₁ f₂ f₃ : ∀ (x : α), β x} : Equiv f₁ f₂ → Equiv f₂ f₃ → Equiv f₁ f₃ := +fun h₁ h₂ x => Eq.trans (h₁ x) (h₂ x) + +protected theorem Equiv.isEquivalence (α : Sort u) (β : α → Sort v) : Equivalence (@Function.Equiv α β) := +mkEquivalence (@Function.Equiv α β) (@Equiv.refl α β) (@Equiv.symm α β) (@Equiv.trans α β) +end Function + +section +open Quotient +variables {α : Sort u} {β : α → Sort v} + +@[instance] +private def funSetoid (α : Sort u) (β : α → Sort v) : Setoid (∀ (x : α), β x) := +Setoid.mk (@Function.Equiv α β) (Function.Equiv.isEquivalence α β) + +private def extfunApp (f : Quotient $ funSetoid α β) : ∀ (x : α), β x := +fun x => +Quot.liftOn f + (fun (f : ∀ (x : α), β x) => f x) + (fun f₁ f₂ h => h x) + +theorem funext {f₁ f₂ : ∀ (x : α), β x} (h : ∀ x, f₁ x = f₂ x) : f₁ = f₂ := +show extfunApp (Quotient.mk f₁) = extfunApp (Quotient.mk f₂) from +congrArg extfunApp (sound h) +end + +instance Forall.Subsingleton {α : Sort u} {β : α → Sort v} [∀ a, Subsingleton (β a)] : Subsingleton (∀ a, β a) := +⟨fun f₁ f₂ => funext (fun a => Subsingleton.elim (f₁ a) (f₂ a))⟩ + +/- General operations on functions -/ +namespace Function +universes u₁ u₂ u₃ u₄ +variables {α : Sort u₁} {β : Sort u₂} {φ : Sort u₃} {δ : Sort u₄} {ζ : Sort u₁} + +@[inline, reducible] def comp (f : β → φ) (g : α → β) : α → φ := +fun x => f (g x) + +infixr ` ∘ ` := Function.comp + +@[inline, reducible] def onFun (f : β → β → φ) (g : α → β) : α → α → φ := +fun x y => f (g x) (g y) + +@[inline, reducible] def combine (f : α → β → φ) (op : φ → δ → ζ) (g : α → β → δ) + : α → β → ζ := +fun x y => op (f x y) (g x y) + +@[inline, reducible] def const (β : Sort u₂) (a : α) : β → α := +fun x => a + +@[inline, reducible] def swap {φ : α → β → Sort u₃} (f : ∀ x y, φ x y) : ∀ y x, φ x y := +fun y x => f x y + +end Function + +/- Classical reasoning support -/ + +namespace Classical + +axiom choice {α : Sort u} : Nonempty α → α + +noncomputable def indefiniteDescription {α : Sort u} (p : α → Prop) + (h : Exists (fun x => p x)) : {x // p x} := +choice $ let ⟨x, px⟩ := h; ⟨⟨x, px⟩⟩ + +noncomputable def choose {α : Sort u} {p : α → Prop} (h : Exists (fun x => p x)) : α := +(indefiniteDescription p h).val + +theorem chooseSpec {α : Sort u} {p : α → Prop} (h : Exists (fun x => p x)) : p (choose h) := +(indefiniteDescription p h).property + +/- Diaconescu's theorem: excluded middle from choice, Function extensionality and propositional extensionality. -/ +theorem em (p : Prop) : p ∨ ¬p := +let U (x : Prop) : Prop := x = True ∨ p; +let V (x : Prop) : Prop := x = False ∨ p; +have exU : Exists (fun x => U x) from ⟨True, Or.inl rfl⟩; +have exV : Exists (fun x => V x) from ⟨False, Or.inl rfl⟩; +let u : Prop := choose exU; +let v : Prop := choose exV; +have uDef : U u from chooseSpec exU; +have vDef : V v from chooseSpec exV; +have notUvOrP : u ≠ v ∨ p from + Or.elim uDef + (fun hut => + Or.elim vDef + (fun hvf => + have hne : u ≠ v from hvf.symm ▸ hut.symm ▸ trueNeFalse; + Or.inl hne) + Or.inr) + Or.inr; +have pImpliesUv : p → u = v from + fun hp => + have hpred : U = V from + funext $ fun x => + have hl : (x = True ∨ p) → (x = False ∨ p) from + fun a => Or.inr hp; + have hr : (x = False ∨ p) → (x = True ∨ p) from + fun a => Or.inr hp; + show (x = True ∨ p) = (x = False ∨ p) from + propext (Iff.intro hl hr); + have h₀ : ∀ exU exV, @choose _ U exU = @choose _ V exV from + hpred ▸ fun exU exV => rfl; + show u = v from h₀ _ _; +Or.elim notUvOrP + (fun (hne : u ≠ v) => Or.inr (mt pImpliesUv hne)) + Or.inl + +theorem existsTrueOfNonempty {α : Sort u} : Nonempty α → Exists (fun (x : α) => True) +| ⟨x⟩ => ⟨x, trivial⟩ + +noncomputable def inhabitedOfNonempty {α : Sort u} (h : Nonempty α) : Inhabited α := +⟨choice h⟩ + +noncomputable def inhabitedOfExists {α : Sort u} {p : α → Prop} (h : Exists (fun x => p x)) : + Inhabited α := +inhabitedOfNonempty (Exists.elim h (fun w hw => ⟨w⟩)) + +/- all propositions are Decidable -/ +noncomputable def propDecidable (a : Prop) : Decidable a := +choice $ Or.elim (em a) + (fun ha => ⟨isTrue ha⟩) + (fun hna => ⟨isFalse hna⟩) + +noncomputable def decidableInhabited (a : Prop) : Inhabited (Decidable a) := +⟨propDecidable a⟩ + +noncomputable def typeDecidableEq (α : Sort u) : DecidableEq α := +{decEq := fun x y => propDecidable (x = y)} + +noncomputable def typeDecidable (α : Sort u) : PSum α (α → False) := +match (propDecidable (Nonempty α)) with +| (isTrue hp) => PSum.inl (@arbitrary _ (inhabitedOfNonempty hp)) +| (isFalse hn) => PSum.inr (fun a => absurd (Nonempty.intro a) hn) + +noncomputable def strongIndefiniteDescription {α : Sort u} (p : α → Prop) + (h : Nonempty α) : {x : α // Exists (fun (y : α) => p y) → p x} := +@dite (Exists (fun (x : α) => p x)) (propDecidable _) _ + (fun (hp : Exists (fun (x : α) => p x)) => + show {x : α // Exists (fun (y : α) => p y) → p x} from + let xp := indefiniteDescription _ hp; + ⟨xp.val, fun h' => xp.property⟩) + (fun hp => ⟨choice h, fun h => absurd h hp⟩) + +/- the Hilbert epsilon Function -/ + +noncomputable def epsilon {α : Sort u} [h : Nonempty α] (p : α → Prop) : α := +(strongIndefiniteDescription p h).val + +theorem epsilonSpecAux {α : Sort u} (h : Nonempty α) (p : α → Prop) + : Exists (fun y => p y) → p (@epsilon α h p) := +(strongIndefiniteDescription p h).property + +theorem epsilonSpec {α : Sort u} {p : α → Prop} (hex : Exists (fun y => p y)) : + p (@epsilon α (nonemptyOfExists hex) p) := +epsilonSpecAux (nonemptyOfExists hex) p hex + +theorem epsilonSingleton {α : Sort u} (x : α) : @epsilon α ⟨x⟩ (fun y => y = x) = x := +@epsilonSpec α (fun y => y = x) ⟨x, rfl⟩ + +/- the axiom of choice -/ + +theorem axiomOfChoice {α : Sort u} {β : α → Sort v} {r : ∀ x, β x → Prop} (h : ∀ x, Exists (fun y => r x y)) : + Exists (fun (f : ∀ x, β x) => ∀ x, r x (f x)) := +⟨_, fun x => chooseSpec (h x)⟩ + +theorem skolem {α : Sort u} {b : α → Sort v} {p : ∀ x, b x → Prop} : + (∀ x, Exists (fun y => p x y)) ↔ Exists (fun (f : ∀ x, b x) => ∀ x, p x (f x)) := +⟨axiomOfChoice, fun ⟨f, hw⟩ (x) => ⟨f x, hw x⟩⟩ + +theorem propComplete (a : Prop) : a = True ∨ a = False := +Or.elim (em a) + (fun t => Or.inl (eqTrueIntro t)) + (fun f => Or.inr (eqFalseIntro f)) + +-- this supercedes byCases in Decidable +theorem byCases {p q : Prop} (hpq : p → q) (hnpq : ¬p → q) : q := +@Decidable.byCases _ _ (propDecidable _) hpq hnpq + +-- this supercedes byContradiction in Decidable +theorem byContradiction {p : Prop} (h : ¬p → False) : p := +@Decidable.byContradiction _ (propDecidable _) h + +end Classical diff --git a/stage0/src/Init/Data.lean b/stage0/src/Init/Data.lean new file mode 100644 index 0000000000..11dc7139ac --- /dev/null +++ b/stage0/src/Init/Data.lean @@ -0,0 +1,23 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Basic +import Init.Data.Nat +import Init.Data.Char +import Init.Data.String +import Init.Data.List +import Init.Data.Int +import Init.Data.Array +import Init.Data.ByteArray +import Init.Data.Fin +import Init.Data.UInt +import Init.Data.RBTree +import Init.Data.RBMap +import Init.Data.Option +import Init.Data.HashMap +import Init.Data.Random +import Init.Data.Queue +import Init.Data.Stack diff --git a/stage0/src/Init/Data/Array.lean b/stage0/src/Init/Data/Array.lean new file mode 100644 index 0000000000..6e7adb07e5 --- /dev/null +++ b/stage0/src/Init/Data/Array.lean @@ -0,0 +1,9 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Gabriel Ebner +-/ +prelude +import Init.Data.Array.Basic +import Init.Data.Array.QSort +import Init.Data.Array.BinSearch diff --git a/stage0/src/Init/Data/Array/Basic.lean b/stage0/src/Init/Data/Array/Basic.lean new file mode 100644 index 0000000000..2eaee31596 --- /dev/null +++ b/stage0/src/Init/Data/Array/Basic.lean @@ -0,0 +1,561 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Nat.Basic +import Init.Data.Fin.Basic +import Init.Data.UInt +import Init.Data.Repr +import Init.Data.ToString +import Init.Control.Id +import Init.Util +universes u v w + +/- +The Compiler has special support for arrays. +They are implemented using dynamic arrays: https://en.wikipedia.org/wiki/Dynamic_array +-/ +structure Array (α : Type u) := +(sz : Nat) +(data : Fin sz → α) + +attribute [extern "lean_array_mk"] Array.mk +attribute [extern "lean_array_data"] Array.data +attribute [extern "lean_array_sz"] Array.sz + +@[reducible, extern "lean_array_get_size"] +def Array.size {α : Type u} (a : @& Array α) : Nat := +a.sz + +namespace Array +variables {α : Type u} + +/- The parameter `c` is the initial capacity -/ +@[extern "lean_mk_empty_array_with_capacity"] +def mkEmpty (c : @& Nat) : Array α := +{ sz := 0, + data := fun ⟨x, h⟩ => absurd h (Nat.notLtZero x) } + +@[extern "lean_array_push"] +def push (a : Array α) (v : α) : Array α := +{ sz := Nat.succ a.sz, + data := fun ⟨j, h₁⟩ => + if h₂ : j = a.sz then v + else a.data ⟨j, Nat.ltOfLeOfNe (Nat.leOfLtSucc h₁) h₂⟩ } + +@[extern "lean_mk_array"] +def mkArray {α : Type u} (n : Nat) (v : α) : Array α := +{ sz := n, + data := fun _ => v} + +theorem szMkArrayEq {α : Type u} (n : Nat) (v : α) : (mkArray n v).sz = n := +rfl + +def empty : Array α := +mkEmpty 0 + +instance : HasEmptyc (Array α) := +⟨Array.empty⟩ + +instance : Inhabited (Array α) := +⟨Array.empty⟩ + +def isEmpty (a : Array α) : Bool := +a.size = 0 + +def singleton (v : α) : Array α := +mkArray 1 v + +@[extern "lean_array_fget"] +def get (a : @& Array α) (i : @& Fin a.size) : α := +a.data i + +/- Low-level version of `fget` which is as fast as a C array read. + `Fin` values are represented as tag pointers in the Lean runtime. Thus, + `fget` may be slightly slower than `uget`. -/ +@[extern "lean_array_uget"] +def uget (a : @& Array α) (i : USize) (h : i.toNat < a.size) : α := +a.get ⟨i.toNat, h⟩ + +/- "Comfortable" version of `fget`. It performs a bound check at runtime. -/ +@[extern "lean_array_get"] +def get! [Inhabited α] (a : @& Array α) (i : @& Nat) : α := +if h : i < a.size then a.get ⟨i, h⟩ else arbitrary α + +def back [Inhabited α] (a : Array α) : α := +a.get! (a.size - 1) + +def get? (a : Array α) (i : Nat) : Option α := +if h : i < a.size then some (a.get ⟨i, h⟩) else none + +def getD (a : Array α) (i : Nat) (v₀ : α) : α := +if h : i < a.size then a.get ⟨i, h⟩ else v₀ + +@[extern "lean_array_fset"] +def set (a : Array α) (i : @& Fin a.size) (v : α) : Array α := +{ sz := a.sz, + data := fun j => if h : i = j then v else a.data j } + +theorem szFSetEq (a : Array α) (i : Fin a.size) (v : α) : (set a i v).size = a.size := +rfl + +theorem szPushEq (a : Array α) (v : α) : (push a v).size = a.size + 1 := +rfl + +/- Low-level version of `fset` which is as fast as a C array fset. + `Fin` values are represented as tag pointers in the Lean runtime. Thus, + `fset` may be slightly slower than `uset`. -/ +@[extern "lean_array_uset"] +def uset (a : Array α) (i : USize) (v : α) (h : i.toNat < a.size) : Array α := +a.set ⟨i.toNat, h⟩ v + +/- "Comfortable" version of `fset`. It performs a bound check at runtime. -/ +@[extern "lean_array_set"] +def set! (a : Array α) (i : @& Nat) (v : α) : Array α := +if h : i < a.size then a.set ⟨i, h⟩ v else panic! "index out of bounds" + +@[extern "lean_array_fswap"] +def swap (a : Array α) (i j : @& Fin a.size) : Array α := +let v₁ := a.get i; +let v₂ := a.get j; +let a := a.set i v₂; +a.set j v₁ + +@[extern "lean_array_swap"] +def swap! (a : Array α) (i j : @& Nat) : Array α := +if h₁ : i < a.size then +if h₂ : j < a.size then swap a ⟨i, h₁⟩ ⟨j, h₂⟩ +else panic! "index out of bounds" +else panic! "index out of bounds" + +@[inline] def swapAt {α : Type} (a : Array α) (i : Fin a.size) (v : α) : α × Array α := +let e := a.get i; +let a := a.set i v; +(e, a) + +-- TODO: delete as soon as we can define local instances +@[neverExtract] private def swapAtPanic! [Inhabited α] (i : Nat) : α × Array α := +panic! ("index " ++ toString i ++ " out of bounds") + +@[inline] def swapAt! {α : Type} (a : Array α) (i : Nat) (v : α) : α × Array α := +if h : i < a.size then swapAt a ⟨i, h⟩ v else @swapAtPanic! _ ⟨v⟩ i + +@[extern "lean_array_pop"] +def pop (a : Array α) : Array α := +{ sz := Nat.pred a.size, + data := fun ⟨j, h⟩ => a.get ⟨j, Nat.ltOfLtOfLe h (Nat.predLe _)⟩ } + +-- TODO(Leo): justify termination using wf-rec +partial def shrink : Array α → Nat → Array α +| a, n => if n ≥ a.size then a else shrink a.pop n + +section +variables {m : Type v → Type w} [Monad m] +variables {β : Type v} {σ : Type u} + +-- TODO(Leo): justify termination using wf-rec +@[specialize] partial def iterateMAux (a : Array α) (f : ∀ (i : Fin a.size), α → β → m β) : Nat → β → m β +| i, b => + if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + f idx (a.get idx) b >>= iterateMAux (i+1) + else pure b + +@[inline] def iterateM (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → m β) : m β := +iterateMAux a f 0 b + +@[inline] def foldlM (f : β → α → m β) (b : β) (a : Array α) : m β := +iterateM a b (fun _ b a => f a b) + +@[inline] def foldlFromM (f : β → α → m β) (b : β) (a : Array α) (ini : Nat := 0) : m β := +iterateMAux a (fun _ b a => f a b) ini b + +-- TODO(Leo): justify termination using wf-rec +@[specialize] partial def iterateM₂Aux (a₁ : Array α) (a₂ : Array σ) (f : ∀ (i : Fin a₁.size), α → σ → β → m β) : Nat → β → m β +| i, b => + if h₁ : i < a₁.size then + let idx₁ : Fin a₁.size := ⟨i, h₁⟩; + if h₂ : i < a₂.size then + let idx₂ : Fin a₂.size := ⟨i, h₂⟩; + f idx₁ (a₁.get idx₁) (a₂.get idx₂) b >>= iterateM₂Aux (i+1) + else pure b + else pure b + +@[inline] def iterateM₂ (a₁ : Array α) (a₂ : Array σ) (b : β) (f : ∀ (i : Fin a₁.size), α → σ → β → m β) : m β := +iterateM₂Aux a₁ a₂ f 0 b + +@[inline] def foldlM₂ (f : β → α → σ → m β) (b : β) (a₁ : Array α) (a₂ : Array σ): m β := +iterateM₂ a₁ a₂ b (fun _ a₁ a₂ b => f b a₁ a₂) + +-- TODO(Leo): justify termination using wf-rec +@[specialize] partial def findMAux (a : Array α) (f : α → m (Option β)) : Nat → m (Option β) +| i => + if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + do r ← f (a.get idx); + match r with + | some v => pure r + | none => findMAux (i+1) + else pure none + +@[inline] def findM (a : Array α) (f : α → m (Option β)) : m (Option β) := +findMAux a f 0 + +@[specialize] partial def findRevMAux (a : Array α) (f : α → m (Option β)) : ∀ (idx : Nat), idx ≤ a.size → m (Option β) +| i, h => + if hLt : 0 < i then + have i - 1 < i from Nat.subLt hLt (Nat.zeroLtSucc 0); + have i - 1 < a.size from Nat.ltOfLtOfLe this h; + let idx : Fin a.size := ⟨i - 1, this⟩; + do + r ← f (a.get idx); + match r with + | some v => pure r + | none => + have i - 1 ≤ a.size from Nat.leOfLt this; + findRevMAux (i-1) this + else pure none + +@[inline] def findRevM (a : Array α) (f : α → m (Option β)) : m (Option β) := +findRevMAux a f a.size (Nat.leRefl _) + +end + +section +variables {β : Type w} {σ : Type u} + +@[inline] def iterate (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → β) : β := +Id.run $ iterateMAux a f 0 b + +@[inline] def iterateFrom (a : Array α) (b : β) (i : Nat) (f : ∀ (i : Fin a.size), α → β → β) : β := +Id.run $ iterateMAux a f i b + +@[inline] def foldl (f : β → α → β) (b : β) (a : Array α) : β := +iterate a b (fun _ a b => f b a) + +@[inline] def foldlFrom (f : β → α → β) (b : β) (a : Array α) (ini : Nat := 0) : β := +Id.run $ foldlFromM f b a ini + +@[inline] def iterate₂ (a₁ : Array α) (a₂ : Array σ) (b : β) (f : ∀ (i : Fin a₁.size), α → σ → β → β) : β := +Id.run $ iterateM₂Aux a₁ a₂ f 0 b + +@[inline] def foldl₂ (f : β → α → σ → β) (b : β) (a₁ : Array α) (a₂ : Array σ) : β := +iterate₂ a₁ a₂ b (fun _ a₁ a₂ b => f b a₁ a₂) + +@[inline] def find? (a : Array α) (f : α → Option β) : Option β := +Id.run $ findMAux a f 0 + +@[inline] def find! [Inhabited β] (a : Array α) (f : α → Option β) : β := +match find? a f with +| some b => b +| none => panic! "failed to find element" + +@[inline] def findRev? (a : Array α) (f : α → Option β) : Option β := +Id.run $ findRevMAux a f a.size (Nat.leRefl _) + +@[inline] def findRev! [Inhabited β] (a : Array α) (f : α → Option β) : β := +match findRev? a f with +| some b => b +| none => panic! "failed to find element" + +@[specialize] partial def findIdxAux (a : Array α) (p : α → Bool) : Nat → Option Nat +| i => + if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + if p (a.get idx) then some i + else findIdxAux (i+1) + else none + +@[inline] def findIdx? (a : Array α) (p : α → Bool) : Option Nat := +findIdxAux a p 0 + +@[inline] def findIdx! (a : Array α) (p : α → Bool) : Nat := +match findIdxAux a p 0 with +| some i => i +| none => panic! "failed to find element" + +end + +section +variables {m : Type → Type w} [Monad m] + +@[specialize] partial def anyRangeMAux (a : Array α) (endIdx : Nat) (hlt : endIdx ≤ a.size) (p : α → m Bool) : Nat → m Bool +| i => + if h : i < endIdx then + let idx : Fin a.size := ⟨i, Nat.ltOfLtOfLe h hlt⟩; + do b ← p (a.get idx); + match b with + | true => pure true + | false => anyRangeMAux (i+1) + else pure false + +@[inline] def anyM (a : Array α) (p : α → m Bool) : m Bool := +anyRangeMAux a a.size (Nat.leRefl _) p 0 + +@[inline] def allM (a : Array α) (p : α → m Bool) : m Bool := +do b ← anyM a (fun v => do b ← p v; pure (!b)); pure (!b) + +@[inline] def anyRangeM (a : Array α) (beginIdx endIdx : Nat) (p : α → m Bool) : m Bool := +if h : endIdx ≤ a.size then + anyRangeMAux a endIdx h p beginIdx +else + anyRangeMAux a a.size (Nat.leRefl _) p beginIdx + +@[inline] def allRangeM (a : Array α) (beginIdx endIdx : Nat) (p : α → m Bool) : m Bool := +do b ← anyRangeM a beginIdx endIdx (fun v => do b ← p v; pure b); pure (!b) + +end + +@[inline] def any (a : Array α) (p : α → Bool) : Bool := +Id.run $ anyM a p + +@[inline] def anyRange (a : Array α) (beginIdx endIdx : Nat) (p : α → Bool) : Bool := +Id.run $ anyRangeM a beginIdx endIdx p + +@[inline] def anyFrom (a : Array α) (beginIdx : Nat) (p : α → Bool) : Bool := +Id.run $ anyRangeM a beginIdx a.size p + +@[inline] def all (a : Array α) (p : α → Bool) : Bool := +!any a (fun v => !p v) + +@[inline] def allRange (a : Array α) (beginIdx endIdx : Nat) (p : α → Bool) : Bool := +!anyRange a beginIdx endIdx (fun v => !p v) + +section +variables {m : Type v → Type w} [Monad m] +variable {β : Type v} + +@[specialize] private def iterateRevMAux (a : Array α) (f : ∀ (i : Fin a.size), α → β → m β) : ∀ (i : Nat), i ≤ a.size → β → m β +| 0, h, b => pure b +| j+1, h, b => do + let i : Fin a.size := ⟨j, h⟩; + b ← f i (a.get i) b; + iterateRevMAux j (Nat.leOfLt h) b + +@[inline] def iterateRevM (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → m β) : m β := +iterateRevMAux a f a.size (Nat.leRefl _) b + +@[inline] def foldrM (f : α → β → m β) (b : β) (a : Array α) : m β := +iterateRevM a b (fun _ => f) + +end + +@[inline] def iterateRev {β} (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → β) : β := +Id.run $ iterateRevM a b f + +@[inline] def foldr {β} (f : α → β → β) (b : β) (a : Array α) : β := +Id.run $ foldrM f b a + +def toList (a : Array α) : List α := +a.foldr List.cons [] + +instance [HasRepr α] : HasRepr (Array α) := +⟨fun a => "#" ++ repr a.toList⟩ + +instance [HasToString α] : HasToString (Array α) := +⟨fun a => "#" ++ toString a.toList⟩ + +section +variables {m : Type u → Type w} [Monad m] +variable {β : Type u} + +@[specialize] unsafe partial def umapMAux (f : Nat → α → m β) : Nat → Array α → m (Array β) +| i, a => + if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + let v : α := a.get idx; + let a := a.set idx (@unsafeCast _ _ ⟨v⟩ ()); + do newV ← f i v; umapMAux (i+1) (a.set idx (@unsafeCast _ _ ⟨v⟩ newV)) + else + pure (unsafeCast a) + +@[inline] unsafe partial def umapM (f : α → m β) (as : Array α) : m (Array β) := +umapMAux (fun i a => f a) 0 as + +@[inline] unsafe partial def umapIdxM (f : Nat → α → m β) (as : Array α) : m (Array β) := +umapMAux f 0 as + +@[implementedBy Array.umapM] def mapM (f : α → m β) (as : Array α) : m (Array β) := +as.foldlM (fun bs a => do b ← f a; pure (bs.push b)) (mkEmpty as.size) + +@[implementedBy Array.umapIdxM] def mapIdxM (f : Nat → α → m β) (as : Array α) : m (Array β) := +as.iterateM (mkEmpty as.size) (fun i a bs => do b ← f i.val a; pure (bs.push b)) +end + +section +variable {β : Type u} + +@[inline] def modify [Inhabited α] (a : Array α) (i : Nat) (f : α → α) : Array α := +if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + let v := a.get idx; + let a := a.set idx (arbitrary α); + let v := f v; + a.set idx v +else + a + +@[inline] def mapIdx (f : Nat → α → β) (a : Array α) : Array β := +Id.run $ mapIdxM f a + +@[inline] def map (f : α → β) (as : Array α) : Array β := +Id.run $ mapM f as +end + +section +variables {m : Type u → Type v} [Monad m] +variable {β : Type u} + +@[specialize] +partial def forMAux {α : Type w} {β : Type u} (f : α → m β) (a : Array α) : Nat → m PUnit +| i => + if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + let v : α := a.get idx; + f v *> forMAux (i+1) + else + pure ⟨⟩ + +def forM {α : Type w} {β : Type u} (f : α → m β) (a : Array α) : m PUnit := +a.forMAux f 0 + +end + +-- TODO(Leo): justify termination using wf-rec +partial def extractAux (a : Array α) : Nat → ∀ (e : Nat), e ≤ a.size → Array α → Array α +| i, e, hle, r => + if hlt : i < e then + let idx : Fin a.size := ⟨i, Nat.ltOfLtOfLe hlt hle⟩; + extractAux (i+1) e hle (r.push (a.get idx)) + else r + +def extract (a : Array α) (b e : Nat) : Array α := +let r : Array α := mkEmpty (e - b); +if h : e ≤ a.size then extractAux a b e h r +else r + +protected def append (a : Array α) (b : Array α) : Array α := +b.foldl (fun a v => a.push v) a + +instance : HasAppend (Array α) := ⟨Array.append⟩ + +-- TODO(Leo): justify termination using wf-rec +partial def isEqvAux (a b : Array α) (hsz : a.size = b.size) (p : α → α → Bool) : Nat → Bool +| i => + if h : i < a.size then + let aidx : Fin a.size := ⟨i, h⟩; + let bidx : Fin b.size := ⟨i, hsz ▸ h⟩; + match p (a.get aidx) (b.get bidx) with + | true => isEqvAux (i+1) + | false => false + else + true + +@[specialize] def isEqv (a b : Array α) (p : α → α → Bool) : Bool := +if h : a.size = b.size then + isEqvAux a b h p 0 +else + false + +instance [HasBeq α] : HasBeq (Array α) := +⟨fun a b => isEqv a b HasBeq.beq⟩ + +-- TODO(Leo): justify termination using wf-rec, and use `swap` +partial def reverseAux : Array α → Nat → Array α +| a, i => + let n := a.size; + if i < n / 2 then + reverseAux (a.swap! i (n - i - 1)) (i+1) + else + a + +def reverse (a : Array α) : Array α := +reverseAux a 0 + +-- TODO(Leo): justify termination using wf-rec +@[specialize] partial def filterAux (p : α → Bool) : Array α → Nat → Nat → Array α +| a, i, j => + if h₁ : i < a.size then + if p (a.get ⟨i, h₁⟩) then + if h₂ : j < i then + filterAux (a.swap ⟨i, h₁⟩ ⟨j, Nat.ltTrans h₂ h₁⟩) (i+1) (j+1) + else + filterAux a (i+1) (j+1) + else + filterAux a (i+1) j + else + a.shrink j + +@[inline] def filter (p : α → Bool) (as : Array α) : Array α := +filterAux p as 0 0 + +partial def indexOfAux {α} [HasBeq α] (a : Array α) (v : α) : Nat → Option (Fin a.size) +| i => + if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + if a.get idx == v then some idx + else indexOfAux (i+1) + else none + +def indexOf {α} [HasBeq α] (a : Array α) (v : α) : Option (Fin a.size) := +indexOfAux a v 0 + +partial def eraseIdxAux {α} : Nat → Array α → Array α +| i, a => + if h : i < a.size then + let idx : Fin a.size := ⟨i, h⟩; + let idx1 : Fin a.size := ⟨i - 1, Nat.ltOfLeOfLt (Nat.predLe i) h⟩; + eraseIdxAux (i+1) (a.swap idx idx1) + else + a.pop + +def feraseIdx {α} (a : Array α) (i : Fin a.size) : Array α := +eraseIdxAux (i.val + 1) a + +def eraseIdx {α} (a : Array α) (i : Nat) : Array α := +if i < a.size then eraseIdxAux (i+1) a else a + +theorem szFSwapEq (a : Array α) (i j : Fin a.size) : (a.swap i j).size = a.size := +rfl + +theorem szPopEq (a : Array α) : a.pop.size = a.size - 1 := +rfl + +section +/- Instance for justifying `partial` declaration. + We should be able to delete it as soon as we restore support for well-founded recursion. -/ +instance eraseIdxSzAuxInstance (a : Array α) : Inhabited { r : Array α // r.size = a.size - 1 } := +⟨⟨a.pop, szPopEq a⟩⟩ + +partial def eraseIdxSzAux {α} (a : Array α) : ∀ (i : Nat) (r : Array α), r.size = a.size → { r : Array α // r.size = a.size - 1 } +| i, r, heq => + if h : i < r.size then + let idx : Fin r.size := ⟨i, h⟩; + let idx1 : Fin r.size := ⟨i - 1, Nat.ltOfLeOfLt (Nat.predLe i) h⟩; + eraseIdxSzAux (i+1) (r.swap idx idx1) ((szFSwapEq r idx idx1).trans heq) + else + ⟨r.pop, (szPopEq r).trans (heq ▸ rfl)⟩ +end + +def eraseIdx' {α} (a : Array α) (i : Fin a.size) : { r : Array α // r.size = a.size - 1 } := +eraseIdxSzAux a (i.val + 1) a rfl + +def contains [HasBeq α] (as : Array α) (a : α) : Bool := +as.any $ fun b => a == b + +end Array + +export Array (mkArray) + +@[inlineIfReduce] def List.toArrayAux {α : Type u} : List α → Array α → Array α +| [], r => r +| a::as, r => List.toArrayAux as (r.push a) + +@[inlineIfReduce] def List.redLength {α : Type u} : List α → Nat +| [] => 0 +| _::as => as.redLength + 1 + +@[inline] def List.toArray {α : Type u} (as : List α) : Array α := +as.toArrayAux (Array.mkEmpty as.redLength) diff --git a/stage0/src/Init/Data/Array/BinSearch.lean b/stage0/src/Init/Data/Array/BinSearch.lean new file mode 100644 index 0000000000..495254cee3 --- /dev/null +++ b/stage0/src/Init/Data/Array/BinSearch.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Array.Basic +universes u v + +namespace Array +-- TODO: remove the [Inhabited α] parameters as soon as we have the tactic framework for automating proof generation and using Array.fget +-- TODO: remove `partial` using well-founded recursion + +@[specialize] partial def binSearchAux {α : Type u} {β : Type v} [Inhabited α] [Inhabited β] (lt : α → α → Bool) (found : Option α → β) (as : Array α) (k : α) : Nat → Nat → β +| lo, hi => + if lo <= hi then + let m := (lo + hi)/2; + let a := as.get! m; + if lt a k then binSearchAux (m+1) hi + else if lt k a then + if m == 0 then found none + else binSearchAux lo (m-1) + else found (some a) + else found none + +@[inline] def binSearch {α : Type} [Inhabited α] (as : Array α) (k : α) (lt : α → α → Bool) (lo := 0) (hi := as.size - 1) : Option α := +binSearchAux lt id as k lo hi + +@[inline] def binSearchContains {α : Type} [Inhabited α] (as : Array α) (k : α) (lt : α → α → Bool) (lo := 0) (hi := as.size - 1) : Bool := +binSearchAux lt Option.isSome as k lo hi + +end Array diff --git a/stage0/src/Init/Data/Array/QSort.lean b/stage0/src/Init/Data/Array/QSort.lean new file mode 100644 index 0000000000..dff4618dee --- /dev/null +++ b/stage0/src/Init/Data/Array/QSort.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Array.Basic + +namespace Array +-- TODO: remove the [Inhabited α] parameters as soon as we have the tactic framework for automating proof generation and using Array.fget +-- TODO: remove `partial` using well-founded recursion + +@[specialize] private partial def partitionAux {α : Type} [Inhabited α] (lt : α → α → Bool) (hi : Nat) (pivot : α) : Array α → Nat → Nat → Nat × Array α +| as, i, j => + if j < hi then + if lt (as.get! j) pivot then + let as := as.swap! i j; + partitionAux as (i+1) (j+1) + else + partitionAux as i (j+1) + else + let as := as.swap! i hi; + (i, as) + +@[inline] def partition {α : Type} [Inhabited α] (as : Array α) (lt : α → α → Bool) (lo hi : Nat) : Nat × Array α := +let mid := (lo + hi) / 2; +let as := if lt (as.get! mid) (as.get! lo) then as.swap! lo mid else as; +let as := if lt (as.get! hi) (as.get! lo) then as.swap! lo hi else as; +let as := if lt (as.get! mid) (as.get! hi) then as.swap! mid hi else as; +let pivot := as.get! hi; +partitionAux lt hi pivot as lo lo + +@[specialize] partial def qsortAux {α : Type} [Inhabited α] (lt : α → α → Bool) : Array α → Nat → Nat → Array α +| as, low, high => + if low < high then + let p := partition as lt low high; + -- TODO: fix `partial` support in the equation compiler, it breaks if we use `let (mid, as) := partition as lt low high` + let mid := p.1; + let as := p.2; + if mid >= high then as + else + let as := qsortAux as low mid; + qsortAux as (mid+1) high + else as + +@[inline] def qsort {α : Type} [Inhabited α] (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α := +qsortAux lt as low high + +end Array diff --git a/stage0/src/Init/Data/AssocList.lean b/stage0/src/Init/Data/AssocList.lean new file mode 100644 index 0000000000..220c1f4246 --- /dev/null +++ b/stage0/src/Init/Data/AssocList.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Control.Id +universes u v w + +/- List-like type to avoid extra level of indirection -/ +inductive AssocList (α : Type u) (β : Type v) +| nil {} : AssocList +| cons (key : α) (value : β) (tail : AssocList) : AssocList + +namespace AssocList +variables {α : Type u} {β : Type v} {δ : Type w} {m : Type w → Type w} [Monad m] + +def empty : AssocList α β := +nil + +@[specialize] def foldlM (f : δ → α → β → m δ) : δ → AssocList α β → m δ +| d, nil => pure d +| d, cons a b es => do d ← f d a b; foldlM d es + +@[inline] def foldl (f : δ → α → β → δ) (d : δ) (as : AssocList α β) : δ := +Id.run (foldlM f d as) + +def find [HasBeq α] (a : α) : AssocList α β → Option β +| nil => none +| cons k v es => match k == a with + | true => some v + | false => find es + +def contains [HasBeq α] (a : α) : AssocList α β → Bool +| nil => false +| cons k v es => k == a || contains es + +def replace [HasBeq α] (a : α) (b : β) : AssocList α β → AssocList α β +| nil => nil +| cons k v es => match k == a with + | true => cons a b es + | false => cons k v (replace es) + +def erase [HasBeq α] (a : α) : AssocList α β → AssocList α β +| nil => nil +| cons k v es => match k == a with + | true => es + | false => cons k v (erase es) + +end AssocList diff --git a/stage0/src/Init/Data/Basic.lean b/stage0/src/Init/Data/Basic.lean new file mode 100644 index 0000000000..8382655db9 --- /dev/null +++ b/stage0/src/Init/Data/Basic.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Nat.Basic +import Init.Data.Fin.Basic +import Init.Data.List.Basic +import Init.Data.Char.Basic +import Init.Data.String.Basic +import Init.Data.Option.Basic +import Init.Data.UInt +import Init.Data.Repr +import Init.Data.ToString diff --git a/stage0/src/Init/Data/BinomialHeap.lean b/stage0/src/Init/Data/BinomialHeap.lean new file mode 100644 index 0000000000..48d33def3b --- /dev/null +++ b/stage0/src/Init/Data/BinomialHeap.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.BinomialHeap.Basic diff --git a/stage0/src/Init/Data/BinomialHeap/Basic.lean b/stage0/src/Init/Data/BinomialHeap/Basic.lean new file mode 100644 index 0000000000..dd8b2305d8 --- /dev/null +++ b/stage0/src/Init/Data/BinomialHeap/Basic.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.List +import Init.Coe +universes u + +namespace BinomialHeapImp + +structure HeapNodeAux (α : Type u) (h : Type u) := +(val : α) (rank : Nat) (children : List h) + +inductive Heap (α : Type u) : Type u +| empty {} : Heap +| heap (ns : List (HeapNodeAux α Heap)) : Heap + +abbrev HeapNode (α) := HeapNodeAux α (Heap α) + +variables {α : Type u} + +instance : Inhabited (Heap α) := ⟨Heap.empty⟩ + +def hRank : List (HeapNode α) → Nat +| [] => 0 +| h::_ => h.rank + +def isEmpty : Heap α → Bool +| Heap.empty => true +| _ => false + +def singleton (a : α) : Heap α := +Heap.heap [{ val := a, rank := 1, children := [] }] + +@[specialize] def combine (lt : α → α → Bool) (n₁ n₂ : HeapNode α) : HeapNode α := +if lt n₂.val n₁.val then + { rank := n₂.rank + 1, children := n₂.children ++ [Heap.heap [n₁]], .. n₂ } +else + { rank := n₁.rank + 1, children := n₁.children ++ [Heap.heap [n₂]], .. n₁ } + +@[specialize] partial def mergeNodes (lt : α → α → Bool) : List (HeapNode α) → List (HeapNode α) → List (HeapNode α) +| [], h => h +| h, [] => h +| f@(h₁ :: t₁), s@(h₂ :: t₂) => + if h₁.rank < h₂.rank then h₁ :: mergeNodes t₁ s + else if h₂.rank < h₁.rank then h₂ :: mergeNodes t₂ f + else + let merged := combine lt h₁ h₂; + let r := merged.rank; + if r != hRank t₁ then + if r != hRank t₂ then merged :: mergeNodes t₁ t₂ else mergeNodes (merged :: t₁) t₂ + else + if r != hRank t₂ then mergeNodes t₁ (merged :: t₂) else merged :: mergeNodes t₁ t₂ + +@[specialize] def merge (lt : α → α → Bool) : Heap α → Heap α → Heap α +| Heap.empty, h => h +| h, Heap.empty => h +| Heap.heap h₁, Heap.heap h₂ => Heap.heap (mergeNodes lt h₁ h₂) + +@[specialize] def head? (lt : α → α → Bool) : Heap α → Option α +| Heap.empty => none +| Heap.heap h => h.foldl + (fun r n => match r with + | none => n.val + | some v => if lt v n.val then v else n.val) none + +/- O(log n) -/ +@[specialize] def head [Inhabited α] (lt : α → α → Bool) : Heap α → α +| Heap.empty => arbitrary α +| Heap.heap [] => arbitrary α +| Heap.heap (h::hs) => hs.foldl (fun r n => if lt r n.val then r else n.val) h.val + +@[specialize] def findMin (lt : α → α → Bool) : List (HeapNode α) → Nat → HeapNode α × Nat → HeapNode α × Nat +| [], _, r => r +| h::hs, idx, (h', idx') => if lt h.val h'.val then findMin hs (idx+1) (h, idx) else findMin hs (idx+1) (h', idx') + +def tail (lt : α → α → Bool) : Heap α → Heap α +| Heap.empty => Heap.empty +| Heap.heap [] => Heap.empty +| Heap.heap [h] => + match h.children with + | [] => Heap.empty + | (h::hs) => hs.foldl (merge lt) h +| Heap.heap hhs@(h::hs) => + let (min, minIdx) := findMin lt hs 1 (h, 0); + let rest := hhs.eraseIdx minIdx; + min.children.foldl (merge lt) (Heap.heap rest) + +partial def toList (lt : α → α → Bool) : Heap α → List α +| Heap.empty => [] +| h => match head? lt h with + | none => [] + | some a => a :: toList (tail lt h) + +inductive WellFormed (lt : α → α → Bool) : Heap α → Prop +| emptyWff : WellFormed Heap.empty +| singletonWff (a : α) : WellFormed (singleton a) +| mergeWff (h₁ h₂ : Heap α) : WellFormed h₁ → WellFormed h₂ → WellFormed (merge lt h₁ h₂) +| tailWff (h : Heap α) : WellFormed h → WellFormed (tail lt h) + +end BinomialHeapImp + +open BinomialHeapImp + +def BinomialHeap (α : Type u) (lt : α → α → Bool) := { h : Heap α // WellFormed lt h } + +@[inline] def mkBinomialHeap (α : Type u) (lt : α → α → Bool) : BinomialHeap α lt := +⟨Heap.empty, WellFormed.emptyWff lt⟩ + +namespace BinomialHeap +variables {α : Type u} {lt : α → α → Bool} + +@[inline] def empty : BinomialHeap α lt := +mkBinomialHeap α lt + +@[inline] def isEmpty : BinomialHeap α lt → Bool +| ⟨b, _⟩ => BinomialHeapImp.isEmpty b + +/- O(1) -/ +@[inline] def singleton (a : α) : BinomialHeap α lt := +⟨BinomialHeapImp.singleton a, WellFormed.singletonWff lt a⟩ + +/- O(log n) -/ +@[inline] def merge : BinomialHeap α lt → BinomialHeap α lt → BinomialHeap α lt +| ⟨b₁, h₁⟩, ⟨b₂, h₂⟩ => ⟨BinomialHeapImp.merge lt b₁ b₂, WellFormed.mergeWff b₁ b₂ h₁ h₂⟩ + +/- O(log n) -/ +@[inline] def head [Inhabited α] : BinomialHeap α lt → α +| ⟨b, _⟩ => BinomialHeapImp.head lt b + +/- O(log n) -/ +@[inline] def head? : BinomialHeap α lt → Option α +| ⟨b, _⟩ => BinomialHeapImp.head? lt b + +/- O(log n) -/ +@[inline] def tail : BinomialHeap α lt → BinomialHeap α lt +| ⟨b, h⟩ => ⟨BinomialHeapImp.tail lt b, WellFormed.tailWff b h⟩ + +/- O(log n) -/ +@[inline] def insert (a : α) (h : BinomialHeap α lt) : BinomialHeap α lt := +merge (singleton a) h + +/- O(n log n) -/ +@[inline] def toList : BinomialHeap α lt → List α +| ⟨b, _⟩ => BinomialHeapImp.toList lt b + +end BinomialHeap diff --git a/stage0/src/Init/Data/ByteArray.lean b/stage0/src/Init/Data/ByteArray.lean new file mode 100644 index 0000000000..b6ee6ccf4b --- /dev/null +++ b/stage0/src/Init/Data/ByteArray.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.ByteArray.Basic diff --git a/stage0/src/Init/Data/ByteArray/Basic.lean b/stage0/src/Init/Data/ByteArray/Basic.lean new file mode 100644 index 0000000000..b99f4f3a28 --- /dev/null +++ b/stage0/src/Init/Data/ByteArray/Basic.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.Array.Basic +import Init.Data.UInt +import Init.Data.Option.Basic +universes u + +structure ByteArray := +(data : Array UInt8) + +attribute [extern "lean_byte_array_mk"] ByteArray.mk +attribute [extern "lean_byte_array_data"] ByteArray.data + +namespace ByteArray +@[extern "lean_mk_empty_byte_array"] +def mkEmpty (c : @& Nat) : ByteArray := +{ data := #[] } + +def empty : ByteArray := +mkEmpty 0 + +instance : Inhabited ByteArray := +⟨empty⟩ + +@[extern "lean_byte_array_push"] +def push : ByteArray → UInt8 → ByteArray +| ⟨bs⟩, b => ⟨bs.push b⟩ + +@[extern "lean_byte_array_size"] +def size : (@& ByteArray) → Nat +| ⟨bs⟩ => bs.size + +@[extern "lean_byte_array_get"] +def get! : (@& ByteArray) → (@& Nat) → UInt8 +| ⟨bs⟩, i => bs.get! i + +@[extern "lean_byte_array_set"] +def set! : ByteArray → (@& Nat) → UInt8 → ByteArray +| ⟨bs⟩, i, b => ⟨bs.set! i b⟩ + +def isEmpty (s : ByteArray) : Bool := +s.size == 0 + +partial def toListAux (bs : ByteArray) : Nat → List UInt8 → List UInt8 +| i, r => + if i < bs.size then + toListAux (i+1) (bs.get! i :: r) + else + r.reverse + +def toList (bs : ByteArray) : List UInt8 := +toListAux bs 0 [] + +end ByteArray + +def List.toByteArrayAux : List UInt8 → ByteArray → ByteArray +| [], r => r +| b::bs, r => List.toByteArrayAux bs (r.push b) + +def List.toByteArray (bs : List UInt8) : ByteArray := +bs.toByteArrayAux ByteArray.empty + +instance : HasToString ByteArray := +⟨fun bs => bs.toList.toString⟩ diff --git a/stage0/src/Init/Data/Char.lean b/stage0/src/Init/Data/Char.lean new file mode 100644 index 0000000000..dc2257bbfe --- /dev/null +++ b/stage0/src/Init/Data/Char.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Char.Basic diff --git a/stage0/src/Init/Data/Char/Basic.lean b/stage0/src/Init/Data/Char/Basic.lean new file mode 100644 index 0000000000..edddab916b --- /dev/null +++ b/stage0/src/Init/Data/Char/Basic.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.UInt +@[inline, reducible] def isValidChar (n : UInt32) : Prop := +n < 0xd800 ∨ (0xdfff < n ∧ n < 0x110000) + +/-- The `Char` Type represents an unicode scalar value. + See http://www.unicode.org/glossary/#unicode_scalar_value). -/ +structure Char := +(val : UInt32) (valid : isValidChar val) + +instance : HasSizeof Char := +⟨fun c => c.val.toNat⟩ + +namespace Char +def utf8Size (c : Char) : UInt32 := +let v := c.val; + if UInt32.land v 0x80 = 0 then 1 +else if UInt32.land v 0xE0 = 0xC0 then 2 +else if UInt32.land v 0xF0 = 0xE0 then 3 +else if UInt32.land v 0xF8 = 0xF0 then 4 +else if UInt32.land v 0xFC = 0xF8 then 5 +else if UInt32.land v 0xFE = 0xFC then 6 +else if v = 0xFF then 1 +else 0 + +protected def Less (a b : Char) : Prop := a.val < b.val +protected def LessEq (a b : Char) : Prop := a.val ≤ b.val + +instance : HasLess Char := ⟨Char.Less⟩ +instance : HasLessEq Char := ⟨Char.LessEq⟩ + +protected def lt (a b : Char) : Bool := a.val < b.val + +instance decLt (a b : Char) : Decidable (a < b) := +UInt32.decLt _ _ + +instance decLe (a b : Char) : Decidable (a ≤ b) := +UInt32.decLe _ _ + +axiom isValidChar0 : isValidChar 0 + +@[noinline, matchPattern] def ofNat (n : Nat) : Char := +if h : isValidChar n.toUInt32 then {val := n.toUInt32, valid := h} else {val := 0, valid := isValidChar0} + +@[inline] def toNat (c : Char) : Nat := +c.val.toNat + +theorem eqOfVeq : ∀ {c d : Char}, c.val = d.val → c = d +| ⟨v, h⟩, ⟨_, _⟩, rfl => rfl + +theorem veqOfEq : ∀ {c d : Char}, c = d → c.val = d.val +| _, _, rfl => rfl + +theorem neOfVne {c d : Char} (h : c.val ≠ d.val) : c ≠ d := +fun h' => absurd (veqOfEq h') h + +theorem vneOfNe {c d : Char} (h : c ≠ d) : c.val ≠ d.val := +fun h' => absurd (eqOfVeq h') h + +instance : DecidableEq Char := +{decEq := fun i j => decidableOfDecidableOfIff + (decEq i.val j.val) ⟨Char.eqOfVeq, Char.veqOfEq⟩} + +instance : Inhabited Char := +⟨'A'⟩ + +def isWhitespace (c : Char) : Bool := +c = ' ' || c = '\t' || c = '\n' + +def isUpper (c : Char) : Bool := +c.val ≥ 65 && c.val ≤ 90 + +def isLower (c : Char) : Bool := +c.val ≥ 97 && c.val ≤ 122 + +def isAlpha (c : Char) : Bool := +c.isUpper || c.isLower + +def isDigit (c : Char) : Bool := +c.val ≥ 48 && c.val ≤ 57 + +def isAlphanum (c : Char) : Bool := +c.isAlpha || c.isDigit + +def toLower (c : Char) : Char := +let n := toNat c; +if n >= 65 ∧ n <= 90 then ofNat (n + 32) else c + +end Char diff --git a/stage0/src/Init/Data/DList.lean b/stage0/src/Init/Data/DList.lean new file mode 100644 index 0000000000..227fc057c6 --- /dev/null +++ b/stage0/src/Init/Data/DList.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.List.Basic +universes u +/-- +A difference List is a Function that, given a List, returns the original +contents of the difference List prepended to the given List. +This structure supports `O(1)` `append` and `concat` operations on lists, making it +useful for append-heavy uses such as logging and pretty printing. +-/ +structure DList (α : Type u) := +(apply : List α → List α) +(invariant : ∀ l, apply l = apply [] ++ l) + +namespace DList +variables {α : Type u} +open List + +def ofList (l : List α) : DList α := +⟨append l, fun t => (appendNil l).symm ▸ rfl⟩ + +def empty : DList α := +⟨id, fun t => rfl⟩ + +instance : HasEmptyc (DList α) := +⟨DList.empty⟩ + +def toList : DList α → List α +| ⟨f, h⟩ => f [] + +def singleton (a : α) : DList α := +⟨fun t => a :: t, + fun t => rfl⟩ + +def cons : α → DList α → DList α +| a, ⟨f, h⟩ => + ⟨fun t => a :: f t, + fun t => + show a :: f t = a :: f [] ++ t from + have h₁ : a :: f t = a :: (f nil ++ t) := h t ▸ rfl; + have h₂ : a :: (f nil ++ t) = a :: f nil ++ t := (consAppend _ _ _).symm; + Eq.trans h₁ h₂⟩ + +def append : DList α → DList α → DList α +| ⟨f, h₁⟩, ⟨g, h₂⟩ => + ⟨f ∘ g, fun t => + show f (g t) = (f (g [])) ++ t from + (h₁ (g [])).symm ▸ (appendAssoc (f []) (g []) t).symm ▸ h₂ t ▸ h₁ (g t) ▸ rfl⟩ + +def push : DList α → α → DList α +| ⟨f, h⟩, a => + ⟨fun t => f (a :: t), + fun t => (h (a::t)).symm ▸ (h [a]).symm ▸ (appendAssoc (f []) [a] t).symm ▸ rfl⟩ + +instance : HasAppend (DList α) := +⟨DList.append⟩ + +end DList diff --git a/stage0/src/Init/Data/Fin.lean b/stage0/src/Init/Data/Fin.lean new file mode 100644 index 0000000000..4e571c0f4b --- /dev/null +++ b/stage0/src/Init/Data/Fin.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.Fin.Basic diff --git a/stage0/src/Init/Data/Fin/Basic.lean b/stage0/src/Init/Data/Fin/Basic.lean new file mode 100644 index 0000000000..e115b16e32 --- /dev/null +++ b/stage0/src/Init/Data/Fin/Basic.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.Nat.Div +import Init.Data.Nat.Bitwise + +open Nat +structure Fin (n : Nat) := (val : Nat) (isLt : val < n) + +namespace Fin + +protected def lt {n} (a b : Fin n) : Prop := +a.val < b.val + +protected def le {n} (a b : Fin n) : Prop := +a.val ≤ b.val + +instance {n} : HasLess (Fin n) := ⟨Fin.lt⟩ +instance {n} : HasLessEq (Fin n) := ⟨Fin.le⟩ + +instance decLt {n} (a b : Fin n) : Decidable (a < b) := +Nat.decLt _ _ + +instance decLe {n} (a b : Fin n) : Decidable (a ≤ b) := +Nat.decLe _ _ + +def elim0.{u} {α : Sort u} : Fin 0 → α +| ⟨_, h⟩ => absurd h (notLtZero _) + +variable {n : Nat} + +def ofNat {n : Nat} (a : Nat) : Fin (succ n) := +⟨a % succ n, Nat.modLt _ (Nat.zeroLtSucc _)⟩ + +def ofNat' {n : Nat} (a : Nat) (h : n > 0) : Fin n := +⟨a % n, Nat.modLt _ h⟩ + +private theorem mlt {n b : Nat} : ∀ {a}, n > a → b % n < n +| 0, h => Nat.modLt _ h +| a+1, h => + have n > 0 from Nat.ltTrans (Nat.zeroLtSucc _) h; + Nat.modLt _ this + +protected def add : Fin n → Fin n → Fin n +| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a + b) % n, mlt h⟩ + +protected def mul : Fin n → Fin n → Fin n +| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a * b) % n, mlt h⟩ + +protected def sub : Fin n → Fin n → Fin n +| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a + (n - b)) % n, mlt h⟩ + +/- +Remark: mod/div/modn/land/lor can be defined without using (% n), but +we are trying to minimize the number of Nat theorems +needed to boostrap Lean. +-/ + +protected def mod : Fin n → Fin n → Fin n +| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a % b) % n, mlt h⟩ + +protected def div : Fin n → Fin n → Fin n +| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a / b) % n, mlt h⟩ + +protected def modn : Fin n → Nat → Fin n +| ⟨a, h⟩, m => ⟨(a % m) % n, mlt h⟩ + +def land : Fin n → Fin n → Fin n +| ⟨a, h⟩, ⟨b, _⟩ => ⟨(Nat.land a b) % n, mlt h⟩ + +def lor : Fin n → Fin n → Fin n +| ⟨a, h⟩, ⟨b, _⟩ => ⟨(Nat.lor a b) % n, mlt h⟩ + +instance : HasZero (Fin (succ n)) := ⟨⟨0, succPos n⟩⟩ +instance : HasOne (Fin (succ n)) := ⟨ofNat 1⟩ +instance : HasAdd (Fin n) := ⟨Fin.add⟩ +instance : HasSub (Fin n) := ⟨Fin.sub⟩ +instance : HasMul (Fin n) := ⟨Fin.mul⟩ +instance : HasMod (Fin n) := ⟨Fin.mod⟩ +instance : HasDiv (Fin n) := ⟨Fin.div⟩ +instance : HasModn (Fin n) := ⟨Fin.modn⟩ + +theorem eqOfVeq : ∀ {i j : Fin n}, (val i) = (val j) → i = j +| ⟨iv, ilt₁⟩, ⟨.(iv), ilt₂⟩, rfl => rfl + +theorem veqOfEq : ∀ {i j : Fin n}, i = j → (val i) = (val j) +| ⟨iv, ilt⟩, .(_), rfl => rfl + +theorem neOfVne {i j : Fin n} (h : val i ≠ val j) : i ≠ j := +fun h' => absurd (veqOfEq h') h + +theorem vneOfNe {i j : Fin n} (h : i ≠ j) : val i ≠ val j := +fun h' => absurd (eqOfVeq h') h + +theorem modnLt : ∀ {m : Nat} (i : Fin n), m > 0 → (i %ₙ m).val < m +| m, ⟨a, h⟩, hp => Nat.ltOfLeOfLt (modLe _ _) (modLt _ hp) + +end Fin + +open Fin + +instance (n : Nat) : DecidableEq (Fin n) := +{decEq := fun i j => decidableOfDecidableOfIff + (decEq i.val j.val) ⟨eqOfVeq, veqOfEq⟩} diff --git a/stage0/src/Init/Data/HashMap.lean b/stage0/src/Init/Data/HashMap.lean new file mode 100644 index 0000000000..1c6779cedf --- /dev/null +++ b/stage0/src/Init/Data/HashMap.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.HashMap.Basic diff --git a/stage0/src/Init/Data/HashMap/Basic.lean b/stage0/src/Init/Data/HashMap/Basic.lean new file mode 100644 index 0000000000..67937ffd84 --- /dev/null +++ b/stage0/src/Init/Data/HashMap/Basic.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.Array.Basic +import Init.Data.AssocList +import Init.Data.Option.Basic +import Init.Data.Hashable +universes u v w + +def HashMapBucket (α : Type u) (β : Type v) := +{ b : Array (AssocList α β) // b.size > 0 } + +def HashMapBucket.update {α : Type u} {β : Type v} (data : HashMapBucket α β) (i : USize) (d : AssocList α β) (h : i.toNat < data.val.size) : HashMapBucket α β := +⟨ data.val.uset i d h, + transRelRight Greater (Array.szFSetEq (data.val) ⟨USize.toNat i, h⟩ d) data.property ⟩ + +structure HashMapImp (α : Type u) (β : Type v) := +(size : Nat) +(buckets : HashMapBucket α β) + +def mkHashMapImp {α : Type u} {β : Type v} (nbuckets := 8) : HashMapImp α β := +let n := if nbuckets = 0 then 8 else nbuckets; +{ size := 0, + buckets := + ⟨ mkArray n AssocList.nil, + have p₁ : (mkArray n (@AssocList.nil α β)).size = n from Array.szMkArrayEq _ _; + have p₂ : n = (if nbuckets = 0 then 8 else nbuckets) from rfl; + have p₃ : (if nbuckets = 0 then 8 else nbuckets) > 0 from + match nbuckets with + | 0 => Nat.zeroLtSucc _ + | (Nat.succ x) => Nat.zeroLtSucc _; + transRelRight Greater (Eq.trans p₁ p₂) p₃ ⟩ } + +namespace HashMapImp +variables {α : Type u} {β : Type v} + +def mkIdx {n : Nat} (h : n > 0) (u : USize) : { u : USize // u.toNat < n } := +⟨u %ₙ n, USize.modnLt _ h⟩ + +@[inline] def reinsertAux (hashFn : α → USize) (data : HashMapBucket α β) (a : α) (b : β) : HashMapBucket α β := +let ⟨i, h⟩ := mkIdx data.property (hashFn a); +data.update i (AssocList.cons a b (data.val.uget i h)) h + +@[inline] def foldBucketsM {δ : Type w} {m : Type w → Type w} [Monad m] (data : HashMapBucket α β) (d : δ) (f : δ → α → β → m δ) : m δ := +data.val.foldlM (fun d b => b.foldlM f d) d + +@[inline] def foldBuckets {δ : Type w} (data : HashMapBucket α β) (d : δ) (f : δ → α → β → δ) : δ := +Id.run $ foldBucketsM data d f + +@[inline] def foldM {δ : Type w} {m : Type w → Type w} [Monad m] (f : δ → α → β → m δ) (d : δ) (h : HashMapImp α β) : m δ := +foldBucketsM h.buckets d f + +@[inline] def fold {δ : Type w} (f : δ → α → β → δ) (d : δ) (m : HashMapImp α β) : δ := +foldBuckets m.buckets d f + +def find [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) : Option β := +match m with +| ⟨_, buckets⟩ => + let ⟨i, h⟩ := mkIdx buckets.property (hash a); + (buckets.val.uget i h).find a + +def contains [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) : Bool := +match m with +| ⟨_, buckets⟩ => + let ⟨i, h⟩ := mkIdx buckets.property (hash a); + (buckets.val.uget i h).contains a + +-- TODO: remove `partial` by using well-founded recursion +partial def moveEntries [Hashable α] : Nat → Array (AssocList α β) → HashMapBucket α β → HashMapBucket α β +| i, source, target => + if h : i < source.size then + let idx : Fin source.size := ⟨i, h⟩; + let es : AssocList α β := source.get idx; + -- We remove `es` from `source` to make sure we can reuse its memory cells when performing es.foldl + let source := source.set idx AssocList.nil; + let target := es.foldl (reinsertAux hash) target; + moveEntries (i+1) source target + else target + +def expand [Hashable α] (size : Nat) (buckets : HashMapBucket α β) : HashMapImp α β := +let nbuckets := buckets.val.size * 2; +have aux₁ : nbuckets > 0 from Nat.mulPos buckets.property (Nat.zeroLtBit0 Nat.oneNeZero); +have aux₂ : (mkArray nbuckets (@AssocList.nil α β)).size = nbuckets from Array.szMkArrayEq _ _; +let new_buckets : HashMapBucket α β := ⟨mkArray nbuckets AssocList.nil, aux₂.symm ▸ aux₁⟩; +{ size := size, + buckets := moveEntries 0 buckets.val new_buckets } + +def insert [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) (b : β) : HashMapImp α β := +match m with +| ⟨size, buckets⟩ => + let ⟨i, h⟩ := mkIdx buckets.property (hash a); + let bkt := buckets.val.uget i h; + if bkt.contains a + then ⟨size, buckets.update i (bkt.replace a b) h⟩ + else + let size' := size + 1; + let buckets' := buckets.update i (AssocList.cons a b bkt) h; + if size' ≤ buckets.val.size + then { size := size', buckets := buckets' } + else expand size' buckets' + +def erase [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) : HashMapImp α β := +match m with +| ⟨ size, buckets ⟩ => + let ⟨i, h⟩ := mkIdx buckets.property (hash a); + let bkt := buckets.val.uget i h; + if bkt.contains a then ⟨size - 1, buckets.update i (bkt.erase a) h⟩ + else m + +inductive WellFormed [HasBeq α] [Hashable α] : HashMapImp α β → Prop +| mkWff : ∀ n, WellFormed (mkHashMapImp n) +| insertWff : ∀ m a b, WellFormed m → WellFormed (insert m a b) +| eraseWff : ∀ m a, WellFormed m → WellFormed (erase m a) + +end HashMapImp + +def HashMap (α : Type u) (β : Type v) [HasBeq α] [Hashable α] := +{ m : HashMapImp α β // m.WellFormed } + +open HashMapImp + +def mkHashMap {α : Type u} {β : Type v} [HasBeq α] [Hashable α] (nbuckets := 8) : HashMap α β := +⟨ mkHashMapImp nbuckets, WellFormed.mkWff nbuckets ⟩ + +namespace HashMap +variables {α : Type u} {β : Type v} [HasBeq α] [Hashable α] + +instance : Inhabited (HashMap α β) := +⟨mkHashMap⟩ + +instance : HasEmptyc (HashMap α β) := +⟨mkHashMap⟩ + +@[inline] def insert (m : HashMap α β) (a : α) (b : β) : HashMap α β := +match m with +| ⟨ m, hw ⟩ => ⟨ m.insert a b, WellFormed.insertWff m a b hw ⟩ + +@[inline] def erase (m : HashMap α β) (a : α) : HashMap α β := +match m with +| ⟨ m, hw ⟩ => ⟨ m.erase a, WellFormed.eraseWff m a hw ⟩ + +@[inline] def find (m : HashMap α β) (a : α) : Option β := +match m with +| ⟨ m, _ ⟩ => m.find a + +@[inline] def findD (m : HashMap α β) (a : α) (b₀ : β) : β := +(m.find a).getD b₀ + +@[inline] def find! [Inhabited β] (m : HashMap α β) (a : α) : β := +match m.find a with +| some b => b +| none => panic! "key is not in the map" + +@[inline] def contains (m : HashMap α β) (a : α) : Bool := +match m with +| ⟨ m, _ ⟩ => m.contains a + +@[inline] def foldM {δ : Type w} {m : Type w → Type w} [Monad m] (f : δ → α → β → m δ) (d : δ) (h : HashMap α β) : m δ := +match h with +| ⟨ h, _ ⟩ => h.foldM f d + +@[inline] def fold {δ : Type w} (f : δ → α → β → δ) (d : δ) (m : HashMap α β) : δ := +match m with +| ⟨ m, _ ⟩ => m.fold f d + +@[inline] def size (m : HashMap α β) : Nat := +match m with +| ⟨ {size := sz, ..}, _ ⟩ => sz + +@[inline] def isEmpty (m : HashMap α β) : Bool := +m.size = 0 + +@[inline] def empty : HashMap α β := +mkHashMap + +def numBuckets (m : HashMap α β) : Nat := +m.val.buckets.val.size + +end HashMap diff --git a/stage0/src/Init/Data/HashSet.lean b/stage0/src/Init/Data/HashSet.lean new file mode 100644 index 0000000000..30be96338e --- /dev/null +++ b/stage0/src/Init/Data/HashSet.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.HashMap + +universes u v + +structure HashSet (α : Type u) [HasBeq α] [Hashable α] := +(set : HashMap α Unit) + +def mkHashSet {α : Type u} [HasBeq α] [Hashable α] (nbuckets := 8) : HashSet α := +{ set := mkHashMap nbuckets } + +namespace HashSet + +variables {α : Type u} [HasBeq α] [Hashable α] + +instance : Inhabited (HashSet α) := +⟨mkHashSet⟩ + +instance : HasEmptyc (HashSet α) := +⟨mkHashSet⟩ + +@[inline] def insert (s : HashSet α) (a : α) : HashSet α := +{ set := s.set.insert a () } + +@[inline] def erase (s : HashSet α) (a : α) : HashSet α := +{ set := s.set.erase a } + +@[inline] def contains (s : HashSet α) (a : α) : Bool := +s.set.contains a + +@[inline] def size (s : HashSet α) : Nat := +s.set.size + +@[inline] def isEmpty (s : HashSet α) : Bool := +s.set.isEmpty + +@[inline] def empty : HashSet α := +mkHashSet + +@[inline] def foldM {β : Type v} {m : Type v → Type v} [Monad m] (f : β → α → m β) (d : β) (s : HashSet α) : m β := +s.set.foldM (fun d a _ => f d a) d + +@[inline] def fold {β : Type v} (f : β → α → β) (d : β) (s : HashSet α) : β := +Id.run $ s.foldM f d + +end HashSet diff --git a/stage0/src/Init/Data/Hashable.lean b/stage0/src/Init/Data/Hashable.lean new file mode 100644 index 0000000000..f8cd402af5 --- /dev/null +++ b/stage0/src/Init/Data/Hashable.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.UInt +import Init.Data.String +universes u + +class Hashable (α : Type u) := +(hash : α → USize) + +export Hashable (hash) + +@[extern "lean_usize_mix_hash"] +constant mixHash (u₁ u₂ : USize) : USize := arbitrary _ + +@[extern "lean_string_hash"] +protected constant String.hash (s : String) : USize := arbitrary _ +instance : Hashable String := ⟨String.hash⟩ + +protected def Nat.hash (n : Nat) : USize := +USize.ofNat n + +instance : Hashable Nat := ⟨Nat.hash⟩ + +instance {α β} [Hashable α] [Hashable β] : Hashable (α × β) := +⟨fun ⟨a, b⟩ => mixHash (hash a) (hash b)⟩ + +def Option.hash {α} [Hashable α] : Option α → USize +| none => 11 +| some a => mixHash (hash a) 13 + +instance {α} [Hashable α] : Hashable (Option α) := ⟨Option.hash⟩ + +def List.hash {α} [Hashable α] (as : List α) : USize := +as.foldl (fun r a => mixHash r (hash a)) 7 + +instance {α} [Hashable α] : Hashable (List α) := ⟨List.hash⟩ diff --git a/stage0/src/Init/Data/Int.lean b/stage0/src/Init/Data/Int.lean new file mode 100644 index 0000000000..55959e95bd --- /dev/null +++ b/stage0/src/Init/Data/Int.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Int.Basic diff --git a/stage0/src/Init/Data/Int/Basic.lean b/stage0/src/Init/Data/Int/Basic.lean new file mode 100644 index 0000000000..2709544694 --- /dev/null +++ b/stage0/src/Init/Data/Int/Basic.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2016 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Leonardo de Moura + +The integers, with addition, multiplication, and subtraction. +-/ +prelude +import Init.Data.Nat.Basic +import Init.Data.List +import Init.Coe +import Init.Data.Repr +import Init.Data.ToString +open Nat + +/- the Type, coercions, and notation -/ + +inductive Int : Type +| ofNat : Nat → Int +| negSucc : Nat → Int + +attribute [extern "lean_nat_to_int"] Int.ofNat +attribute [extern "lean_int_neg_succ_of_nat"] Int.negSucc + +instance : HasCoe Nat Int := ⟨Int.ofNat⟩ + +namespace Int +protected def zero : Int := ofNat 0 +protected def one : Int := ofNat 1 + +instance : HasZero Int := ⟨Int.zero⟩ +instance : HasOne Int := ⟨Int.one⟩ + +def negOfNat : Nat → Int +| 0 => 0 +| succ m => negSucc m + +@[extern "lean_int_neg"] +protected def neg (n : @& Int) : Int := +match n with +| ofNat n => negOfNat n +| negSucc n => succ n + +def subNatNat (m n : Nat) : Int := +match (n - m : Nat) with +| 0 => ofNat (m - n) -- m ≥ n +| (succ k) => negSucc k + +@[extern "lean_int_add"] +protected def add (m n : @& Int) : Int := +match m, n with +| ofNat m, ofNat n => ofNat (m + n) +| ofNat m, negSucc n => subNatNat m (succ n) +| negSucc m, ofNat n => subNatNat n (succ m) +| negSucc m, negSucc n => negSucc (m + n) + +@[extern "lean_int_mul"] +protected def mul (m n : @& Int) : Int := +match m, n with +| ofNat m, ofNat n => ofNat (m * n) +| ofNat m, negSucc n => negOfNat (m * succ n) +| negSucc m, ofNat n => negOfNat (succ m * n) +| negSucc m, negSucc n => ofNat (succ m * succ n) + +instance : HasNeg Int := ⟨Int.neg⟩ +instance : HasAdd Int := ⟨Int.add⟩ +instance : HasMul Int := ⟨Int.mul⟩ + +@[extern "lean_int_sub"] +protected def sub (m n : @& Int) : Int := +m + -n + +instance : HasSub Int := ⟨Int.sub⟩ + +inductive NonNeg : Int → Prop +| mk (n : Nat) : NonNeg (ofNat n) + +protected def LessEq (a b : Int) : Prop := NonNeg (b - a) + +instance : HasLessEq Int := ⟨Int.LessEq⟩ + +protected def Less (a b : Int) : Prop := (a + 1) ≤ b + +instance : HasLess Int := ⟨Int.Less⟩ + +@[extern "lean_int_dec_eq"] +protected def decEq (a b : @& Int) : Decidable (a = b) := +match a, b with + | ofNat a, ofNat b => match decEq a b with + | isTrue h => isTrue $ h ▸ rfl + | isFalse h => isFalse $ fun h' => Int.noConfusion h' (fun h' => absurd h' h) + | negSucc a, negSucc b => match decEq a b with + | isTrue h => isTrue $ h ▸ rfl + | isFalse h => isFalse $ fun h' => Int.noConfusion h' (fun h' => absurd h' h) + | ofNat a, negSucc b => isFalse $ fun h => Int.noConfusion h + | negSucc a, ofNat b => isFalse $ fun h => Int.noConfusion h + +instance Int.DecidableEq : DecidableEq Int := +{decEq := Int.decEq} + +@[extern "lean_int_dec_nonneg"] +private def decNonneg (m : @& Int) : Decidable (NonNeg m) := +match m with +| ofNat m => isTrue $ NonNeg.mk m +| negSucc m => isFalse $ fun h => nomatch h + +@[extern "lean_int_dec_le"] +instance decLe (a b : @& Int) : Decidable (a ≤ b) := +decNonneg _ + +@[extern "lean_int_dec_lt"] +instance decLt (a b : @& Int) : Decidable (a < b) := +decNonneg _ + +@[extern "lean_nat_abs"] +def natAbs (m : @& Int) : Nat := +match m with +| ofNat m => m +| negSucc m => m.succ + +protected def repr : Int → String +| ofNat m => Nat.repr m +| negSucc m => "-" ++ Nat.repr (succ m) + +instance : HasRepr Int := +⟨Int.repr⟩ + +instance : HasToString Int := +⟨Int.repr⟩ + +@[extern "lean_int_div"] +def div : (@& Int) → (@& Int) → Int +| ofNat m, ofNat n => ofNat (m / n) +| ofNat m, negSucc n => -ofNat (m / succ n) +| negSucc m, ofNat n => -ofNat (succ m / n) +| negSucc m, negSucc n => ofNat (succ m / succ n) + +@[extern "lean_int_mod"] +def mod : (@& Int) → (@& Int) → Int +| ofNat m, ofNat n => ofNat (m % n) +| ofNat m, negSucc n => ofNat (m % succ n) +| negSucc m, ofNat n => -ofNat (succ m % n) +| negSucc m, negSucc n => -ofNat (succ m % succ n) + +instance : HasDiv Int := ⟨Int.div⟩ +instance : HasMod Int := ⟨Int.mod⟩ + +def toNat : Int → Nat +| ofNat n => n +| negSucc n => 0 + +def natMod (m n : Int) : Nat := (m % n).toNat + +end Int + +namespace String + +def toInt (s : String) : Int := +if s.get 0 = '-' then + - Int.ofNat (s.toSubstring.drop 1).toNat +else + Int.ofNat s.toNat + +def isInt (s : String) : Bool := +if s.get 0 = '-' then + (s.toSubstring.drop 1).isNat +else + s.isNat + +end String diff --git a/stage0/src/Init/Data/List.lean b/stage0/src/Init/Data/List.lean new file mode 100644 index 0000000000..9af534e509 --- /dev/null +++ b/stage0/src/Init/Data/List.lean @@ -0,0 +1,10 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.List.Basic +import Init.Data.List.BasicAux +import Init.Data.List.Instances +import Init.Data.List.Control diff --git a/stage0/src/Init/Data/List/Basic.lean b/stage0/src/Init/Data/List/Basic.lean new file mode 100644 index 0000000000..a9e50cd84f --- /dev/null +++ b/stage0/src/Init/Data/List/Basic.lean @@ -0,0 +1,346 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Core +import Init.Data.Nat.Basic +open Decidable List + +universes u v w + +instance (α : Type u) : Inhabited (List α) := +⟨List.nil⟩ + +variables {α : Type u} {β : Type v} {γ : Type w} + +namespace List + +protected def hasDecEq [DecidableEq α] : ∀ (a b : List α), Decidable (a = b) +| [], [] => isTrue rfl +| a::as, [] => isFalse (fun h => List.noConfusion h) +| [], b::bs => isFalse (fun h => List.noConfusion h) +| a::as, b::bs => + match decEq a b with + | isTrue hab => + match hasDecEq as bs with + | isTrue habs => isTrue (Eq.subst hab (Eq.subst habs rfl)) + | isFalse nabs => isFalse (fun h => List.noConfusion h (fun _ habs => absurd habs nabs)) + | isFalse nab => isFalse (fun h => List.noConfusion h (fun hab _ => absurd hab nab)) + +instance [DecidableEq α] : DecidableEq (List α) := +{decEq := List.hasDecEq} + +def reverseAux : List α → List α → List α +| [], r => r +| a::l, r => reverseAux l (a::r) + +def reverse : List α → List α := +fun l => reverseAux l [] + +protected def append (as bs : List α) : List α := +reverseAux as.reverse bs + +instance : HasAppend (List α) := +⟨List.append⟩ + +theorem reverseAuxReverseAuxNil : ∀ (as bs : List α), reverseAux (reverseAux as bs) [] = reverseAux bs as +| [], bs => rfl +| a::as, bs => + show reverseAux (reverseAux as (a::bs)) [] = reverseAux bs (a::as) from + reverseAuxReverseAuxNil as (a::bs) + +theorem nilAppend (as : List α) : [] ++ as = as := +rfl + +theorem appendNil (as : List α) : as ++ [] = as := +show reverseAux (reverseAux as []) [] = as from +reverseAuxReverseAuxNil as [] + +theorem reverseAuxReverseAux : ∀ (as bs cs : List α), reverseAux (reverseAux as bs) cs = reverseAux bs (reverseAux (reverseAux as []) cs) +| [], bs, cs => rfl +| a::as, bs, cs => + Eq.trans + (reverseAuxReverseAux as (a::bs) cs) + (congrArg (fun b => reverseAux bs b) (reverseAuxReverseAux as [a] cs).symm) + +theorem consAppend (a : α) (as bs : List α) : (a::as) ++ bs = a::(as ++ bs) := +reverseAuxReverseAux as [a] bs + +theorem appendAssoc : ∀ (as bs cs : List α), (as ++ bs) ++ cs = as ++ (bs ++ cs) +| [], bs, cs => rfl +| a::as, bs, cs => + show ((a::as) ++ bs) ++ cs = (a::as) ++ (bs ++ cs) from + have h₁ : ((a::as) ++ bs) ++ cs = a::(as++bs) ++ cs from congrArg (fun ds => ds ++ cs) (consAppend a as bs); + have h₂ : a::(as++bs) ++ cs = a::((as++bs) ++ cs) from consAppend a (as++bs) cs; + have h₃ : a::((as++bs) ++ cs) = a::(as ++ (bs ++ cs)) from congrArg (fun as => a::as) (appendAssoc as bs cs); + have h₄ : a::(as ++ (bs ++ cs)) = (a::as ++ (bs ++ cs)) from (consAppend a as (bs++cs)).symm; + Eq.trans (Eq.trans (Eq.trans h₁ h₂) h₃) h₄ + +instance : HasEmptyc (List α) := +⟨List.nil⟩ + +protected def erase {α} [HasBeq α] : List α → α → List α +| [], b => [] +| a::as, b => match a == b with + | true => as + | false => a :: erase as b + +def eraseIdx : List α → Nat → List α +| [], _ => [] +| a::as, 0 => as +| a::as, n+1 => a :: eraseIdx as n + +def lengthAux : List α → Nat → Nat +| [], n => n +| a::as, n => lengthAux as (n+1) + +def length (as : List α) : Nat := +lengthAux as 0 + +def isEmpty : List α → Bool +| [] => true +| _ :: _ => false + +def set : List α → Nat → α → List α +| a::as, 0, b => b::as +| a::as, n+1, b => a::(set as n b) +| [], _, _ => [] + +@[specialize] def map (f : α → β) : List α → List β +| [] => [] +| a::as => f a :: map as + +@[specialize] def map₂ (f : α → β → γ) : List α → List β → List γ +| [], _ => [] +| _, [] => [] +| a::as, b::bs => f a b :: map₂ as bs + +def join : List (List α) → List α +| [] => [] +| a :: as => a ++ join as + +@[specialize] def filterMap (f : α → Option β) : List α → List β +| [] => [] +| a::as => + match f a with + | none => filterMap as + | some b => b :: filterMap as + +@[specialize] def filterAux (p : α → Bool) : List α → List α → List α +| [], rs => rs.reverse +| a::as, rs => match p a with + | true => filterAux as (a::rs) + | false => filterAux as rs + +@[inline] def filter (p : α → Bool) (as : List α) : List α := +filterAux p as [] + +@[specialize] def partitionAux (p : α → Bool) : List α → List α × List α → List α × List α +| [], (bs, cs) => (bs.reverse, cs.reverse) +| a::as, (bs, cs) => + match p a with + | true => partitionAux as (a::bs, cs) + | false => partitionAux as (bs, a::cs) + +@[inline] def partition (p : α → Bool) (as : List α) : List α × List α := +partitionAux p as ([], []) + +def dropWhile (p : α → Bool) : List α → List α +| [] => [] +| a::l => match p a with + | true => dropWhile l + | false => a::l + +def find (p : α → Bool) : List α → Option α +| [] => none +| a::as => match p a with + | true => some a + | false => find as + +def elem [HasBeq α] (a : α) : List α → Bool +| [] => false +| b::bs => match a == b with + | true => true + | false => elem bs + +def notElem [HasBeq α] (a : α) (as : List α) : Bool := +!(as.elem a) + +abbrev contains [HasBeq α] (as : List α) (a : α) : Bool := +elem a as + +def eraseDupsAux {α} [HasBeq α] : List α → List α → List α +| [], bs => bs.reverse +| a::as, bs => match bs.elem a with + | true => eraseDupsAux as bs + | false => eraseDupsAux as (a::bs) + +def eraseDups {α} [HasBeq α] (as : List α) : List α := +eraseDupsAux as [] + +@[specialize] def spanAux (p : α → Bool) : List α → List α → List α × List α +| [], rs => (rs.reverse, []) +| a::as, rs => match p a with + | true => spanAux as (a::rs) + | false => (rs.reverse, a::as) + +@[inline] def span (p : α → Bool) (as : List α) : List α × List α := +spanAux p as [] + +def lookup [HasBeq α] : α → List (α × β) → Option β +| _, [] => none +| a, (k,b)::es => match a == k with + | true => some b + | false => lookup a es + +def removeAll [HasBeq α] (xs ys : List α) : List α := +xs.filter (fun x => ys.notElem x) + +def drop : Nat → List α → List α +| 0, a => a +| n+1, [] => [] +| n+1, a::as => drop n as + +def take : Nat → List α → List α +| 0, a => [] +| n+1, [] => [] +| n+1, a::as => a :: take n as + +@[specialize] def foldl (f : α → β → α) : α → List β → α +| a, [] => a +| a, b :: l => foldl (f a b) l + +@[specialize] def foldr (f : α → β → β) (b : β) : List α → β +| [] => b +| a :: l => f a (foldr l) + +@[specialize] def foldr1 (f : α → α → α) : ∀ (xs : List α), xs ≠ [] → α +| [], h => absurd rfl h +| [a], _ => a +| a :: as@(_::_), _ => f a (foldr1 as (fun h => List.noConfusion h)) + +@[specialize] def foldr1Opt (f : α → α → α) : List α → Option α +| [] => none +| a :: as => some $ foldr1 f (a :: as) (fun h => List.noConfusion h) + +@[inline] def any (l : List α) (p : α → Bool) : Bool := +foldr (fun a r => p a || r) false l + +@[inline] def all (l : List α) (p : α → Bool) : Bool := +foldr (fun a r => p a && r) true l + +def or (bs : List Bool) : Bool := bs.any id + +def and (bs : List Bool) : Bool := bs.all id + +def zipWith (f : α → β → γ) : List α → List β → List γ +| x::xs, y::ys => f x y :: zipWith xs ys +| _, _ => [] + +def zip : List α → List β → List (Prod α β) := +zipWith Prod.mk + +def unzip : List (α × β) → List α × List β +| [] => ([], []) +| (a, b) :: t => match unzip t with | (al, bl) => (a::al, b::bl) + +def replicate (n : Nat) (a : α) : List α := +n.repeat (fun xs => a :: xs) [] + +def rangeAux : Nat → List Nat → List Nat +| 0, ns => ns +| n+1, ns => rangeAux n (n::ns) + +def range (n : Nat) : List Nat := +rangeAux n [] + +def iota : Nat → List Nat +| 0 => [] +| m@(n+1) => m :: iota n + +def enumFrom : Nat → List α → List (Nat × α) +| n, [] => nil +| n, x :: xs => (n, x) :: enumFrom (n + 1) xs + +def enum : List α → List (Nat × α) := enumFrom 0 + +def init : List α → List α +| [] => [] +| [a] => [] +| a::l => a::init l + +def intersperse (sep : α) : List α → List α +| [] => [] +| [x] => [x] +| x::xs => x::sep::intersperse xs + +def intercalate (sep : List α) (xs : List (List α)) : List α := +join (intersperse sep xs) + +@[inline] protected def bind {α : Type u} {β : Type v} (a : List α) (b : α → List β) : List β := +join (map b a) + +@[inline] protected def pure {α : Type u} (a : α) : List α := +[a] + +inductive Less [HasLess α] : List α → List α → Prop +| nil (b : α) (bs : List α) : Less [] (b::bs) +| head {a : α} (as : List α) {b : α} (bs : List α) : a < b → Less (a::as) (b::bs) +| tail {a : α} {as : List α} {b : α} {bs : List α} : ¬ a < b → ¬ b < a → Less as bs → Less (a::as) (b::bs) + +instance [HasLess α] : HasLess (List α) := +⟨List.Less⟩ + +instance hasDecidableLt [HasLess α] [h : DecidableRel HasLess.Less] : ∀ (l₁ l₂ : List α), Decidable (l₁ < l₂) +| [], [] => isFalse (fun h => nomatch h) +| [], b::bs => isTrue (Less.nil _ _) +| a::as, [] => isFalse (fun h => nomatch h) +| a::as, b::bs => + match h a b with + | isTrue h₁ => isTrue (Less.head _ _ h₁) + | isFalse h₁ => + match h b a with + | isTrue h₂ => isFalse (fun h => match h with + | Less.head _ _ h₁' => absurd h₁' h₁ + | Less.tail _ h₂' _ => absurd h₂ h₂') + | isFalse h₂ => + match hasDecidableLt as bs with + | isTrue h₃ => isTrue (Less.tail h₁ h₂ h₃) + | isFalse h₃ => isFalse (fun h => match h with + | Less.head _ _ h₁' => absurd h₁' h₁ + | Less.tail _ _ h₃' => absurd h₃' h₃) + +@[reducible] protected def LessEq [HasLess α] (a b : List α) : Prop := +¬ b < a + +instance [HasLess α] : HasLessEq (List α) := +⟨List.LessEq⟩ + +instance hasDecidableLe [HasLess α] [h : DecidableRel (HasLess.Less : α → α → Prop)] : ∀ (l₁ l₂ : List α), Decidable (l₁ ≤ l₂) := +fun a b => Not.Decidable + +/-- `isPrefixOf l₁ l₂` returns `true` Iff `l₁` is a prefix of `l₂`. -/ +def isPrefixOf [HasBeq α] : List α → List α → Bool +| [], _ => true +| _, [] => false +| a::as, b::bs => a == b && isPrefixOf as bs + +/-- `isSuffixOf l₁ l₂` returns `true` Iff `l₁` is a suffix of `l₂`. -/ +def isSuffixOf [HasBeq α] (l₁ l₂ : List α) : Bool := +isPrefixOf l₁.reverse l₂.reverse + +@[specialize] def isEqv : List α → List α → (α → α → Bool) → Bool +| [], [], _ => true +| a::as, b::bs, eqv => eqv a b && isEqv as bs eqv +| _, _, eqv => false + +protected def beq [HasBeq α] : List α → List α → Bool +| [], [] => true +| a::as, b::bs => a == b && beq as bs +| _, _ => false + +instance [HasBeq α] : HasBeq (List α) := ⟨List.beq⟩ + +end List diff --git a/stage0/src/Init/Data/List/BasicAux.lean b/stage0/src/Init/Data/List/BasicAux.lean new file mode 100644 index 0000000000..6e3b2d521d --- /dev/null +++ b/stage0/src/Init/Data/List/BasicAux.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.List.Basic +import Init.Util + +universes u + +namespace List +/- The following functions can't be defined at `init.data.list.basic`, because they depend on `init.util`, + and `init.util` depends on `init.data.list.basic`. -/ + +variables {α : Type u} + +def get! [Inhabited α] : Nat → List α → α +| 0, a::as => a +| n+1, a::as => get! n as +| _, _ => panic! "invalid index" + +def get? : Nat → List α → Option α +| 0, a::as => some a +| n+1, a::as => get? n as +| _, _ => none + +def getD (idx : Nat) (as : List α) (a₀ : α) : α := +(as.get? idx).getD a₀ + +def head! [Inhabited α] : List α → α +| [] => panic! "empty list" +| a::_ => a + +def head? : List α → Option α +| [] => none +| a::_ => some a + +def headD : List α → α → α +| [], a₀ => a₀ +| a::_, _ => a + +def tail! : List α → List α +| [] => panic! "empty list" +| a::as => as + +def tail? : List α → Option (List α) +| [] => none +| a::as => some as + +def tailD : List α → List α → List α +| [], as₀ => as₀ +| a::as, _ => as + +def getLast : ∀ (as : List α), as ≠ [] → α +| [], h => absurd rfl h +| [a], h => a +| a::b::as, h => getLast (b::as) (fun h => List.noConfusion h) + +def getLast! [Inhabited α] : List α → α +| [] => panic! "empty list" +| a::as => getLast (a::as) (fun h => List.noConfusion h) + +def getLast? : List α → Option α +| [] => none +| a::as => some (getLast (a::as) (fun h => List.noConfusion h)) + +def getLastD : List α → α → α +| [], a₀ => a₀ +| a::as, _ => getLast (a::as) (fun h => List.noConfusion h) + +end List diff --git a/stage0/src/Init/Data/List/Control.lean b/stage0/src/Init/Data/List/Control.lean new file mode 100644 index 0000000000..920d7f257c --- /dev/null +++ b/stage0/src/Init/Data/List/Control.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Control.Monad +import Init.Control.Alternative + +namespace List +universes u v w u₁ u₂ + +/- +Remark: we can define `mapM`, `mapM₂` and `forM` using `Applicative` instead of `Monad`. +Example: +``` +def mapM {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β) +| [] => pure [] +| a::as => List.cons <$> (f a) <*> mapM as +``` + +However, we consider `f <$> a <*> b` an anti-idiom because the generated code +may produce unnecessary closure allocations. +Suppose `m` is a `Monad`, and it uses the default implementation for `Applicative.seq`. +Then, the compiler expands `f <$> a <*> b <*> c` into something equivalent to +``` +(Functor.map f a >>= fun g_1 => Functor.map g_1 b) >>= fun g_2 => Functor.map g_2 c +``` +In an ideal world, the compiler may eliminate the temporary closures `g_1` and `g_2` after it inlines +`Functor.map` and `Monad.bind`. However, this can easily fail. For example, suppose +`Functor.map f a >>= fun g_1 => Functor.map g_1 b` expanded into a match-expression. +This is not unreasonable and can happen in many different ways, e.g., we are using a monad that +may throw exceptions. Then, the compiler has to decide whether it will create a join-point for +the continuation of the match or float it. If the compiler decides to float, then it will +be able to eliminate the closures, but it may not be feasible since floating match expressions +may produce exponential blowup in the code size. + +Finally, we rarely use `mapM` with something that is not a `Monad`. + +Users that want to use `mapM` with `Applicative` should use `mapA` instead. +-/ + +@[specialize] +def mapM {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β) +| [] => pure [] +| a::as => do b ← f a; bs ← mapM as; pure (b :: bs) + +@[specialize] +def mapM₂ {m : Type u → Type v} [Monad m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m (List γ) +| a::as, b::bs => do c ← f a b; cs ← mapM₂ as bs; pure (c :: cs) +| _, _ => pure [] + +@[specialize] +def mapA {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β) +| [] => pure [] +| a::as => List.cons <$> f a <*> mapA as + +@[specialize] +def mapA₂ {m : Type u → Type v} [Applicative m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m (List γ) +| a::as, b::bs => List.cons <$> f a b <*> mapA₂ as bs +| _, _ => pure [] + +@[specialize] +def forM {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β) : List α → m PUnit +| [] => pure ⟨⟩ +| h :: t => do f h; forM t + +@[specialize] +def forM₂ {m : Type u → Type v} [Monad m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m PUnit +| a::as, b::bs => do f a b; forM₂ as bs +| _, _ => pure ⟨⟩ + +@[specialize] +def forA {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m PUnit +| [] => pure ⟨⟩ +| h :: t => f h *> forA t + +@[specialize] +def forA₂ {m : Type u → Type v} [Applicative m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m PUnit +| a::as, b::bs => f a b *> forA₂ as bs +| _, _ => pure ⟨⟩ + +@[specialize] +def filterM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) : List α → m (List α) +| [] => pure [] +| h :: t => do b ← f h; t' ← filterM t; cond b (pure (h :: t')) (pure t') + +@[specialize] +def foldlM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} : (s → α → m s) → s → List α → m s +| f, s, [] => pure s +| f, s, h :: r => do + s' ← f s h; + foldlM f s' r + +@[specialize] +def foldrM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} : (α → s → m s) → s → List α → m s +| f, s, [] => pure s +| f, s, h :: r => do + s' ← foldrM f s r; + f h s' + +@[specialize] +def firstM {m : Type u → Type v} [Monad m] [Alternative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m β +| [] => failure +| a::as => f a <|> firstM as + +@[specialize] +def anyM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool +| [] => pure false +| a::as => do b ← f a; match b with + | true => pure true + | false => anyM as + +@[specialize] +def allM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool +| [] => pure true +| a::as => do b ← f a; match b with + | true => allM as + | false => pure false + +end List diff --git a/stage0/src/Init/Data/List/Instances.lean b/stage0/src/Init/Data/List/Instances.lean new file mode 100644 index 0000000000..7a92dd1b9f --- /dev/null +++ b/stage0/src/Init/Data/List/Instances.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.List.Basic +import Init.Control.Alternative +import Init.Control.Monad +open List + +universes u v + +instance : Monad List := +{ pure := @List.pure, map := @List.map, bind := @List.bind } + +instance : Alternative List := +{ failure := @List.nil, + orelse := @List.append, + ..List.Monad } diff --git a/stage0/src/Init/Data/Nat.lean b/stage0/src/Init/Data/Nat.lean new file mode 100644 index 0000000000..cf7be93c6e --- /dev/null +++ b/stage0/src/Init/Data/Nat.lean @@ -0,0 +1,10 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Nat.Basic +import Init.Data.Nat.Div +import Init.Data.Nat.Bitwise +import Init.Data.Nat.Control diff --git a/stage0/src/Init/Data/Nat/Basic.lean b/stage0/src/Init/Data/Nat/Basic.lean new file mode 100644 index 0000000000..3a6e5c3381 --- /dev/null +++ b/stage0/src/Init/Data/Nat/Basic.lean @@ -0,0 +1,717 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Floris van Doorn, Leonardo de Moura +-/ +prelude +import Init.Core +universes u + +namespace Nat + +@[extern "lean_nat_dec_eq"] +def beq : Nat → Nat → Bool +| zero, zero => true +| zero, succ m => false +| succ n, zero => false +| succ n, succ m => beq n m + +theorem eqOfBeqEqTt : ∀ {n m : Nat}, beq n m = true → n = m +| zero, zero, h => rfl +| zero, succ m, h => Bool.noConfusion h +| succ n, zero, h => Bool.noConfusion h +| succ n, succ m, h => + have beq n m = true from h; + have n = m from eqOfBeqEqTt this; + congrArg succ this + +theorem neOfBeqEqFf : ∀ {n m : Nat}, beq n m = false → n ≠ m +| zero, zero, h₁, h₂ => Bool.noConfusion h₁ +| zero, succ m, h₁, h₂ => Nat.noConfusion h₂ +| succ n, zero, h₁, h₂ => Nat.noConfusion h₂ +| succ n, succ m, h₁, h₂ => + have beq n m = false from h₁; + have n ≠ m from neOfBeqEqFf this; + Nat.noConfusion h₂ (fun h₂ => absurd h₂ this) + +@[extern "lean_nat_dec_eq"] +protected def decEq (n m : @& Nat) : Decidable (n = m) := +if h : beq n m = true then isTrue (eqOfBeqEqTt h) +else isFalse (neOfBeqEqFf (eqFalseOfNeTrue h)) + +@[inline] instance : DecidableEq Nat := +{decEq := Nat.decEq} + +@[extern "lean_nat_dec_le"] +def ble : Nat → Nat → Bool +| zero, zero => true +| zero, succ m => true +| succ n, zero => false +| succ n, succ m => ble n m + +protected def le (n m : Nat) : Prop := +ble n m = true + +instance : HasLessEq Nat := +⟨Nat.le⟩ + +protected def lt (n m : Nat) : Prop := +Nat.le (succ n) m + +instance : HasLess Nat := +⟨Nat.lt⟩ + +@[extern c inline "lean_nat_sub(#1, lean_box(1))"] +def pred : Nat → Nat +| 0 => 0 +| a+1 => a + +@[extern "lean_nat_sub"] +protected def sub : (@& Nat) → (@& Nat) → Nat +| a, 0 => a +| a, b+1 => pred (sub a b) + +@[extern "lean_nat_mul"] +protected def mul : (@& Nat) → (@& Nat) → Nat +| a, 0 => 0 +| a, b+1 => (mul a b) + a + +instance : HasSub Nat := +⟨Nat.sub⟩ + +instance : HasMul Nat := +⟨Nat.mul⟩ + +@[specialize] def foldAux {α : Type u} (f : Nat → α → α) (s : Nat) : Nat → α → α +| 0, a => a +| succ n, a => foldAux n (f (s - (succ n)) a) + +@[inline] def fold {α : Type u} (f : Nat → α → α) (n : Nat) (a : α) : α := +foldAux f n n a + +@[specialize] def foldRevAux {α : Type u} (f : Nat → α → α) : Nat → α → α +| 0, a => a +| succ n, a => foldRevAux n (f n a) + +@[inline] def foldRev {α : Type u} (f : Nat → α → α) (n : Nat) (a : α) : α := +foldRevAux f n a + +@[specialize] def anyAux (f : Nat → Bool) (s : Nat) : Nat → Bool +| 0 => false +| succ n => f (s - (succ n)) || anyAux n + +/- `any f n = true` iff there is `i in [0, n-1]` s.t. `f i = true` -/ +@[inline] def any (f : Nat → Bool) (n : Nat) : Bool := +anyAux f n n + +@[inline] def all (f : Nat → Bool) (n : Nat) : Bool := +!any (fun i => !f i) n + +@[specialize] def repeatAux {α : Type u} (f : α → α) : Nat → α → α +| 0, a => a +| succ n, a => repeatAux n (f a) + +@[inline] def repeat {α : Type u} (f : α → α) (n : Nat) (a : α) : α := +repeatAux f n a + +protected def pow (m : Nat) : Nat → Nat +| 0 => 1 +| succ n => pow n * m + +instance : HasPow Nat Nat := +⟨Nat.pow⟩ + +/- Nat.add theorems -/ + +protected theorem zeroAdd : ∀ (n : Nat), 0 + n = n +| 0 => rfl +| n+1 => congrArg succ (zeroAdd n) + +theorem succAdd : ∀ (n m : Nat), (succ n) + m = succ (n + m) +| n, 0 => rfl +| n, m+1 => congrArg succ (succAdd n m) + +theorem addSucc (n m : Nat) : n + succ m = succ (n + m) := +rfl + +protected theorem addZero (n : Nat) : n + 0 = n := +rfl + +theorem addOne (n : Nat) : n + 1 = succ n := +rfl + +theorem succEqAddOne (n : Nat) : succ n = n + 1 := +rfl + +protected theorem addComm : ∀ (n m : Nat), n + m = m + n +| n, 0 => Eq.symm (Nat.zeroAdd n) +| n, m+1 => + suffices succ (n + m) = succ (m + n) from Eq.symm (succAdd m n) ▸ this; + congrArg succ (addComm n m) + +protected theorem addAssoc : ∀ (n m k : Nat), (n + m) + k = n + (m + k) +| n, m, 0 => rfl +| n, m, succ k => congrArg succ (addAssoc n m k) + +protected theorem addLeftComm : ∀ (n m k : Nat), n + (m + k) = m + (n + k) := +leftComm Nat.add Nat.addComm Nat.addAssoc + +protected theorem addRightComm : ∀ (n m k : Nat), (n + m) + k = (n + k) + m := +rightComm Nat.add Nat.addComm Nat.addAssoc + +protected theorem addLeftCancel : ∀ {n m k : Nat}, n + m = n + k → m = k +| 0, m, k, h => Nat.zeroAdd m ▸ Nat.zeroAdd k ▸ h +| succ n, m, k, h => + have n+m = n+k from + have succ (n + m) = succ (n + k) from succAdd n m ▸ succAdd n k ▸ h; + Nat.noConfusion this id; + addLeftCancel this + +protected theorem addRightCancel {n m k : Nat} (h : n + m = k + m) : n = k := +have m + n = m + k from Nat.addComm n m ▸ Nat.addComm k m ▸ h; +Nat.addLeftCancel this + +/- Nat.mul theorems -/ + +protected theorem mulZero (n : Nat) : n * 0 = 0 := +rfl + +theorem mulSucc (n m : Nat) : n * succ m = n * m + n := +rfl + +protected theorem zeroMul : ∀ (n : Nat), 0 * n = 0 +| 0 => rfl +| succ n => (mulSucc 0 n).symm ▸ (zeroMul n).symm ▸ rfl + +theorem succMul : ∀ (n m : Nat), (succ n) * m = (n * m) + m +| n, 0 => rfl +| n, succ m => + have succ (n * m + m + n) = succ (n * m + n + m) from + congrArg succ (Nat.addRightComm _ _ _); + (mulSucc n m).symm ▸ (mulSucc (succ n) m).symm ▸ (succMul n m).symm ▸ this + +protected theorem mulComm : ∀ (n m : Nat), n * m = m * n +| n, 0 => (Nat.zeroMul n).symm ▸ (Nat.mulZero n).symm ▸ rfl +| n, succ m => (mulSucc n m).symm ▸ (succMul m n).symm ▸ (mulComm n m).symm ▸ rfl + +protected theorem mulOne : ∀ (n : Nat), n * 1 = n := +Nat.zeroAdd + +protected theorem oneMul (n : Nat) : 1 * n = n := +Nat.mulComm n 1 ▸ Nat.mulOne n + +protected theorem leftDistrib : ∀ (n m k : Nat), n * (m + k) = n * m + n * k +| 0, m, k => (Nat.zeroMul (m + k)).symm ▸ (Nat.zeroMul m).symm ▸ (Nat.zeroMul k).symm ▸ rfl +| succ n, m, k => + have h₁ : succ n * (m + k) = n * (m + k) + (m + k) from succMul _ _; + have h₂ : n * (m + k) + (m + k) = (n * m + n * k) + (m + k) from leftDistrib n m k ▸ rfl; + have h₃ : (n * m + n * k) + (m + k) = n * m + (n * k + (m + k)) from Nat.addAssoc _ _ _; + have h₄ : n * m + (n * k + (m + k)) = n * m + (m + (n * k + k)) from congrArg (fun x => n*m + x) (Nat.addLeftComm _ _ _); + have h₅ : n * m + (m + (n * k + k)) = (n * m + m) + (n * k + k) from (Nat.addAssoc _ _ _).symm; + have h₆ : (n * m + m) + (n * k + k) = (n * m + m) + succ n * k from succMul n k ▸ rfl; + have h₇ : (n * m + m) + succ n * k = succ n * m + succ n * k from succMul n m ▸ rfl; + (((((h₁.trans h₂).trans h₃).trans h₄).trans h₅).trans h₆).trans h₇ + +protected theorem rightDistrib (n m k : Nat) : (n + m) * k = n * k + m * k := +have h₁ : (n + m) * k = k * (n + m) from Nat.mulComm _ _; +have h₂ : k * (n + m) = k * n + k * m from Nat.leftDistrib _ _ _; +have h₃ : k * n + k * m = n * k + k * m from Nat.mulComm n k ▸ rfl; +have h₄ : n * k + k * m = n * k + m * k from Nat.mulComm m k ▸ rfl; +((h₁.trans h₂).trans h₃).trans h₄ + +protected theorem mulAssoc : ∀ (n m k : Nat), (n * m) * k = n * (m * k) +| n, m, 0 => rfl +| n, m, succ k => + have h₁ : n * m * succ k = n * m * (k + 1) from rfl; + have h₂ : n * m * (k + 1) = (n * m * k) + n * m * 1 from Nat.leftDistrib _ _ _; + have h₃ : (n * m * k) + n * m * 1 = (n * m * k) + n * m from (Nat.mulOne (n*m)).symm ▸ rfl; + have h₄ : (n * m * k) + n * m = (n * (m * k)) + n * m from (mulAssoc n m k).symm ▸ rfl; + have h₅ : (n * (m * k)) + n * m = n * (m * k + m) from (Nat.leftDistrib n (m*k) m).symm; + have h₆ : n * (m * k + m) = n * (m * succ k) from Nat.mulSucc m k ▸ rfl; +((((h₁.trans h₂).trans h₃).trans h₄).trans h₅).trans h₆ + +/- Inequalities -/ + +protected def leRefl : ∀ (n : Nat), n ≤ n +| zero => rfl +| succ n => leRefl n + +theorem leSucc : ∀ (n : Nat), n ≤ succ n +| zero => rfl +| succ n => leSucc n + +theorem succLeSucc {n m : Nat} (h : n ≤ m) : succ n ≤ succ m := +h + +theorem succLtSucc {n m : Nat} : n < m → succ n < succ m := +succLeSucc + +theorem leStep : ∀ {n m : Nat}, n ≤ m → n ≤ succ m +| zero, zero, h => rfl +| zero, succ n, h => rfl +| succ n, zero, h => Bool.noConfusion h +| succ n, succ m, h => + have n ≤ m from h; + have n ≤ succ m from leStep this; + succLeSucc this + +theorem zeroLe : ∀ (n : Nat), 0 ≤ n +| zero => rfl +| succ n => rfl + +theorem zeroLtSucc (n : Nat) : 0 < succ n := +succLeSucc (zeroLe n) + +def succPos := zeroLtSucc + +theorem notSuccLeZero : ∀ (n : Nat), succ n ≤ 0 → False +| 0, h => nomatch h +| n+1, h => nomatch h + +theorem notLtZero (n : Nat) : ¬ n < 0 := +notSuccLeZero n + +theorem predLePred : ∀ {n m : Nat}, n ≤ m → pred n ≤ pred m +| zero, zero, h => rfl +| zero, succ n, h => zeroLe n +| succ n, zero, h => Bool.noConfusion h +| succ n, succ m, h => h + +theorem leOfSuccLeSucc {n m : Nat} : succ n ≤ succ m → n ≤ m := +predLePred + +@[extern "lean_nat_dec_le"] +instance decLe (n m : @& Nat) : Decidable (n ≤ m) := +decEq (ble n m) true + +@[extern "lean_nat_dec_lt"] +instance decLt (n m : @& Nat) : Decidable (n < m) := +Nat.decLe (succ n) m + +protected theorem eqOrLtOfLe : ∀ {n m: Nat}, n ≤ m → n = m ∨ n < m +| zero, zero, h => Or.inl rfl +| zero, succ n, h => Or.inr $ zeroLe n +| succ n, zero, h => Bool.noConfusion h +| succ n, succ m, h => + have n ≤ m from h; + have n = m ∨ n < m from eqOrLtOfLe this; + Or.elim this + (fun h => Or.inl $ congrArg succ h) + (fun h => Or.inr $ succLtSucc h) + +theorem ltSuccOfLe {n m : Nat} : n ≤ m → n < succ m := +succLeSucc + +protected theorem subZero (n : Nat) : n - 0 = n := +rfl + +theorem succSubSuccEqSub (n m : Nat) : succ n - succ m = n - m := +Nat.recOn m + (show succ n - succ zero = n - zero from (Eq.refl (succ n - succ zero))) + (fun m => congrArg pred) + +theorem notSuccLeSelf : ∀ (n : Nat), ¬succ n ≤ n := +fun n => Nat.rec (notSuccLeZero 0) (fun a b c => b (leOfSuccLeSucc c)) n + +protected theorem ltIrrefl (n : Nat) : ¬n < n := +notSuccLeSelf n + +protected theorem leTrans : ∀ {n m k : Nat}, n ≤ m → m ≤ k → n ≤ k +| zero, m, k, h₁, h₂ => zeroLe _ +| succ n, zero, k, h₁, h₂ => Bool.noConfusion h₁ +| succ n, succ m, zero, h₁, h₂ => Bool.noConfusion h₂ +| succ n, succ m, succ k, h₁, h₂ => + have h₁' : n ≤ m from h₁; + have h₂' : m ≤ k from h₂; + have n ≤ k from leTrans h₁' h₂'; + succLeSucc this + +theorem predLe : ∀ (n : Nat), pred n ≤ n +| zero => rfl +| succ n => leSucc _ + +theorem predLt : ∀ {n : Nat}, n ≠ 0 → pred n < n +| zero, h => absurd rfl h +| succ n, h => ltSuccOfLe (Nat.leRefl _) + +theorem subLe (n m : Nat) : n - m ≤ n := +Nat.recOn m (Nat.leRefl (n - 0)) (fun m => Nat.leTrans (predLe (n - m))) + +theorem subLt : ∀ {n m : Nat}, 0 < n → 0 < m → n - m < n +| 0, m, h1, h2 => absurd h1 (Nat.ltIrrefl 0) +| n+1, 0, h1, h2 => absurd h2 (Nat.ltIrrefl 0) +| n+1, m+1, h1, h2 => + Eq.symm (succSubSuccEqSub n m) ▸ + show n - m < succ n from + ltSuccOfLe (subLe n m) + +protected theorem ltOfLtOfLe {n m k : Nat} : n < m → m ≤ k → n < k := +Nat.leTrans + +protected theorem leOfEq {n m : Nat} (p : n = m) : n ≤ m := +p ▸ Nat.leRefl n + +theorem leSuccOfLe {n m : Nat} (h : n ≤ m) : n ≤ succ m := +Nat.leTrans h (leSucc m) + +theorem leOfSuccLe {n m : Nat} (h : succ n ≤ m) : n ≤ m := +Nat.leTrans (leSucc n) h + +protected theorem leOfLt {n m : Nat} (h : n < m) : n ≤ m := +leOfSuccLe h + +def lt.step {n m : Nat} : n < m → n < succ m := leStep + +theorem eqZeroOrPos : ∀ (n : Nat), n = 0 ∨ n > 0 +| 0 => Or.inl rfl +| n+1 => Or.inr (succPos _) + +protected theorem ltTrans {n m k : Nat} (h₁ : n < m) : m < k → n < k := +Nat.leTrans (leStep h₁) + +protected theorem ltOfLeOfLt {n m k : Nat} (h₁ : n ≤ m) : m < k → n < k := +Nat.leTrans (succLeSucc h₁) + +def lt.base (n : Nat) : n < succ n := Nat.leRefl (succ n) + +theorem ltSuccSelf (n : Nat) : n < succ n := lt.base n + +protected theorem leAntisymm : ∀ {n m : Nat}, n ≤ m → m ≤ n → n = m +| zero, zero, h₁, h₂ => rfl +| succ n, zero, h₁, h₂ => Bool.noConfusion h₁ +| zero, succ m, h₁, h₂ => Bool.noConfusion h₂ +| succ n, succ m, h₁, h₂ => + have h₁' : n ≤ m from h₁; + have h₂' : m ≤ n from h₂; + have n = m from leAntisymm h₁' h₂'; + congrArg succ this + +protected theorem ltOrGe : ∀ (n m : Nat), n < m ∨ n ≥ m +| n, 0 => Or.inr (zeroLe n) +| n, m+1 => + match ltOrGe n m with + | Or.inl h => Or.inl (leSuccOfLe h) + | Or.inr h => + match Nat.eqOrLtOfLe h with + | Or.inl h1 => Or.inl (h1 ▸ ltSuccSelf m) + | Or.inr h1 => Or.inr h1 + +protected theorem leTotal (m n : Nat) : m ≤ n ∨ n ≤ m := +Or.elim (Nat.ltOrGe m n) + (fun h => Or.inl (Nat.leOfLt h)) + Or.inr + +protected theorem ltOfLeAndNe {m n : Nat} (h1 : m ≤ n) : m ≠ n → m < n := +resolveRight (Or.swap (Nat.eqOrLtOfLe h1)) + +theorem eqZeroOfLeZero {n : Nat} (h : n ≤ 0) : n = 0 := +Nat.leAntisymm h (zeroLe _) + +theorem ltOfSuccLt {n m : Nat} : succ n < m → n < m := +leOfSuccLe + +theorem ltOfSuccLtSucc {n m : Nat} : succ n < succ m → n < m := +leOfSuccLeSucc + +theorem ltOfSuccLe {n m : Nat} (h : succ n ≤ m) : n < m := +h + +theorem succLeOfLt {n m : Nat} (h : n < m) : succ n ≤ m := +h + +theorem ltOrEqOrLeSucc {m n : Nat} (h : m ≤ succ n) : m ≤ n ∨ m = succ n := +Decidable.byCases + (fun (h' : m = succ n) => Or.inr h') + (fun (h' : m ≠ succ n) => + have m < succ n from Nat.ltOfLeAndNe h h'; + have succ m ≤ succ n from succLeOfLt this; + Or.inl (leOfSuccLeSucc this)) + +theorem leAddRight : ∀ (n k : Nat), n ≤ n + k +| n, 0 => Nat.leRefl n +| n, k+1 => leSuccOfLe (leAddRight n k) + +theorem leAddLeft (n m : Nat): n ≤ m + n := +Nat.addComm n m ▸ leAddRight n m + +theorem le.dest : ∀ {n m : Nat}, n ≤ m → Exists (fun k => n + k = m) +| zero, zero, h => ⟨0, rfl⟩ +| zero, succ n, h => ⟨succ n, show 0 + succ n = succ n from (Nat.addComm 0 (succ n)).symm ▸ rfl⟩ +| succ n, zero, h => Bool.noConfusion h +| succ n, succ m, h => + have n ≤ m from h; + have Exists (fun k => n + k = m) from le.dest this; + match this with + | ⟨k, h⟩ => ⟨k, show succ n + k = succ m from ((succAdd n k).symm ▸ h ▸ rfl)⟩ + +theorem le.intro {n m k : Nat} (h : n + k = m) : n ≤ m := +h ▸ leAddRight n k + +protected theorem notLeOfGt {n m : Nat} (h : n > m) : ¬ n ≤ m := +fun h₁ => Or.elim (Nat.ltOrGe n m) + (fun h₂ => absurd (Nat.ltTrans h h₂) (Nat.ltIrrefl _)) + (fun h₂ => + have Heq : n = m from Nat.leAntisymm h₁ h₂; + absurd (@Eq.subst _ _ _ _ Heq h) (Nat.ltIrrefl m)) + +theorem gtOfNotLe {n m : Nat} (h : ¬ n ≤ m) : n > m := +Or.elim (Nat.ltOrGe m n) + (fun h₁ => h₁) + (fun h₁ => absurd h₁ h) + +protected theorem ltOfLeOfNe {n m : Nat} (h₁ : n ≤ m) (h₂ : n ≠ m) : n < m := +Or.elim (Nat.ltOrGe n m) + (fun h₃ => h₃) + (fun h₃ => absurd (Nat.leAntisymm h₁ h₃) h₂) + +protected theorem addLeAddLeft {n m : Nat} (h : n ≤ m) (k : Nat) : k + n ≤ k + m := +match le.dest h with +| ⟨w, hw⟩ => + have h₁ : k + n + w = k + (n + w) from Nat.addAssoc _ _ _; + have h₂ : k + (n + w) = k + m from congrArg _ hw; + le.intro $ h₁.trans h₂ + +protected theorem addLeAddRight {n m : Nat} (h : n ≤ m) (k : Nat) : n + k ≤ m + k := +have h₁ : n + k = k + n from Nat.addComm _ _; +have h₂ : k + n ≤ k + m from Nat.addLeAddLeft h k; +have h₃ : k + m = m + k from Nat.addComm _ _; +transRelLeft (fun a b => a ≤ b) (transRelRight (fun a b => a ≤ b) h₁ h₂) h₃ + +protected theorem addLtAddLeft {n m : Nat} (h : n < m) (k : Nat) : k + n < k + m := +ltOfSuccLe (addSucc k n ▸ Nat.addLeAddLeft (succLeOfLt h) k) + +protected theorem addLtAddRight {n m : Nat} (h : n < m) (k : Nat) : n + k < m + k := +Nat.addComm k m ▸ Nat.addComm k n ▸ Nat.addLtAddLeft h k + +protected theorem zeroLtOne : 0 < (1:Nat) := +zeroLtSucc 0 + +theorem leOfLtSucc {m n : Nat} : m < succ n → m ≤ n := +leOfSuccLeSucc + +theorem addLeAdd {a b c d : Nat} (h₁ : a ≤ b) (h₂ : c ≤ d) : a + c ≤ b + d := +Nat.leTrans (Nat.addLeAddRight h₁ c) (Nat.addLeAddLeft h₂ b) + +theorem addLtAdd {a b c d : Nat} (h₁ : a < b) (h₂ : c < d) : a + c < b + d := +Nat.ltTrans (Nat.addLtAddRight h₁ c) (Nat.addLtAddLeft h₂ b) + +/- Basic theorems for comparing numerals -/ + +theorem natZeroEqZero : Nat.zero = 0 := +rfl + +protected theorem oneNeZero : 1 ≠ (0 : Nat) := +fun h => Nat.noConfusion h + +protected theorem zeroNeOne : 0 ≠ (1 : Nat) := +fun h => Nat.noConfusion h + +theorem succNeZero (n : Nat) : succ n ≠ 0 := +fun h => Nat.noConfusion h + +protected theorem bit0SuccEq (n : Nat) : bit0 (succ n) = succ (succ (bit0 n)) := +show succ (succ n + n) = succ (succ (n + n)) from +congrArg succ (succAdd n n) + +protected theorem zeroLtBit0 : ∀ {n : Nat}, n ≠ 0 → 0 < bit0 n +| 0, h => absurd rfl h +| succ n, h => + have h₁ : 0 < succ (succ (bit0 n)) from zeroLtSucc _; + have h₂ : succ (succ (bit0 n)) = bit0 (succ n) from (Nat.bit0SuccEq n).symm; + transRelLeft (fun a b => a < b) h₁ h₂ + +protected theorem zeroLtBit1 (n : Nat) : 0 < bit1 n := +zeroLtSucc _ + +protected theorem bit0NeZero : ∀ {n : Nat}, n ≠ 0 → bit0 n ≠ 0 +| 0, h => absurd rfl h +| n+1, h => + suffices (n+1) + (n+1) ≠ 0 from this; + suffices succ ((n+1) + n) ≠ 0 from this; + fun h => Nat.noConfusion h + +protected theorem bit1NeZero (n : Nat) : bit1 n ≠ 0 := +show succ (n + n) ≠ 0 from +fun h => Nat.noConfusion h + +protected theorem bit1EqSuccBit0 (n : Nat) : bit1 n = succ (bit0 n) := +rfl + +protected theorem bit1SuccEq (n : Nat) : bit1 (succ n) = succ (succ (bit1 n)) := +Eq.trans (Nat.bit1EqSuccBit0 (succ n)) (congrArg succ (Nat.bit0SuccEq n)) + +protected theorem bit1NeOne : ∀ {n : Nat}, n ≠ 0 → bit1 n ≠ 1 +| 0, h, h1 => absurd rfl h +| n+1, h, h1 => Nat.noConfusion h1 (fun h2 => absurd h2 (succNeZero _)) + +protected theorem bit0NeOne : ∀ (n : Nat), bit0 n ≠ 1 +| 0, h => absurd h (Ne.symm Nat.oneNeZero) +| n+1, h => + have h1 : succ (succ (n + n)) = 1 from succAdd n n ▸ h; + Nat.noConfusion h1 + (fun h2 => absurd h2 (succNeZero (n + n))) + +protected theorem addSelfNeOne : ∀ (n : Nat), n + n ≠ 1 +| 0, h => Nat.noConfusion h +| n+1, h => + have h1 : succ (succ (n + n)) = 1 from succAdd n n ▸ h; + Nat.noConfusion h1 (fun h2 => absurd h2 (Nat.succNeZero (n + n))) + +protected theorem bit1NeBit0 : ∀ (n m : Nat), bit1 n ≠ bit0 m +| 0, m, h => absurd h (Ne.symm (Nat.addSelfNeOne m)) +| n+1, 0, h => + have h1 : succ (bit0 (succ n)) = 0 from h; + absurd h1 (Nat.succNeZero _) +| n+1, m+1, h => + have h1 : succ (succ (bit1 n)) = succ (succ (bit0 m)) from + Nat.bit0SuccEq m ▸ Nat.bit1SuccEq n ▸ h; + have h2 : bit1 n = bit0 m from + Nat.noConfusion h1 (fun h2' => Nat.noConfusion h2' (fun h2'' => h2'')); + absurd h2 (bit1NeBit0 n m) + +protected theorem bit0NeBit1 : ∀ (n m : Nat), bit0 n ≠ bit1 m := +fun n m => Ne.symm (Nat.bit1NeBit0 m n) + +protected theorem bit0Inj : ∀ {n m : Nat}, bit0 n = bit0 m → n = m +| 0, 0, h => rfl +| 0, m+1, h => absurd h.symm (succNeZero _) +| n+1, 0, h => absurd h (succNeZero _) +| n+1, m+1, h => + have (n+1) + n = (m+1) + m from Nat.noConfusion h id; + have n + (n+1) = m + (m+1) from Nat.addComm (m+1) m ▸ Nat.addComm (n+1) n ▸ this; + have succ (n + n) = succ (m + m) from this; + have n + n = m + m from Nat.noConfusion this id; + have n = m from bit0Inj this; + congrArg (fun a => a + 1) this + +protected theorem bit1Inj : ∀ {n m : Nat}, bit1 n = bit1 m → n = m := +fun n m h => +have succ (bit0 n) = succ (bit0 m) from Nat.bit1EqSuccBit0 n ▸ Nat.bit1EqSuccBit0 m ▸ h; +have bit0 n = bit0 m from Nat.noConfusion this id; +Nat.bit0Inj this + +protected theorem bit0Ne {n m : Nat} : n ≠ m → bit0 n ≠ bit0 m := +fun h₁ h₂ => absurd (Nat.bit0Inj h₂) h₁ + +protected theorem bit1Ne {n m : Nat} : n ≠ m → bit1 n ≠ bit1 m := +fun h₁ h₂ => absurd (Nat.bit1Inj h₂) h₁ + +protected theorem zeroNeBit0 {n : Nat} : n ≠ 0 → 0 ≠ bit0 n := +fun h => Ne.symm (Nat.bit0NeZero h) + +protected theorem zeroNeBit1 (n : Nat) : 0 ≠ bit1 n := +Ne.symm (Nat.bit1NeZero n) + +protected theorem oneNeBit0 (n : Nat) : 1 ≠ bit0 n := +Ne.symm (Nat.bit0NeOne n) + +protected theorem oneNeBit1 {n : Nat} : n ≠ 0 → 1 ≠ bit1 n := +fun h => Ne.symm (Nat.bit1NeOne h) + +protected theorem oneLtBit1 : ∀ {n : Nat}, n ≠ 0 → 1 < bit1 n +| 0, h => absurd rfl h +| succ n, h => + suffices succ 0 < succ (succ (bit1 n)) from (Nat.bit1SuccEq n).symm ▸ this; + succLtSucc (zeroLtSucc _) + +protected theorem oneLtBit0 : ∀ {n : Nat}, n ≠ 0 → 1 < bit0 n +| 0, h => absurd rfl h +| succ n, h => + suffices succ 0 < succ (succ (bit0 n)) from (Nat.bit0SuccEq n).symm ▸ this; + succLtSucc (zeroLtSucc _) + +protected theorem bit0Lt {n m : Nat} (h : n < m) : bit0 n < bit0 m := +Nat.addLtAdd h h + +protected theorem bit1Lt {n m : Nat} (h : n < m) : bit1 n < bit1 m := +succLtSucc (Nat.addLtAdd h h) + +protected theorem bit0LtBit1 {n m : Nat} (h : n ≤ m) : bit0 n < bit1 m := +ltSuccOfLe (Nat.addLeAdd h h) + +protected theorem bit1LtBit0 : ∀ {n m : Nat}, n < m → bit1 n < bit0 m +| n, 0, h => absurd h (notLtZero _) +| n, succ m, h => + have n ≤ m from leOfLtSucc h; + have succ (n + n) ≤ succ (m + m) from succLeSucc (addLeAdd this this); + have succ (n + n) ≤ succ m + m from (succAdd m m).symm ▸ this; + show succ (n + n) < succ (succ m + m) from ltSuccOfLe this + +protected theorem oneLeBit1 (n : Nat) : 1 ≤ bit1 n := +show 1 ≤ succ (bit0 n) from +succLeSucc (zeroLe (bit0 n)) + +protected theorem oneLeBit0 : ∀ (n : Nat), n ≠ 0 → 1 ≤ bit0 n +| 0, h => absurd rfl h +| n+1, h => + suffices 1 ≤ succ (succ (bit0 n)) from Eq.symm (Nat.bit0SuccEq n) ▸ this; + succLeSucc (zeroLe (succ (bit0 n))) + +/- mul + order -/ + +theorem mulLeMulLeft {n m : Nat} (k : Nat) (h : n ≤ m) : k * n ≤ k * m := +match le.dest h with +| ⟨l, hl⟩ => + have k * n + k * l = k * m from Nat.leftDistrib k n l ▸ hl.symm ▸ rfl; + le.intro this + +theorem mulLeMulRight {n m : Nat} (k : Nat) (h : n ≤ m) : n * k ≤ m * k := +Nat.mulComm k m ▸ Nat.mulComm k n ▸ mulLeMulLeft k h + +protected theorem mulLeMul {n₁ m₁ n₂ m₂ : Nat} (h₁ : n₁ ≤ n₂) (h₂ : m₁ ≤ m₂) : n₁ * m₁ ≤ n₂ * m₂ := +Nat.leTrans (mulLeMulRight _ h₁) (mulLeMulLeft _ h₂) + +protected theorem mulLtMulOfPosLeft {n m k : Nat} (h : n < m) (hk : k > 0) : k * n < k * m := +Nat.ltOfLtOfLe (Nat.addLtAddLeft hk _) (Nat.mulSucc k n ▸ Nat.mulLeMulLeft k (succLeOfLt h)) + +protected theorem mulLtMulOfPosRight {n m k : Nat} (h : n < m) (hk : k > 0) : n * k < m * k := +Nat.mulComm k m ▸ Nat.mulComm k n ▸ Nat.mulLtMulOfPosLeft h hk + +protected theorem mulPos {n m : Nat} (ha : n > 0) (hb : m > 0) : n * m > 0 := +have h : 0 * m < n * m from Nat.mulLtMulOfPosRight ha hb; +Nat.zeroMul m ▸ h + +/- power -/ + +theorem powSucc (n m : Nat) : n^(succ m) = n^m * n := +rfl + +theorem powZero (n : Nat) : n^0 = 1 := rfl + +theorem powLePowOfLeLeft {n m : Nat} (h : n ≤ m) : ∀ (i : Nat), n^i ≤ m^i +| 0 => Nat.leRefl _ +| succ i => Nat.mulLeMul (powLePowOfLeLeft i) h + +theorem powLePowOfLeRight {n : Nat} (hx : n > 0) {i : Nat} : ∀ {j}, i ≤ j → n^i ≤ n^j +| 0, h => + have i = 0 from eqZeroOfLeZero h; + this.symm ▸ Nat.leRefl _ +| succ j, h => + Or.elim (ltOrEqOrLeSucc h) + (fun h => show n^i ≤ n^j * n from + suffices n^i * 1 ≤ n^j * n from Nat.mulOne (n^i) ▸ this; + Nat.mulLeMul (powLePowOfLeRight h) hx) + (fun h => h.symm ▸ Nat.leRefl _) + +theorem posPowOfPos {n : Nat} (m : Nat) (h : 0 < n) : 0 < n^m := +powLePowOfLeRight h (Nat.zeroLe _) + +/- Max -/ + +protected def max (n m : Nat) : Nat := +if n ≤ m then m else n + +end Nat + +namespace Prod + +@[inline] def foldI {α : Type u} (f : Nat → α → α) (i : Nat × Nat) (a : α) : α := +Nat.foldAux f i.2 (i.2 - i.1) a + +@[inline] def anyI (f : Nat → Bool) (i : Nat × Nat) : Bool := +Nat.anyAux f i.2 (i.2 - i.1) + +@[inline] def allI (f : Nat → Bool) (i : Nat × Nat) : Bool := +!Nat.anyAux (fun a => !f a) i.2 (i.2 - i.1) + +end Prod diff --git a/stage0/src/Init/Data/Nat/Bitwise.lean b/stage0/src/Init/Data/Nat/Bitwise.lean new file mode 100644 index 0000000000..52a89b7a89 --- /dev/null +++ b/stage0/src/Init/Data/Nat/Bitwise.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Nat.Basic +import Init.Data.Nat.Div +import Init.Coe + +namespace Nat + +partial def bitwise (f : Bool → Bool → Bool) : Nat → Nat → Nat | n, m => +if n = 0 then (if f false true then m else 0) +else if m = 0 then (if f true false then n else 0) +else + let n' := n / 2; + let m' := m / 2; + let b₁ := n % 2 = 1; + let b₂ := m % 2 = 1; + let r := bitwise n' m'; + if f b₁ b₂ then bit1 r else bit0 r + +@[extern "lean_nat_land"] +def land : Nat → Nat → Nat := bitwise and +@[extern "lean_nat_lor"] +def lor : Nat → Nat → Nat := bitwise or + +end Nat diff --git a/stage0/src/Init/Data/Nat/Control.lean b/stage0/src/Init/Data/Nat/Control.lean new file mode 100644 index 0000000000..41f9b28104 --- /dev/null +++ b/stage0/src/Init/Data/Nat/Control.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Control.Monad +import Init.Control.Alternative +import Init.Data.Nat.Basic + +namespace Nat +universes u v + +@[specialize] def forMAux {m} [Monad m] (f : Nat → m Unit) (n : Nat) : Nat → m Unit +| 0 => pure () +| i+1 => do f (n-i-1); forMAux i + +@[inline] def forM {m} [Monad m] (n : Nat) (f : Nat → m Unit) : m Unit := +forMAux f n n + +@[specialize] def forRevMAux {m} [Monad m] (f : Nat → m Unit) : Nat → m Unit +| 0 => pure () +| i+1 => do f i; forRevMAux i + +@[inline] def forRevM {m} [Monad m] (n : Nat) (f : Nat → m Unit) : m Unit := +forRevMAux f n + +@[specialize] def foldMAux {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) (n : Nat) : Nat → α → m α +| 0, a => pure a +| i+1, a => f (n-i-1) a >>= foldMAux i + +@[inline] def foldM {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) (a : α) (n : Nat) : m α := +foldMAux f n n a + +@[specialize] def foldRevMAux {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) : Nat → α → m α +| 0, a => pure a +| i+1, a => f i a >>= foldRevMAux i + +@[inline] def foldRevM {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) (a : α) (n : Nat) : m α := +foldRevMAux f n a + +@[specialize] def allMAux {m} [Monad m] (p : Nat → m Bool) (n : Nat) : Nat → m Bool +| 0 => pure true +| i+1 => condM (p (n-i-1)) (allMAux i) (pure false) + +@[inline] def allM {m} [Monad m] (n : Nat) (p : Nat → m Bool) : m Bool := +allMAux p n n + +@[specialize] def anyMAux {m} [Monad m] (p : Nat → m Bool) (n : Nat) : Nat → m Bool +| 0 => pure false +| i+1 => condM (p (n-i-1)) (pure true) (anyMAux i) + +@[inline] def anyM {m} [Monad m] (n : Nat) (p : Nat → m Bool) : m Bool := +anyMAux p n n + +end Nat diff --git a/stage0/src/Init/Data/Nat/Div.lean b/stage0/src/Init/Data/Nat/Div.lean new file mode 100644 index 0000000000..dea5a1cc50 --- /dev/null +++ b/stage0/src/Init/Data/Nat/Div.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.WF +import Init.Data.Nat.Basic +namespace Nat + +private def divRecLemma {x y : Nat} : 0 < y ∧ y ≤ x → x - y < x := +fun h => And.rec (fun ypos ylex => subLt (Nat.ltOfLtOfLe ypos ylex) ypos) h + +private def div.F (x : Nat) (f : ∀ x₁, x₁ < x → Nat → Nat) (y : Nat) : Nat := +if h : 0 < y ∧ y ≤ x then f (x - y) (divRecLemma h) y + 1 else zero + +@[extern "lean_nat_div"] +protected def div (a b : @& Nat) : Nat := +WellFounded.fix ltWf div.F a b + +instance : HasDiv Nat := +⟨Nat.div⟩ + +private theorem divDefAux (x y : Nat) : x / y = if h : 0 < y ∧ y ≤ x then (x - y) / y + 1 else 0 := +congrFun (WellFounded.fixEq ltWf div.F x) y + +theorem divDef (x y : Nat) : x / y = if 0 < y ∧ y ≤ x then (x - y) / y + 1 else 0 := +difEqIf (0 < y ∧ y ≤ x) ((x - y) / y + 1) 0 ▸ divDefAux x y + +private theorem div.induction.F.{u} + (C : Nat → Nat → Sort u) + (h₁ : ∀ x y, 0 < y ∧ y ≤ x → C (x - y) y → C x y) + (h₂ : ∀ x y, ¬(0 < y ∧ y ≤ x) → C x y) + (x : Nat) (f : ∀ (x₁ : Nat), x₁ < x → ∀ (y : Nat), C x₁ y) (y : Nat) : C x y := +if h : 0 < y ∧ y ≤ x then h₁ x y h (f (x - y) (divRecLemma h) y) else h₂ x y h + +@[elabAsEliminator] +theorem div.inductionOn.{u} + {C : Nat → Nat → Sort u} + (x y : Nat) + (h₁ : ∀ x y, 0 < y ∧ y ≤ x → C (x - y) y → C x y) + (h₂ : ∀ x y, ¬(0 < y ∧ y ≤ x) → C x y) + : C x y := +WellFounded.fix Nat.ltWf (div.induction.F C h₁ h₂) x y + +private def mod.F (x : Nat) (f : ∀ x₁, x₁ < x → Nat → Nat) (y : Nat) : Nat := +if h : 0 < y ∧ y ≤ x then f (x - y) (divRecLemma h) y else x + +@[extern "lean_nat_mod"] +protected def mod (a b : @& Nat) : Nat := +WellFounded.fix ltWf mod.F a b + +instance : HasMod Nat := +⟨Nat.mod⟩ + +private theorem modDefAux (x y : Nat) : x % y = if h : 0 < y ∧ y ≤ x then (x - y) % y else x := +congrFun (WellFounded.fixEq ltWf mod.F x) y + +theorem modDef (x y : Nat) : x % y = if 0 < y ∧ y ≤ x then (x - y) % y else x := +difEqIf (0 < y ∧ y ≤ x) ((x - y) % y) x ▸ modDefAux x y + +@[elabAsEliminator] +theorem mod.inductionOn.{u} + {C : Nat → Nat → Sort u} + (x y : Nat) + (h₁ : ∀ x y, 0 < y ∧ y ≤ x → C (x - y) y → C x y) + (h₂ : ∀ x y, ¬(0 < y ∧ y ≤ x) → C x y) + : C x y := +div.inductionOn x y h₁ h₂ + +theorem modZero (a : Nat) : a % 0 = a := +suffices (if 0 < 0 ∧ 0 ≤ a then (a - 0) % 0 else a) = a from (modDef a 0).symm ▸ this; +have h : ¬ (0 < 0 ∧ 0 ≤ a) from fun ⟨h₁, _⟩ => absurd h₁ (Nat.ltIrrefl _); +ifNeg h + +theorem modEqOfLt {a b : Nat} (h : a < b) : a % b = a := +suffices (if 0 < b ∧ b ≤ a then (a - b) % b else a) = a from (modDef a b).symm ▸ this; +have h' : ¬(0 < b ∧ b ≤ a) from fun ⟨_, h₁⟩ => absurd h₁ (Nat.notLeOfGt h); +ifNeg h' + +theorem modEqSubMod {a b : Nat} (h : a ≥ b) : a % b = (a - b) % b := +Or.elim (eqZeroOrPos b) + (fun h₁ => h₁.symm ▸ (Nat.subZero a).symm ▸ rfl) + (fun h₁ => (modDef a b).symm ▸ ifPos ⟨h₁, h⟩) + +theorem modLt (x : Nat) {y : Nat} : y > 0 → x % y < y := +mod.inductionOn x y + (fun (x y) ⟨_, h₁⟩ (h₂ h₃) => + have ih : (x - y) % y < y from h₂ h₃; + have Heq : x % y = (x - y) % y from modEqSubMod h₁; + Heq.symm ▸ ih) + (fun x y h₁ h₂ => + have h₁ : ¬ 0 < y ∨ ¬ y ≤ x from Iff.mp (Decidable.notAndIffOrNot _ _) h₁; + Or.elim h₁ + (fun h₁ => absurd h₂ h₁) + (fun h₁ => + have hgt : y > x from gtOfNotLe h₁; + have Heq : x % y = x from modEqOfLt hgt; + Heq.symm ▸ hgt)) + +theorem modLe (x y : Nat) : x % y ≤ x := +Or.elim (Nat.ltOrGe x y) + (fun (h₁ : x < y) => (modEqOfLt h₁).symm ▸ Nat.leRefl _) + (fun (h₁ : x ≥ y) => Or.elim (eqZeroOrPos y) + (fun (h₂ : y = 0) => h₂.symm ▸ (Nat.modZero x).symm ▸ Nat.leRefl _) + (fun (h₂ : y > 0) => Nat.leTrans (Nat.leOfLt (Nat.modLt _ h₂)) h₁)) + +end Nat diff --git a/stage0/src/Init/Data/Option.lean b/stage0/src/Init/Data/Option.lean new file mode 100644 index 0000000000..0a35feacc2 --- /dev/null +++ b/stage0/src/Init/Data/Option.lean @@ -0,0 +1,9 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Option.Basic +import Init.Data.Option.BasicAux +import Init.Data.Option.Instances diff --git a/stage0/src/Init/Data/Option/Basic.lean b/stage0/src/Init/Data/Option/Basic.lean new file mode 100644 index 0000000000..64f6b9aad6 --- /dev/null +++ b/stage0/src/Init/Data/Option/Basic.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Core +import Init.Control.Monad +import Init.Control.Alternative +import Init.Coe +open Decidable + +universes u v + +namespace Option + +def toMonad {m : Type → Type} [Monad m] [Alternative m] {A} : Option A → m A +| none => failure +| some a => pure a + +@[macroInline] def getD {α : Type u} : Option α → α → α +| some x, _ => x +| none, e => e + +@[inline] def toBool {α : Type u} : Option α → Bool +| some _ => true +| none => false + +@[inline] def isSome {α : Type u} : Option α → Bool +| some _ => true +| none => false + +@[inline] def isNone {α : Type u} : Option α → Bool +| some _ => false +| none => true + +@[inline] protected def bind {α : Type u} {β : Type v} : Option α → (α → Option β) → Option β +| none, b => none +| some a, b => b a + +@[inline] protected def map {α β} (f : α → β) (o : Option α) : Option β := +Option.bind o (some ∘ f) + +theorem mapId {α} : (Option.map id : Option α → Option α) = id := +funext (fun o => match o with | none => rfl | some x => rfl) + +instance : Monad Option := +{pure := @some, bind := @Option.bind, map := @Option.map} + +@[macroInline] protected def orelse {α : Type u} : Option α → Option α → Option α +| some a, _ => some a +| none, b => b + +/- Remark: when using the polymorphic notation `a <|> b` is not a `[macroInline]`. + Thus, `a <|> b` will make `Option.orelse` to behave like it was marked as `[inline]`. -/ +instance : Alternative Option := +{ failure := @none, + orelse := @Option.orelse, + ..Option.Monad } + +@[inline] protected def lt {α : Type u} (r : α → α → Prop) : Option α → Option α → Prop +| none, some x => True +| some x, some y => r x y +| _, _ => False + +instance decidableRelLt {α : Type u} (r : α → α → Prop) [s : DecidableRel r] : DecidableRel (Option.lt r) +| none, some y => isTrue trivial +| some x, some y => s x y +| some x, none => isFalse notFalse +| none, none => isFalse notFalse + +end Option + +instance (α : Type u) : Inhabited (Option α) := +⟨none⟩ + +instance {α : Type u} [DecidableEq α] : DecidableEq (Option α) := +{decEq := fun a b => match a, b with + | none, none => isTrue rfl + | none, (some v₂) => isFalse (fun h => Option.noConfusion h) + | (some v₁), none => isFalse (fun h => Option.noConfusion h) + | (some v₁), (some v₂) => + match decEq v₁ v₂ with + | (isTrue e) => isTrue (congrArg (@some α) e) + | (isFalse n) => isFalse (fun h => Option.noConfusion h (fun e => absurd e n))} + +instance {α : Type u} [HasBeq α] : HasBeq (Option α) := +⟨fun a b => match a, b with + | none, none => true + | none, (some v₂) => false + | (some v₁), none => false + | (some v₁), (some v₂) => v₁ == v₂⟩ + +instance {α : Type u} [HasLess α] : HasLess (Option α) := ⟨Option.lt HasLess.Less⟩ diff --git a/stage0/src/Init/Data/Option/BasicAux.lean b/stage0/src/Init/Data/Option/BasicAux.lean new file mode 100644 index 0000000000..2a74f19c6a --- /dev/null +++ b/stage0/src/Init/Data/Option/BasicAux.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Option.Basic +import Init.Util + +universes u + +namespace Option + +@[inline] def get! {α : Type u} [Inhabited α] : Option α → α +| some x => x +| none => panic! "value is none" + +end Option diff --git a/stage0/src/Init/Data/Option/Instances.lean b/stage0/src/Init/Data/Option/Instances.lean new file mode 100644 index 0000000000..f18c711701 --- /dev/null +++ b/stage0/src/Init/Data/Option/Instances.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Option.Basic + +universes u v + +theorem Option.eqOfEqSome {α : Type u} : ∀ {x y : Option α}, (∀z, x = some z ↔ y = some z) → x = y +| none, none, h => rfl +| none, some z, h => Option.noConfusion ((h z).2 rfl) +| some z, none, h => Option.noConfusion ((h z).1 rfl) +| some z, some w, h => Option.noConfusion ((h w).2 rfl) (congrArg some) + +theorem Option.eqNoneOfIsNone {α : Type u} : ∀ {o : Option α}, o.isNone → o = none +| none, h => rfl diff --git a/stage0/src/Init/Data/PersistentArray.lean b/stage0/src/Init/Data/PersistentArray.lean new file mode 100644 index 0000000000..a30feb7f28 --- /dev/null +++ b/stage0/src/Init/Data/PersistentArray.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.PersistentArray.Basic diff --git a/stage0/src/Init/Data/PersistentArray/Basic.lean b/stage0/src/Init/Data/PersistentArray/Basic.lean new file mode 100644 index 0000000000..cab966e963 --- /dev/null +++ b/stage0/src/Init/Data/PersistentArray/Basic.lean @@ -0,0 +1,330 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Conditional +import Init.Data.Array +universes u v w + +inductive PersistentArrayNode (α : Type u) +| node (cs : Array PersistentArrayNode) : PersistentArrayNode +| leaf (vs : Array α) : PersistentArrayNode + +namespace PersistentArrayNode + +instance {α : Type u} : Inhabited (PersistentArrayNode α) := ⟨leaf #[]⟩ + +def isNode {α} : PersistentArrayNode α → Bool +| node _ => true +| leaf _ => false + +end PersistentArrayNode + +abbrev PersistentArray.initShift : USize := 5 +abbrev PersistentArray.branching : USize := USize.ofNat (2 ^ PersistentArray.initShift.toNat) + +structure PersistentArray (α : Type u) := +/- Recall that we run out of memory if we have more than `usizeSz/8` elements. + So, we can stop adding elements at `root` after `size > usizeSz`, and + keep growing the `tail`. This modification allow us to use `USize` instead + of `Nat` when traversing `root`. -/ +(root : PersistentArrayNode α := PersistentArrayNode.node (Array.mkEmpty PersistentArray.branching.toNat)) +(tail : Array α := Array.mkEmpty PersistentArray.branching.toNat) +(size : Nat := 0) +(shift : USize := PersistentArray.initShift) +(tailOff : Nat := 0) + +abbrev PArray (α : Type u) := PersistentArray α + +namespace PersistentArray +/- TODO: use proofs for showing that array accesses are not out of bounds. + We can do it after we reimplement the tactic framework. -/ +variables {α : Type u} +open PersistentArrayNode + +def empty : PersistentArray α := +{} + +def isEmpty (a : PersistentArray α) : Bool := +a.size == 0 + +instance : Inhabited (PersistentArray α) := ⟨{}⟩ + +def mkEmptyArray : Array α := Array.mkEmpty branching.toNat + +abbrev mul2Shift (i : USize) (shift : USize) : USize := i.shiftLeft shift +abbrev div2Shift (i : USize) (shift : USize) : USize := i.shiftRight shift +abbrev mod2Shift (i : USize) (shift : USize) : USize := USize.land i ((USize.shiftLeft 1 shift) - 1) + +partial def getAux [Inhabited α] : PersistentArrayNode α → USize → USize → α +| node cs, i, shift => getAux (cs.get! (div2Shift i shift).toNat) (mod2Shift i shift) (shift - initShift) +| leaf cs, i, _ => cs.get! i.toNat + +def get! [Inhabited α] (t : PersistentArray α) (i : Nat) : α := +if i >= t.tailOff then + t.tail.get! (i - t.tailOff) +else + getAux t.root (USize.ofNat i) t.shift + +partial def setAux : PersistentArrayNode α → USize → USize → α → PersistentArrayNode α +| node cs, i, shift, a => + let j := div2Shift i shift; + let i := mod2Shift i shift; + let shift := shift - initShift; + node $ cs.modify j.toNat $ fun c => setAux c i shift a +| leaf cs, i, _, a => leaf (cs.set! i.toNat a) + +def set (t : PersistentArray α) (i : Nat) (a : α) : PersistentArray α := +if i >= t.tailOff then + { tail := t.tail.set! (i - t.tailOff) a, .. t } +else + { root := setAux t.root (USize.ofNat i) t.shift a, .. t } + +@[specialize] partial def modifyAux [Inhabited α] (f : α → α) : PersistentArrayNode α → USize → USize → PersistentArrayNode α +| node cs, i, shift => + let j := div2Shift i shift; + let i := mod2Shift i shift; + let shift := shift - initShift; + node $ cs.modify j.toNat $ fun c => modifyAux c i shift +| leaf cs, i, _ => leaf (cs.modify i.toNat f) + +@[specialize] def modify [Inhabited α] (t : PersistentArray α) (i : Nat) (f : α → α) : PersistentArray α := +if i >= t.tailOff then + { tail := t.tail.modify (i - t.tailOff) f, .. t } +else + { root := modifyAux f t.root (USize.ofNat i) t.shift, .. t } + +partial def mkNewPath : USize → Array α → PersistentArrayNode α +| shift, a => + if shift == 0 then + leaf a + else + node (mkEmptyArray.push (mkNewPath (shift - initShift) a)) + +partial def insertNewLeaf : PersistentArrayNode α → USize → USize → Array α → PersistentArrayNode α +| node cs, i, shift, a => + if i < branching then + node (cs.push (leaf a)) + else + let j := div2Shift i shift; + let i := mod2Shift i shift; + let shift := shift - initShift; + if j.toNat < cs.size then + node $ cs.modify j.toNat $ fun c => insertNewLeaf c i shift a + else + node $ cs.push $ mkNewPath shift a +| n, _, _, _ => n -- unreachable + +def mkNewTail (t : PersistentArray α) : PersistentArray α := +if t.size <= (mul2Shift 1 (t.shift + initShift)).toNat then + { tail := mkEmptyArray, root := insertNewLeaf t.root (USize.ofNat (t.size - 1)) t.shift t.tail, + tailOff := t.size, + .. t } +else + { tail := #[], + root := let n := mkEmptyArray.push t.root; + node (n.push (mkNewPath t.shift t.tail)), + shift := t.shift + initShift, + tailOff := t.size, + .. t } + +def tooBig : Nat := usizeSz / 8 + +def push (t : PersistentArray α) (a : α) : PersistentArray α := +let r := { tail := t.tail.push a, size := t.size + 1, .. t }; +if r.tail.size < branching.toNat || t.size >= tooBig then + r +else + mkNewTail r + +private def emptyArray {α : Type u} : Array (PersistentArrayNode α) := +Array.mkEmpty PersistentArray.branching.toNat + +partial def popLeaf : PersistentArrayNode α → Option (Array α) × Array (PersistentArrayNode α) +| n@(node cs) => + if h : cs.size ≠ 0 then + let idx : Fin cs.size := ⟨cs.size - 1, Nat.predLt h⟩; + let last := cs.get idx; + let cs := cs.set idx (arbitrary _); + match popLeaf last with + | (none, _) => (none, emptyArray) + | (some l, newLast) => + if newLast.size == 0 then + let cs := cs.pop; + if cs.isEmpty then (some l, emptyArray) else (some l, cs) + else + (some l, cs.set idx (node newLast)) + else + (none, emptyArray) +| leaf vs => (some vs, emptyArray) + +def pop (t : PersistentArray α) : PersistentArray α := +if t.tail.size > 0 then + { tail := t.tail.pop, size := t.size - 1, .. t } +else + match popLeaf t.root with + | (none, _) => t + | (some last, newRoots) => + let last := last.pop; + let newSize := t.size - 1; + let newTailOff := newSize - last.size; + if newRoots.size == 1 && (newRoots.get! 0).isNode then + { root := newRoots.get! 0, + shift := t.shift - initShift, + size := newSize, + tail := last, + tailOff := newTailOff } + else + { root := node newRoots, + size := newSize, + tail := last, + tailOff := newTailOff, + .. t } + +section +variables {m : Type v → Type w} [Monad m] +variable {β : Type v} + +@[specialize] partial def foldlMAux (f : β → α → m β) : PersistentArrayNode α → β → m β +| node cs, b => cs.foldlM (fun b c => foldlMAux c b) b +| leaf vs, b => vs.foldlM f b + +@[specialize] def foldlM (t : PersistentArray α) (f : β → α → m β) (b : β) : m β := +do b ← foldlMAux f t.root b; t.tail.foldlM f b + +@[specialize] partial def findMAux (f : α → m (Option β)) : PersistentArrayNode α → m (Option β) +| node cs => cs.findM (fun c => findMAux c) +| leaf vs => vs.findM f + +@[specialize] def findM (t : PersistentArray α) (f : α → m (Option β)) : m (Option β) := +do b ← findMAux f t.root; + match b with + | none => t.tail.findM f + | some b => pure (some b) + +@[specialize] partial def findRevMAux (f : α → m (Option β)) : PersistentArrayNode α → m (Option β) +| node cs => cs.findRevM (fun c => findRevMAux c) +| leaf vs => vs.findRevM f + +@[specialize] def findRevM (t : PersistentArray α) (f : α → m (Option β)) : m (Option β) := +do b ← t.tail.findRevM f; + match b with + | none => findRevMAux f t.root + | some b => pure (some b) + +partial def foldlFromMAux (f : β → α → m β) : PersistentArrayNode α → USize → USize → β → m β +| node cs, i, shift, b => do + let j := (div2Shift i shift).toNat; + b ← foldlFromMAux (cs.get! j) (mod2Shift i shift) (shift - initShift) b; + cs.foldlFromM (fun b c => foldlMAux f c b) b (j+1) +| leaf vs, i, _, b => vs.foldlFromM f b i.toNat + +def foldlFromM (t : PersistentArray α) (f : β → α → m β) (b : β) (ini : Nat) : m β := +if ini >= t.tailOff then + t.tail.foldlFromM f b (ini - t.tailOff) +else do + b ← foldlFromMAux f t.root (USize.ofNat ini) t.shift b; + t.tail.foldlM f b + +@[specialize] partial def forMAux (f : α → m β) : PersistentArrayNode α → m PUnit +| node cs => cs.forM (fun c => forMAux c) +| leaf vs => vs.forM f + +@[specialize] def forM (t : PersistentArray α) (f : α → m β) : m PUnit := +forMAux f t.root *> t.tail.forM f + +end + +@[inline] def foldl {β} (t : PersistentArray α) (f : β → α → β) (b : β) : β := +Id.run (t.foldlM f b) + +@[inline] def find {β} (t : PersistentArray α) (f : α → (Option β)) : Option β := +Id.run (t.findM f) + +@[inline] def findRev {β} (t : PersistentArray α) (f : α → (Option β)) : Option β := +Id.run (t.findRevM f) + +@[inline] def foldlFrom {β} (t : PersistentArray α) (f : β → α → β) (b : β) (ini : Nat) : β := +Id.run (t.foldlFromM f b ini) + +def toList (t : PersistentArray α) : List α := +(t.foldl (fun xs x => x :: xs) []).reverse + +section +variables {m : Type → Type w} [Monad m] +@[specialize] partial def anyMAux (p : α → m Bool) : PersistentArrayNode α → m Bool +| node cs => cs.anyM (fun c => anyMAux c) +| leaf vs => vs.anyM p + +@[specialize] def anyM (t : PersistentArray α) (p : α → m Bool) : m Bool := +anyMAux p t.root <||> t.tail.anyM p + +@[inline] def allM (a : PersistentArray α) (p : α → m Bool) : m Bool := +do b ← anyM a (fun v => do b ← p v; pure (not b)); pure (not b) + +end + +@[inline] def any (a : PersistentArray α) (p : α → Bool) : Bool := +Id.run $ anyM a p + +@[inline] def all (a : PersistentArray α) (p : α → Bool) : Bool := +!any a (fun v => !p v) + +section +variables {m : Type u → Type v} [Monad m] +variable {β : Type u} + +@[specialize] partial def mapMAux (f : α → m β) : PersistentArrayNode α → m (PersistentArrayNode β) +| node cs => node <$> cs.mapM (fun c => mapMAux c) +| leaf vs => leaf <$> vs.mapM f + +@[specialize] def mapM (f : α → m β) (t : PersistentArray α) : m (PersistentArray β) := +do root ← mapMAux f t.root; + tail ← t.tail.mapM f; + pure { tail := tail, root := root, .. t } + +end + +@[inline] def map {β} (f : α → β) (t : PersistentArray α) : PersistentArray β := +Id.run (t.mapM f) + +structure Stats := +(numNodes : Nat) (depth : Nat) (tailSize : Nat) + +partial def collectStats : PersistentArrayNode α → Stats → Nat → Stats +| node cs, s, d => + cs.foldl (fun s c => collectStats c s (d+1)) + { numNodes := s.numNodes + 1, + depth := Nat.max d s.depth, .. s } +| leaf vs, s, d => { numNodes := s.numNodes + 1, depth := Nat.max d s.depth, .. s } + +def stats (r : PersistentArray α) : Stats := +collectStats r.root { numNodes := 0, depth := 0, tailSize := r.tail.size } 0 + +def Stats.toString (s : Stats) : String := +"{nodes := " ++ toString s.numNodes ++ ", depth := " ++ toString s.depth ++ ", tail size := " ++ toString s.tailSize ++ "}" + +instance : HasToString Stats := ⟨Stats.toString⟩ + +end PersistentArray + +def List.toPersistentArrayAux {α : Type u} : List α → PersistentArray α → PersistentArray α +| [], t => t +| x::xs, t => List.toPersistentArrayAux xs (t.push x) + +def List.toPersistentArray {α : Type u} (xs : List α) : PersistentArray α := +xs.toPersistentArrayAux {} + +def Array.toPersistentArray {α : Type u} (xs : Array α) : PersistentArray α := +xs.foldl (fun p x => p.push x) PersistentArray.empty + +@[inline] def Array.toPArray {α : Type u} (xs : Array α) : PersistentArray α := +xs.toPersistentArray + +def mkPersistentArray {α : Type u} (n : Nat) (v : α) : PArray α := +n.fold (fun i p => p.push v) PersistentArray.empty + +@[inline] def mkPArray {α : Type u} (n : Nat) (v : α) : PArray α := +mkPersistentArray n v diff --git a/stage0/src/Init/Data/PersistentHashMap.lean b/stage0/src/Init/Data/PersistentHashMap.lean new file mode 100644 index 0000000000..ff75ec38e4 --- /dev/null +++ b/stage0/src/Init/Data/PersistentHashMap.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.PersistentHashMap.Basic diff --git a/stage0/src/Init/Data/PersistentHashMap/Basic.lean b/stage0/src/Init/Data/PersistentHashMap/Basic.lean new file mode 100644 index 0000000000..b7a22fc817 --- /dev/null +++ b/stage0/src/Init/Data/PersistentHashMap/Basic.lean @@ -0,0 +1,293 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Array +import Init.Data.Hashable +universes u v w w' + +namespace PersistentHashMap + +inductive Entry (α : Type u) (β : Type v) (σ : Type w) +| entry {} (key : α) (val : β) : Entry +| ref {} (node : σ) : Entry +| null {} : Entry + +instance Entry.inhabited {α β σ} : Inhabited (Entry α β σ) := ⟨Entry.null⟩ + +inductive Node (α : Type u) (β : Type v) : Type (max u v) +| entries (es : Array (Entry α β Node)) : Node +| collision (ks : Array α) (vs : Array β) (h : ks.size = vs.size) : Node + +instance Node.inhabited {α β} : Inhabited (Node α β) := ⟨Node.entries #[]⟩ + +abbrev shift : USize := 5 +abbrev branching : USize := USize.ofNat (2 ^ shift.toNat) +abbrev maxDepth : USize := 7 +abbrev maxCollisions : Nat := 4 + +def mkEmptyEntriesArray {α β} : Array (Entry α β (Node α β)) := +(Array.mkArray PersistentHashMap.branching.toNat PersistentHashMap.Entry.null) + +end PersistentHashMap + +structure PersistentHashMap (α : Type u) (β : Type v) [Hashable α] [HasBeq α] := +(root : PersistentHashMap.Node α β := PersistentHashMap.Node.entries PersistentHashMap.mkEmptyEntriesArray) +(size : Nat := 0) + +abbrev PHashMap (α : Type u) (β : Type v) [Hashable α] [HasBeq α] := PersistentHashMap α β + +namespace PersistentHashMap +variables {α : Type u} {β : Type v} + +def empty [Hashable α] [HasBeq α] : PersistentHashMap α β := {} + +instance [Hashable α] [HasBeq α] : HasEmptyc (PersistentHashMap α β) := ⟨empty⟩ + +def isEmpty [Hashable α] [HasBeq α] (m : PersistentHashMap α β) : Bool := +m.size == 0 + +instance [Hashable α] [HasBeq α] : Inhabited (PersistentHashMap α β) := ⟨{}⟩ + +def mkEmptyEntries {α β} : Node α β := +Node.entries mkEmptyEntriesArray + +abbrev mul2Shift (i : USize) (shift : USize) : USize := i.shiftLeft shift +abbrev div2Shift (i : USize) (shift : USize) : USize := i.shiftRight shift +abbrev mod2Shift (i : USize) (shift : USize) : USize := USize.land i ((USize.shiftLeft 1 shift) - 1) + +inductive IsCollisionNode : Node α β → Prop +| mk (keys : Array α) (vals : Array β) (h : keys.size = vals.size) : IsCollisionNode (Node.collision keys vals h) + +abbrev CollisionNode (α β) := { n : Node α β // IsCollisionNode n } + +inductive IsEntriesNode : Node α β → Prop +| mk (entries : Array (Entry α β (Node α β))) : IsEntriesNode (Node.entries entries) + +abbrev EntriesNode (α β) := { n : Node α β // IsEntriesNode n } + +private theorem setSizeEq {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (i : Fin ks.size) (j : Fin vs.size) (k : α) (v : β) + : (ks.set i k).size = (vs.set j v).size := +have h₁ : (ks.set i k).size = ks.size from Array.szFSetEq _ _ _; +have h₂ : (vs.set j v).size = vs.size from Array.szFSetEq _ _ _; +(h₁.trans h).trans h₂.symm + +private theorem pushSizeEq {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (k : α) (v : β) : (ks.push k).size = (vs.push v).size := +have h₁ : (ks.push k).size = ks.size + 1 from Array.szPushEq _ _; +have h₂ : (vs.push v).size = vs.size + 1 from Array.szPushEq _ _; +have h₃ : ks.size + 1 = vs.size + 1 from h ▸ rfl; +(h₁.trans h₃).trans h₂.symm + +partial def insertAtCollisionNodeAux [HasBeq α] : CollisionNode α β → Nat → α → β → CollisionNode α β +| n@⟨Node.collision keys vals heq, _⟩, i, k, v => + if h : i < keys.size then + let idx : Fin keys.size := ⟨i, h⟩; + let k' := keys.get idx; + if k == k' then + let j : Fin vals.size := ⟨i, heq ▸ h⟩; + ⟨Node.collision (keys.set idx k) (vals.set j v) (setSizeEq heq idx j k v), IsCollisionNode.mk _ _ _⟩ + else insertAtCollisionNodeAux n (i+1) k v + else + ⟨Node.collision (keys.push k) (vals.push v) (pushSizeEq heq k v), IsCollisionNode.mk _ _ _⟩ +| ⟨Node.entries _, h⟩, _, _, _ => False.elim (nomatch h) + +def insertAtCollisionNode [HasBeq α] : CollisionNode α β → α → β → CollisionNode α β := +fun n k v => insertAtCollisionNodeAux n 0 k v + +def getCollisionNodeSize : CollisionNode α β → Nat +| ⟨Node.collision keys _ _, _⟩ => keys.size +| ⟨Node.entries _, h⟩ => False.elim (nomatch h) + +def mkCollisionNode (k₁ : α) (v₁ : β) (k₂ : α) (v₂ : β) : Node α β := +let ks : Array α := Array.mkEmpty maxCollisions; +let ks := (ks.push k₁).push k₂; +let vs : Array β := Array.mkEmpty maxCollisions; +let vs := (vs.push v₁).push v₂; +Node.collision ks vs rfl + +partial def insertAux [HasBeq α] [Hashable α] : Node α β → USize → USize → α → β → Node α β +| Node.collision keys vals heq, _, depth, k, v => + let newNode := insertAtCollisionNode ⟨Node.collision keys vals heq, IsCollisionNode.mk _ _ _⟩ k v; + if depth >= maxDepth || getCollisionNodeSize newNode < maxCollisions then newNode.val + else match newNode with + | ⟨Node.entries _, h⟩ => False.elim (nomatch h) + | ⟨Node.collision keys vals heq, _⟩ => + let entries : Node α β := mkEmptyEntries; + keys.iterate entries $ fun i k entries => + let v := vals.get ⟨i.val, heq ▸ i.isLt⟩; + let h := hash k; + -- dbgTrace ("toCollision " ++ toString i ++ ", h: " ++ toString h ++ ", depth: " ++ toString depth ++ ", h': " ++ + -- toString (div2Shift h (shift * (depth - 1)))) $ fun _ => + let h := div2Shift h (shift * (depth - 1)); + insertAux entries h depth k v +| Node.entries entries, h, depth, k, v => + let j := (mod2Shift h shift).toNat; + Node.entries $ entries.modify j $ fun entry => + match entry with + | Entry.null => Entry.entry k v + | Entry.ref node => Entry.ref $ insertAux node (div2Shift h shift) (depth+1) k v + | Entry.entry k' v' => + if k == k' then Entry.entry k v + else Entry.ref $ mkCollisionNode k' v' k v + +def insert [HasBeq α] [Hashable α] : PersistentHashMap α β → α → β → PersistentHashMap α β +| { root := n, size := sz }, k, v => { root := insertAux n (hash k) 1 k v, size := sz + 1 } + +partial def findAtAux [HasBeq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) : Nat → α → Option β +| i, k => + if h : i < keys.size then + let k' := keys.get ⟨i, h⟩; + if k == k' then some (vals.get ⟨i, heq ▸ h⟩) + else findAtAux (i+1) k + else none + +partial def findAux [HasBeq α] : Node α β → USize → α → Option β +| Node.entries entries, h, k => + let j := (mod2Shift h shift).toNat; + match entries.get! j with + | Entry.null => none + | Entry.ref node => findAux node (div2Shift h shift) k + | Entry.entry k' v => if k == k' then some v else none +| Node.collision keys vals heq, _, k => findAtAux keys vals heq 0 k + +def find [HasBeq α] [Hashable α] : PersistentHashMap α β → α → Option β +| { root := n, .. }, k => findAux n (hash k) k + +@[inline] def findD [HasBeq α] [Hashable α] (m : PersistentHashMap α β) (a : α) (b₀ : β) : β := +(m.find a).getD b₀ + +@[inline] def find! [HasBeq α] [Hashable α] [Inhabited β] (m : PersistentHashMap α β) (a : α) : β := +match m.find a with +| some b => b +| none => panic! "key is not in the map" + +partial def containsAtAux [HasBeq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) : Nat → α → Bool +| i, k => + if h : i < keys.size then + let k' := keys.get ⟨i, h⟩; + if k == k' then true + else containsAtAux (i+1) k + else false + +partial def containsAux [HasBeq α] : Node α β → USize → α → Bool +| Node.entries entries, h, k => + let j := (mod2Shift h shift).toNat; + match entries.get! j with + | Entry.null => false + | Entry.ref node => containsAux node (div2Shift h shift) k + | Entry.entry k' v => k == k' +| Node.collision keys vals heq, _, k => containsAtAux keys vals heq 0 k + +def contains [HasBeq α] [Hashable α] : PersistentHashMap α β → α → Bool +| { root := n, .. }, k => containsAux n (hash k) k + +partial def isUnaryEntries (a : Array (Entry α β (Node α β))) : Nat → Option (α × β) → Option (α × β) +| i, acc => + if h : i < a.size then + match a.get ⟨i, h⟩ with + | Entry.null => isUnaryEntries (i+1) acc + | Entry.ref _ => none + | Entry.entry k v => + match acc with + | none => isUnaryEntries (i+1) (some (k, v)) + | some _ => none + else acc + +def isUnaryNode : Node α β → Option (α × β) +| Node.entries entries => isUnaryEntries entries 0 none +| Node.collision keys vals heq => + if h : 1 = keys.size then + have 0 < keys.size from h ▸ (Nat.zeroLtSucc _); + some (keys.get ⟨0, this⟩, vals.get ⟨0, heq ▸ this⟩) + else + none + +partial def eraseAux [HasBeq α] : Node α β → USize → α → Node α β × Bool +| n@(Node.collision keys vals heq), _, k => + match keys.indexOf k with + | some idx => + let ⟨keys', keq⟩ := keys.eraseIdx' idx; + let ⟨vals', veq⟩ := vals.eraseIdx' (Eq.rec idx heq); + have keys.size - 1 = vals.size - 1 from heq ▸ rfl; + (Node.collision keys' vals' (keq.trans (this.trans veq.symm)), true) + | none => (n, false) +| n@(Node.entries entries), h, k => + let j := (mod2Shift h shift).toNat; + let entry := entries.get! j; + match entry with + | Entry.null => (n, false) + | Entry.entry k' v => + if k == k' then (Node.entries (entries.set! j Entry.null), true) else (n, false) + | Entry.ref node => + let entries := entries.set! j Entry.null; + let (newNode, deleted) := eraseAux node (div2Shift h shift) k; + if !deleted then (n, false) + else match isUnaryNode newNode with + | none => (Node.entries (entries.set! j (Entry.ref newNode)), true) + | some (k, v) => (Node.entries (entries.set! j (Entry.entry k v)), true) + +def erase [HasBeq α] [Hashable α] : PersistentHashMap α β → α → PersistentHashMap α β +| { root := n, size := sz }, k => + let h := hash k; + let (n, del) := eraseAux n h k; + { root := n, size := if del then sz - 1 else sz } + +section +variables {m : Type w → Type w'} [Monad m] +variables {σ : Type w} + +@[specialize] partial def foldlMAux (f : σ → α → β → m σ) : Node α β → σ → m σ +| Node.collision keys vals heq, acc => keys.iterateM acc $ fun i k acc => f acc k (vals.get ⟨i.val, heq ▸ i.isLt⟩) +| Node.entries entries, acc => entries.foldlM (fun acc entry => + match entry with + | Entry.null => pure acc + | Entry.entry k v => f acc k v + | Entry.ref node => foldlMAux node acc) + acc + +@[specialize] def foldlM [Hashable α] [HasBeq α] (map : PersistentHashMap α β) (f : σ → α → β → m σ) (acc : σ) : m σ := +foldlMAux f map.root acc + +@[specialize] def foldl [Hashable α] [HasBeq α] (map : PersistentHashMap α β) (f : σ → α → β → σ) (acc : σ) : σ := +Id.run $ map.foldlM f acc +end + +def toList [Hashable α] [HasBeq α] (m : PersistentHashMap α β) : List (α × β) := +m.foldl (fun ps k v => (k, v) :: ps) [] + +structure Stats := +(numNodes : Nat := 0) +(numNull : Nat := 0) +(numCollisions : Nat := 0) +(maxDepth : Nat := 0) + +partial def collectStats : Node α β → Stats → Nat → Stats +| Node.collision keys _ _, stats, depth => + { numNodes := stats.numNodes + 1, + numCollisions := stats.numCollisions + keys.size - 1, + maxDepth := Nat.max stats.maxDepth depth, + .. stats } +| Node.entries entries, stats, depth => + let stats := + { numNodes := stats.numNodes + 1, + maxDepth := Nat.max stats.maxDepth depth, + .. stats }; + entries.foldl (fun stats entry => + match entry with + | Entry.null => { numNull := stats.numNull + 1, .. stats } + | Entry.ref node => collectStats node stats (depth + 1) + | Entry.entry _ _ => stats) + stats + +def stats [Hashable α] [HasBeq α] (m : PersistentHashMap α β) : Stats := +collectStats m.root {} 1 + +def Stats.toString (s : Stats) : String := +"{ nodes := " ++ toString s.numNodes ++ ", null := " ++ toString s.numNull ++ +", collisions := " ++ toString s.numCollisions ++ ", depth := " ++ toString s.maxDepth ++ "}" + +instance : HasToString Stats := ⟨Stats.toString⟩ + +end PersistentHashMap diff --git a/stage0/src/Init/Data/PersistentHashSet.lean b/stage0/src/Init/Data/PersistentHashSet.lean new file mode 100644 index 0000000000..9a63be93b6 --- /dev/null +++ b/stage0/src/Init/Data/PersistentHashSet.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.PersistentHashMap + +universes u v + +structure PersistentHashSet (α : Type u) [HasBeq α] [Hashable α] := +(set : PersistentHashMap α Unit) + +abbrev PHashSet (α : Type u) [HasBeq α] [Hashable α] := PersistentHashSet α + +namespace PersistentHashSet + +variables {α : Type u} [HasBeq α] [Hashable α] + +@[inline] def isEmpty (s : PersistentHashSet α) : Bool := +s.set.isEmpty + +@[inline] def empty : PersistentHashSet α := +{ set := PersistentHashMap.empty } + +instance : Inhabited (PersistentHashSet α) := +⟨empty⟩ + +instance : HasEmptyc (PersistentHashSet α) := +⟨empty⟩ + +@[inline] def insert (s : PersistentHashSet α) (a : α) : PersistentHashSet α := +{ set := s.set.insert a () } + +@[inline] def erase (s : PersistentHashSet α) (a : α) : PersistentHashSet α := +{ set := s.set.erase a } + +@[inline] def contains (s : PersistentHashSet α) (a : α) : Bool := +s.set.contains a + +@[inline] def size (s : PersistentHashSet α) : Nat := +s.set.size + +@[inline] def foldM {β : Type v} {m : Type v → Type v} [Monad m] (f : β → α → m β) (d : β) (s : PersistentHashSet α) : m β := +s.set.foldlM (fun d a _ => f d a) d + +@[inline] def fold {β : Type v} (f : β → α → β) (d : β) (s : PersistentHashSet α) : β := +Id.run $ s.foldM f d + +end PersistentHashSet diff --git a/stage0/src/Init/Data/Queue.lean b/stage0/src/Init/Data/Queue.lean new file mode 100644 index 0000000000..68a6627db9 --- /dev/null +++ b/stage0/src/Init/Data/Queue.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam +-/ +prelude +import Init.Data.Queue.Basic diff --git a/stage0/src/Init/Data/Queue/Basic.lean b/stage0/src/Init/Data/Queue/Basic.lean new file mode 100644 index 0000000000..0542e17568 --- /dev/null +++ b/stage0/src/Init/Data/Queue/Basic.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam + +Simple queue implemented using two lists. +Note: this is only a temporary placeholder. +-/ +prelude +import Init.Data.Array +import Init.Data.Int +universes u v w + +structure Queue (α : Type u) := +(eList dList : List α := []) + +namespace Queue + +variable {α : Type u} + +def empty : Queue α := +{ eList := [], dList := [] } + +def isEmpty (q : Queue α) : Bool := +q.dList.isEmpty && q.eList.isEmpty + +def enqueue (v : α) (q : Queue α) : Queue α := +{ eList := v::q.eList .. q } + +def enqueueAll (vs : List α) (q : Queue α) : Queue α := +{ eList := vs ++ q.eList .. q } + +def dequeue? (q : Queue α) : Option (α × Queue α) := +match q.dList with +| d::ds => some (d, { dList := ds, .. q }) +| [] => + match q.eList.reverse with + | [] => none + | d::ds => some (d, { eList := [], dList := ds }) + +end Queue diff --git a/stage0/src/Init/Data/RBMap.lean b/stage0/src/Init/Data/RBMap.lean new file mode 100644 index 0000000000..2dd824ced0 --- /dev/null +++ b/stage0/src/Init/Data/RBMap.lean @@ -0,0 +1,8 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.RBMap.Basic +import Init.Data.RBMap.BasicAux diff --git a/stage0/src/Init/Data/RBMap/Basic.lean b/stage0/src/Init/Data/RBMap/Basic.lean new file mode 100644 index 0000000000..e2a87a9614 --- /dev/null +++ b/stage0/src/Init/Data/RBMap/Basic.lean @@ -0,0 +1,309 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Repr +import Init.Data.Option.Basic + +universes u v w w' + +inductive Rbcolor +| red | black + +inductive RBNode (α : Type u) (β : α → Type v) +| leaf {} : RBNode +| node (color : Rbcolor) (lchild : RBNode) (key : α) (val : β key) (rchild : RBNode) : RBNode + +namespace RBNode +variables {α : Type u} {β : α → Type v} {σ : Type w} + +open Rbcolor Nat + +def depth (f : Nat → Nat → Nat) : RBNode α β → Nat +| leaf => 0 +| node _ l _ _ r => succ (f (depth l) (depth r)) + +protected def min : RBNode α β → Option (Sigma (fun k => β k)) +| leaf => none +| node _ leaf k v _ => some ⟨k, v⟩ +| node _ l k v _ => min l + +protected def max : RBNode α β → Option (Sigma (fun k => β k)) +| leaf => none +| node _ _ k v leaf => some ⟨k, v⟩ +| node _ _ k v r => max r + +@[specialize] def fold (f : σ → ∀ (k : α), β k → σ) : σ → RBNode α β → σ +| b, leaf => b +| b, node _ l k v r => fold (f (fold b l) k v) r + +@[specialize] def mfold {m : Type w → Type w'} [Monad m] (f : σ → ∀ (k : α), β k → m σ) : σ → RBNode α β → m σ +| b, leaf => pure b +| b, node _ l k v r => do + b ← mfold b l; + b ← f b k v; + mfold b r + +@[specialize] def revFold (f : σ → ∀ (k : α), β k → σ) : σ → RBNode α β → σ +| b, leaf => b +| b, node _ l k v r => revFold (f (revFold b r) k v) l + +@[specialize] def all (p : ∀ k, β k → Bool) : RBNode α β → Bool +| leaf => true +| node _ l k v r => p k v && all l && all r + +@[specialize] def any (p : ∀ k, β k → Bool) : RBNode α β → Bool +| leaf => false +| node _ l k v r => p k v || any l || any r + +def singleton (k : α) (v : β k) : RBNode α β := +node red leaf k v leaf + +@[inline] def balance1 : ∀ a, β a → RBNode α β → RBNode α β → RBNode α β +| kv, vv, t, node _ (node red l kx vx r₁) ky vy r₂ => node red (node black l kx vx r₁) ky vy (node black r₂ kv vv t) +| kv, vv, t, node _ l₁ ky vy (node red l₂ kx vx r) => node red (node black l₁ ky vy l₂) kx vx (node black r kv vv t) +| kv, vv, t, node _ l ky vy r => node black (node red l ky vy r) kv vv t +| _, _, _, _ => leaf -- unreachable + +@[inline] def balance2 : RBNode α β → ∀ a, β a → RBNode α β → RBNode α β +| t, kv, vv, node _ (node red l kx₁ vx₁ r₁) ky vy r₂ => node red (node black t kv vv l) kx₁ vx₁ (node black r₁ ky vy r₂) +| t, kv, vv, node _ l₁ ky vy (node red l₂ kx₂ vx₂ r₂) => node red (node black t kv vv l₁) ky vy (node black l₂ kx₂ vx₂ r₂) +| t, kv, vv, node _ l ky vy r => node black t kv vv (node red l ky vy r) +| _, _, _, _ => leaf -- unreachable + +def isRed : RBNode α β → Bool +| node red _ _ _ _ => true +| _ => false + +def isBlack : RBNode α β → Bool +| node black _ _ _ _ => true +| _ => false + +section Insert + +variables (lt : α → α → Bool) + +@[specialize] def ins : RBNode α β → ∀ k, β k → RBNode α β +| leaf, kx, vx => node red leaf kx vx leaf +| node red a ky vy b, kx, vx => + if lt kx ky then node red (ins a kx vx) ky vy b + else if lt ky kx then node red a ky vy (ins b kx vx) + else node red a kx vx b +| node black a ky vy b, kx, vx => + if lt kx ky then + if isRed a then balance1 ky vy b (ins a kx vx) + else node black (ins a kx vx) ky vy b + else if lt ky kx then + if isRed b then balance2 a ky vy (ins b kx vx) + else node black a ky vy (ins b kx vx) + else + node black a kx vx b + +def setBlack : RBNode α β → RBNode α β +| node _ l k v r => node black l k v r +| e => e + +@[specialize] def insert (t : RBNode α β) (k : α) (v : β k) : RBNode α β := +if isRed t then setBlack (ins lt t k v) +else ins lt t k v + +end Insert + +def balance₃ : RBNode α β → ∀ k, β k → RBNode α β → RBNode α β +| node red (node red a kx vx b) ky vy c, k, v, d => node red (node black a kx vx b) ky vy (node black c k v d) +| node red a kx vx (node red b ky vy c), k, v, d => node red (node black a kx vx b) ky vy (node black c k v d) +| a, k, v, node red b ky vy (node red c kz vz d) => node red (node black a k v b) ky vy (node black c kz vz d) +| a, k, v, node red (node red b ky vy c) kz vz d => node red (node black a k v b) ky vy (node black c kz vz d) +| l, k, v, r => node black l k v r + +def setRed : RBNode α β → RBNode α β +| node _ a k v b => node red a k v b +| e => e + +def balLeft : RBNode α β → ∀ k, β k → RBNode α β → RBNode α β +| node red a kx vx b, k, v, r => node red (node black a kx vx b) k v r +| l, k, v, node black a ky vy b => balance₃ l k v (node red a ky vy b) +| l, k, v, node red (node black a ky vy b) kz vz c => node red (node black l k v a) ky vy (balance₃ b kz vz (setRed c)) +| l, k, v, r => node red l k v r -- unreachable + +def balRight (l : RBNode α β) (k : α) (v : β k) (r : RBNode α β) : RBNode α β := +match r with +| (node red b ky vy c) => node red l k v (node black b ky vy c) +| _ => match l with + | node black a kx vx b => balance₃ (node red a kx vx b) k v r + | node red a kx vx (node black b ky vy c) => node red (balance₃ (setRed a) kx vx b) ky vy (node black c k v r) + | _ => node red l k v r -- unreachable + +-- TODO: use wellfounded recursion +partial def appendTrees : RBNode α β → RBNode α β → RBNode α β +| leaf, x => x +| x, leaf => x +| node red a kx vx b, node red c ky vy d => + match appendTrees b c with + | node red b' kz vz c' => node red (node red a kx vx b') kz vz (node red c' ky vy d) + | bc => node red a kx vx (node red bc ky vy d) +| node black a kx vx b, node black c ky vy d => + match appendTrees b c with + | node red b' kz vz c' => node red (node black a kx vx b') kz vz (node black c' ky vy d) + | bc => balLeft a kx vx (node black bc ky vy d) + | a, node red b kx vx c => node red (appendTrees a b) kx vx c + | node red a kx vx b, c => node red a kx vx (appendTrees b c) + +section Erase + +variables (lt : α → α → Bool) + +@[specialize] def del (x : α) : RBNode α β → RBNode α β +| leaf => leaf +| node _ a y v b => + if lt x y then + if a.isBlack then balLeft (del a) y v b + else node red (del a) y v b + else if lt y x then + if b.isBlack then balRight a y v (del b) + else node red a y v (del b) + else appendTrees a b + +@[specialize] def erase (x : α) (t : RBNode α β) : RBNode α β := +let t := del lt x t; +t.setBlack + +end Erase + +section Membership +variable (lt : α → α → Bool) + +@[specialize] def findCore : RBNode α β → ∀ (k : α), Option (Sigma (fun k => β k)) +| leaf, x => none +| node _ a ky vy b, x => + if lt x ky then findCore a x + else if lt ky x then findCore b x + else some ⟨ky, vy⟩ + +@[specialize] def find {β : Type v} : RBNode α (fun _ => β) → α → Option β +| leaf, x => none +| node _ a ky vy b, x => + if lt x ky then find a x + else if lt ky x then find b x + else some vy + +@[specialize] def lowerBound : RBNode α β → α → Option (Sigma β) → Option (Sigma β) +| leaf, x, lb => lb +| node _ a ky vy b, x, lb => + if lt x ky then lowerBound a x lb + else if lt ky x then lowerBound b x (some ⟨ky, vy⟩) + else some ⟨ky, vy⟩ + +end Membership + +inductive WellFormed (lt : α → α → Bool) : RBNode α β → Prop +| leafWff : WellFormed leaf +| insertWff {n n' : RBNode α β} {k : α} {v : β k} : WellFormed n → n' = insert lt n k v → WellFormed n' +| eraseWff {n n' : RBNode α β} {k : α} : WellFormed n → n' = erase lt k n → WellFormed n' + +end RBNode + +open RBNode + +/- TODO(Leo): define dRBMap -/ + +def RBMap (α : Type u) (β : Type v) (lt : α → α → Bool) : Type (max u v) := +{t : RBNode α (fun _ => β) // t.WellFormed lt } + +@[inline] def mkRBMap (α : Type u) (β : Type v) (lt : α → α → Bool) : RBMap α β lt := +⟨leaf, WellFormed.leafWff lt⟩ + +@[inline] def RBMap.empty {α : Type u} {β : Type v} {lt : α → α → Bool} : RBMap α β lt := +mkRBMap _ _ _ + +instance (α : Type u) (β : Type v) (lt : α → α → Bool) : HasEmptyc (RBMap α β lt) := +⟨RBMap.empty⟩ + +namespace RBMap +variables {α : Type u} {β : Type v} {σ : Type w} {lt : α → α → Bool} + +def depth (f : Nat → Nat → Nat) (t : RBMap α β lt) : Nat := +t.val.depth f + +@[inline] def fold (f : σ → α → β → σ) : σ → RBMap α β lt → σ +| b, ⟨t, _⟩ => t.fold f b + +@[inline] def revFold (f : σ → α → β → σ) : σ → RBMap α β lt → σ +| b, ⟨t, _⟩ => t.revFold f b + +@[inline] def mfold {m : Type w → Type w'} [Monad m] (f : σ → α → β → m σ) : σ → RBMap α β lt → m σ +| b, ⟨t, _⟩ => t.mfold f b + +@[inline] def mfor {m : Type w → Type w'} [Monad m] (f : α → β → m σ) (t : RBMap α β lt) : m PUnit := +t.mfold (fun _ k v => f k v *> pure ⟨⟩) ⟨⟩ + +@[inline] def isEmpty : RBMap α β lt → Bool +| ⟨leaf, _⟩ => true +| _ => false + +@[specialize] def toList : RBMap α β lt → List (α × β) +| ⟨t, _⟩ => t.revFold (fun ps k v => (k, v)::ps) [] + +@[inline] protected def min : RBMap α β lt → Option (α × β) +| ⟨t, _⟩ => + match t.min with + | some ⟨k, v⟩ => some (k, v) + | none => none + +@[inline] protected def max : RBMap α β lt → Option (α × β) +| ⟨t, _⟩ => + match t.max with + | some ⟨k, v⟩ => some (k, v) + | none => none + +instance [HasRepr α] [HasRepr β] : HasRepr (RBMap α β lt) := +⟨fun t => "rbmapOf " ++ repr t.toList⟩ + +@[inline] def insert : RBMap α β lt → α → β → RBMap α β lt +| ⟨t, w⟩, k, v => ⟨t.insert lt k v, WellFormed.insertWff w rfl⟩ + +@[inline] def erase : RBMap α β lt → α → RBMap α β lt +| ⟨t, w⟩, k => ⟨t.erase lt k, WellFormed.eraseWff w rfl⟩ + +@[specialize] def ofList : List (α × β) → RBMap α β lt +| [] => mkRBMap _ _ _ +| ⟨k,v⟩::xs => (ofList xs).insert k v + +@[inline] def findCore : RBMap α β lt → α → Option (Sigma (fun (k : α) => β)) +| ⟨t, _⟩, x => t.findCore lt x + +@[inline] def find : RBMap α β lt → α → Option β +| ⟨t, _⟩, x => t.find lt x + +@[inline] def findD (t : RBMap α β lt) (k : α) (v₀ : β) : β := +(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 : RBMap α β lt → α → Option (Sigma (fun (k : α) => β)) +| ⟨t, _⟩, x => t.lowerBound lt x none + +@[inline] def contains (t : RBMap α β lt) (a : α) : Bool := +(t.find a).isSome + +@[inline] def fromList (l : List (α × β)) (lt : α → α → Bool) : RBMap α β lt := +l.foldl (fun r p => r.insert p.1 p.2) (mkRBMap α β lt) + +@[inline] def all : RBMap α β lt → (α → β → Bool) → Bool +| ⟨t, _⟩, p => t.all p + +@[inline] def any : RBMap α β lt → (α → β → Bool) → Bool +| ⟨t, _⟩, p => t.any p + +def size (m : RBMap α β lt) : Nat := +m.fold (fun sz _ _ => sz+1) 0 + +def maxDepth (t : RBMap α β lt) : Nat := +t.val.depth Nat.max + +end RBMap + +def rbmapOf {α : Type u} {β : Type v} (l : List (α × β)) (lt : α → α → Bool) : RBMap α β lt := +RBMap.fromList l lt diff --git a/stage0/src/Init/Data/RBMap/BasicAux.lean b/stage0/src/Init/Data/RBMap/BasicAux.lean new file mode 100644 index 0000000000..e99e6876d8 --- /dev/null +++ b/stage0/src/Init/Data/RBMap/BasicAux.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.RBMap.Basic +import Init.Util + +universes u v w w' + +namespace RBMap +variables {α : Type u} {β : Type v} {lt : α → α → Bool} + +@[inline] def min! [Inhabited α] [Inhabited β] (t : RBMap α β lt) : α × β := +match t.min with +| some p => p +| none => panic! "map is empty" + +@[inline] def max! [Inhabited α] [Inhabited β] (t : RBMap α β lt) : α × β := +match t.max with +| some p => p +| none => panic! "map is empty" + +@[inline] def find! [Inhabited β] (t : RBMap α β lt) (k : α) : β := +match t.find k with +| some b => b +| none => panic! "key is not in the map" + +end RBMap diff --git a/stage0/src/Init/Data/RBTree.lean b/stage0/src/Init/Data/RBTree.lean new file mode 100644 index 0000000000..4fd618f37d --- /dev/null +++ b/stage0/src/Init/Data/RBTree.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.RBTree.Basic diff --git a/stage0/src/Init/Data/RBTree/Basic.lean b/stage0/src/Init/Data/RBTree/Basic.lean new file mode 100644 index 0000000000..a4b379d903 --- /dev/null +++ b/stage0/src/Init/Data/RBTree/Basic.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.RBMap.Basic +universes u v w + +def RBTree (α : Type u) (lt : α → α → Bool) : Type u := +RBMap α Unit lt + +@[inline] def mkRBTree (α : Type u) (lt : α → α → Bool) : RBTree α lt := +mkRBMap α Unit lt + +instance (α : Type u) (lt : α → α → Bool) : HasEmptyc (RBTree α lt) := +⟨mkRBTree α lt⟩ + +namespace RBTree +variables {α : Type u} {β : Type v} {lt : α → α → Bool} + +@[inline] def empty : RBTree α lt := +RBMap.empty + +@[inline] def depth (f : Nat → Nat → Nat) (t : RBTree α lt) : Nat := +RBMap.depth f t + +@[inline] def fold (f : β → α → β) (b : β) (t : RBTree α lt) : β := +RBMap.fold (fun r a _ => f r a) b t + +@[inline] def revFold (f : β → α → β) (b : β) (t : RBTree α lt) : β := +RBMap.revFold (fun r a _ => f r a) b t + +@[inline] def mfold {m : Type v → Type w} [Monad m] (f : β → α → m β) (b : β) (t : RBTree α lt) : m β := +RBMap.mfold (fun r a _ => f r a) b t + +@[inline] def mfor {m : Type v → Type w} [Monad m] (f : α → m β) (t : RBTree α lt) : m PUnit := +t.mfold (fun _ a => f a *> pure ⟨⟩) ⟨⟩ + +@[inline] def isEmpty (t : RBTree α lt) : Bool := +RBMap.isEmpty t + +@[specialize] def toList (t : RBTree α lt) : List α := +t.revFold (fun as a => a::as) [] + +@[inline] protected def min (t : RBTree α lt) : Option α := +match RBMap.min t with +| some ⟨a, _⟩ => some a +| none => none + +@[inline] protected def max (t : RBTree α lt) : Option α := +match RBMap.max t with +| some ⟨a, _⟩ => some a +| none => none + +instance [HasRepr α] : HasRepr (RBTree α lt) := +⟨fun t => "rbtreeOf " ++ repr t.toList⟩ + +@[inline] def insert (t : RBTree α lt) (a : α) : RBTree α lt := +RBMap.insert t a () + +@[inline] def erase (t : RBTree α lt) (a : α) : RBTree α lt := +RBMap.erase t a + +@[specialize] def ofList : List α → RBTree α lt +| [] => mkRBTree _ _ +| x::xs => (ofList xs).insert x + +@[inline] def find (t : RBTree α lt) (a : α) : Option α := +match RBMap.findCore t a with +| some ⟨a, _⟩ => some a +| none => none + +@[inline] def contains (t : RBTree α lt) (a : α) : Bool := +(t.find a).isSome + +def fromList (l : List α) (lt : α → α → Bool) : RBTree α lt := +l.foldl insert (mkRBTree α lt) + +@[inline] def all (t : RBTree α lt) (p : α → Bool) : Bool := +RBMap.all t (fun a _ => p a) + +@[inline] def any (t : RBTree α lt) (p : α → Bool) : Bool := +RBMap.any t (fun a _ => p a) + +def subset (t₁ t₂ : RBTree α lt) : Bool := +t₁.all $ fun a => (t₂.find a).toBool + +def seteq (t₁ t₂ : RBTree α lt) : Bool := +subset t₁ t₂ && subset t₂ t₁ + +end RBTree + +def rbtreeOf {α : Type u} (l : List α) (lt : α → α → Bool) : RBTree α lt := +RBTree.fromList l lt diff --git a/stage0/src/Init/Data/Random.lean b/stage0/src/Init/Data/Random.lean new file mode 100644 index 0000000000..8d8bf33470 --- /dev/null +++ b/stage0/src/Init/Data/Random.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.System.IO +import Init.Data.Int +universes u + +/- +Basic random number generator support based on the one +available on the Haskell library +-/ + +/- Interface for random number generators. -/ +class RandomGen (g : Type u) := +/- `range` returns the range of values returned by + the generator. -/ +(range : g → Nat × Nat) +/- `next` operation returns a natural number that is uniformly distributed + the range returned by `range` (including both end points), + and a new generator. -/ +(next : g → Nat × g) +/- + The 'split' operation allows one to obtain two distinct random number + generators. This is very useful in functional programs (for example, when + passing a random number generator down to recursive calls). -/ +(split : g → g × g) + +/- "Standard" random number generator. -/ +structure StdGen := +(s1 : Nat) (s2 : Nat) + +def stdRange := (1, 2147483562) + +instance : HasRepr StdGen := +{ repr := fun ⟨s1, s2⟩ => "⟨" ++ toString s1 ++ ", " ++ toString s2 ++ "⟩" } + +def stdNext : StdGen → Nat × StdGen +| ⟨s1, s2⟩ => + let k : Int := s1 / 53668; + let s1' : Int := 40014 * ((s1 : Int) - k * 53668) - k * 12211; + let s1'' : Int := if s1' < 0 then s1' + 2147483563 else s1'; + let k' : Int := s2 / 52774; + let s2' : Int := 40692 * ((s2 : Int) - k' * 52774) - k' * 3791; + let s2'' : Int := if s2' < 0 then s2' + 2147483399 else s2'; + let z : Int := s1'' - s2''; + let z' : Int := if z < 1 then z + 2147483562 else z % 2147483562; + (z'.toNat, ⟨s1''.toNat, s2''.toNat⟩) + +def stdSplit : StdGen → StdGen × StdGen +| g@⟨s1, s2⟩ => + let newS1 := if s1 = 2147483562 then 1 else s1 + 1; + let newS2 := if s2 = 1 then 2147483398 else s2 - 1; + let newG := (stdNext g).2; + let leftG := StdGen.mk newS1 newG.2; + let rightG := StdGen.mk newG.1 newS2; + (leftG, rightG) + +instance : RandomGen StdGen := +{range := fun _ => stdRange, + next := stdNext, + split := stdSplit} + +/-- Return a standard number generator. -/ +def mkStdGen (s : Nat := 0) : StdGen := +let q := s / 2147483562; +let s1 := s % 2147483562; +let s2 := q % 2147483398; +⟨s1 + 1, s2 + 1⟩ + +/- +Auxiliary function for randomNatVal. +Generate random values until we exceed the target magnitude. +`genLo` and `genMag` are the generator lower bound and magnitude. +The parameter `r` is the "remaining" magnitude. +-/ +private partial def randNatAux {gen : Type u} [RandomGen gen] (genLo genMag : Nat) : Nat → (Nat × gen) → Nat × gen +| 0, (v, g) => (v, g) +| r'@(r+1), (v, g) => + let (x, g') := RandomGen.next g; + let v' := v*genMag + (x - genLo); + randNatAux (r' / genMag - 1) (v', g') + +/-- Generate a random natural number in the interval [lo, hi]. -/ +def randNat {gen : Type u} [RandomGen gen] (g : gen) (lo hi : Nat) : Nat × gen := +let lo' := if lo > hi then hi else lo; +let hi' := if lo > hi then lo else hi; +let (genLo, genHi) := RandomGen.range g; +let genMag := genHi - genLo + 1; + /- + Probabilities of the most likely and least likely result + will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen + is uniform, of course + -/ +let q := 1000; +let k := hi' - lo' + 1; +let tgtMag := k * q; +let (v, g') := randNatAux genLo genMag tgtMag (0, g); +let v' := lo' + (v % k); +(v', g') + +/-- Generate a random Boolean. -/ +def randBool {gen : Type u} [RandomGen gen] (g : gen) : Bool × gen := +let (v, g') := randNat g 0 1; +(v = 1, g') + +def IO.mkStdGenRef : IO (IO.Ref StdGen) := +IO.mkRef mkStdGen + +@[init IO.mkStdGenRef] +constant IO.stdGenRef : IO.Ref StdGen := arbitrary _ + +def IO.setRandSeed (n : Nat) : IO Unit := +IO.stdGenRef.set (mkStdGen n) + +def IO.rand (lo hi : Nat) : IO Nat := +do gen ← IO.stdGenRef.get; + let (r, gen) := randNat gen lo hi; + IO.stdGenRef.set gen; + pure r diff --git a/stage0/src/Init/Data/Repr.lean b/stage0/src/Init/Data/Repr.lean new file mode 100644 index 0000000000..cd068e4f21 --- /dev/null +++ b/stage0/src/Init/Data/Repr.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.String.Basic +import Init.Data.UInt +import Init.Data.Nat.Div +open Sum Subtype Nat + +universes u v + +class HasRepr (α : Type u) := +(repr : α → String) + +export HasRepr (repr) + +-- This instance is needed because `id` is not reducible +instance {α : Type u} [HasRepr α] : HasRepr (id α) := +inferInstanceAs (HasRepr α) + +instance : HasRepr Bool := +⟨fun b => cond b "true" "false"⟩ + +instance {p : Prop} : HasRepr (Decidable p) := +⟨fun b => @ite p b _ "true" "false"⟩ + +protected def List.reprAux {α : Type u} [HasRepr α] : Bool → List α → String +| b, [] => "" +| true, x::xs => repr x ++ List.reprAux false xs +| false, x::xs => ", " ++ repr x ++ List.reprAux false xs + +protected def List.repr {α : Type u} [HasRepr α] : List α → String +| [] => "[]" +| x::xs => "[" ++ List.reprAux true (x::xs) ++ "]" + +instance {α : Type u} [HasRepr α] : HasRepr (List α) := +⟨List.repr⟩ + +instance : HasRepr Unit := +⟨fun u => "()"⟩ + +instance {α : Type u} [HasRepr α] : HasRepr (Option α) := +⟨fun o => match o with | none => "none" | (some a) => "(some " ++ repr a ++ ")"⟩ + +instance {α : Type u} {β : Type v} [HasRepr α] [HasRepr β] : HasRepr (Sum α β) := +⟨fun s => match s with | (inl a) => "(inl " ++ repr a ++ ")" | (inr b) => "(inr " ++ repr b ++ ")"⟩ + +instance {α : Type u} {β : Type v} [HasRepr α] [HasRepr β] : HasRepr (α × β) := +⟨fun ⟨a, b⟩ => "(" ++ repr a ++ ", " ++ repr b ++ ")"⟩ + +instance {α : Type u} {β : α → Type v} [HasRepr α] [s : ∀ x, HasRepr (β x)] : HasRepr (Sigma β) := +⟨fun ⟨a, b⟩ => "⟨" ++ repr a ++ ", " ++ repr b ++ "⟩"⟩ + +instance {α : Type u} {p : α → Prop} [HasRepr α] : HasRepr (Subtype p) := +⟨fun s => repr (val s)⟩ + +namespace Nat + +def digitChar (n : Nat) : Char := +if n = 0 then '0' else +if n = 1 then '1' else +if n = 2 then '2' else +if n = 3 then '3' else +if n = 4 then '4' else +if n = 5 then '5' else +if n = 6 then '6' else +if n = 7 then '7' else +if n = 8 then '8' else +if n = 9 then '9' else +if n = 0xa then 'a' else +if n = 0xb then 'b' else +if n = 0xc then 'c' else +if n = 0xd then 'd' else +if n = 0xe then 'e' else +if n = 0xf then 'f' else +'*' + +def toDigitsCore (base : Nat) : Nat → Nat → List Char → List Char +| 0, n, ds => ds +| fuel+1, n, ds => + let d := digitChar $ n % base; + let n' := n / base; + if n' = 0 then d::ds + else toDigitsCore fuel n' (d::ds) + +def toDigits (base : Nat) (n : Nat) : List Char := +toDigitsCore base (n+1) n [] + +protected def repr (n : Nat) : String := +(toDigits 10 n).asString + +end Nat + +instance : HasRepr Nat := +⟨Nat.repr⟩ + +def hexDigitRepr (n : Nat) : String := +String.singleton $ Nat.digitChar n + +def charToHex (c : Char) : String := +let n := Char.toNat c; +let d2 := n / 16; +let d1 := n % 16; +hexDigitRepr d2 ++ hexDigitRepr d1 + +def Char.quoteCore (c : Char) : String := +if c = '\n' then "\\n" +else if c = '\t' then "\\t" +else if c = '\\' then "\\\\" +else if c = '\"' then "\\\"" +else if c.toNat <= 31 ∨ c = '\x7f' then "\\x" ++ charToHex c +else String.singleton c + +instance : HasRepr Char := +⟨fun c => "'" ++ Char.quoteCore c ++ "'"⟩ + +def String.quoteAux : List Char → String +| [] => "" +| x::xs => Char.quoteCore x ++ String.quoteAux xs + +def String.quote (s : String) : String := +if s.isEmpty = true then "\"\"" +else "\"" ++ String.quoteAux s.toList ++ "\"" + +instance : HasRepr String := +⟨String.quote⟩ + +instance : HasRepr Substring := +⟨fun s => String.quote s.toString ++ ".toSubstring"⟩ + +instance : HasRepr String.Iterator := +⟨fun ⟨s, pos⟩ => "(String.Iterator.mk " ++ repr s ++ " " ++ repr pos ++ ")"⟩ + +instance (n : Nat) : HasRepr (Fin n) := +⟨fun f => repr (Fin.val f)⟩ + +instance : HasRepr UInt16 := ⟨fun n => repr n.toNat⟩ +instance : HasRepr UInt32 := ⟨fun n => repr n.toNat⟩ +instance : HasRepr UInt64 := ⟨fun n => repr n.toNat⟩ +instance : HasRepr USize := ⟨fun n => repr n.toNat⟩ + +def Char.repr (c : Char) : String := +repr c diff --git a/stage0/src/Init/Data/Stack.lean b/stage0/src/Init/Data/Stack.lean new file mode 100644 index 0000000000..47ab22409b --- /dev/null +++ b/stage0/src/Init/Data/Stack.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam +-/ +prelude +import Init.Data.Stack.Basic diff --git a/stage0/src/Init/Data/Stack/Basic.lean b/stage0/src/Init/Data/Stack/Basic.lean new file mode 100644 index 0000000000..69c6b5e9f1 --- /dev/null +++ b/stage0/src/Init/Data/Stack/Basic.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam + +Simple stack API implemented using an array. +-/ +prelude +import Init.Data.Array +import Init.Data.Int +universes u v w + +structure Stack (α : Type u) := +(vals : Array α := #[]) + +namespace Stack + +variable {α : Type u} + +def empty : Stack α := +{} + +def isEmpty (s : Stack α) : Bool := +s.vals.isEmpty + +def push (v : α) (s : Stack α) : Stack α := +{ vals := s.vals.push v .. s } + +def peek? (s : Stack α) : Option α := +if s.vals.isEmpty then none else s.vals.get? (s.vals.size-1) + +def peek! [Inhabited α] (s : Stack α) : α := +s.vals.back + +def pop [Inhabited α] (s : Stack α) : Stack α := +{ vals := s.vals.pop .. s } + +def modify [Inhabited α] (s : Stack α) (f : α → α) : Stack α := +{ vals := s.vals.modify (s.vals.size-1) f .. s } + +end Stack diff --git a/stage0/src/Init/Data/String.lean b/stage0/src/Init/Data/String.lean new file mode 100644 index 0000000000..88da4da708 --- /dev/null +++ b/stage0/src/Init/Data/String.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.String.Basic diff --git a/stage0/src/Init/Data/String/Basic.lean b/stage0/src/Init/Data/String/Basic.lean new file mode 100644 index 0000000000..15b4c3e384 --- /dev/null +++ b/stage0/src/Init/Data/String/Basic.lean @@ -0,0 +1,518 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.List.Basic +import Init.Data.Char.Basic +import Init.Data.Option.Basic +universes u + +structure String := +(data : List Char) + +abbrev String.Pos := Nat + +structure Substring := +(str : String) (startPos : String.Pos) (stopPos : String.Pos) + +attribute [extern "lean_string_mk"] String.mk +attribute [extern "lean_string_data"] String.data + +@[extern "lean_string_dec_eq"] +def String.decEq (s₁ s₂ : @& String) : Decidable (s₁ = s₂) := +match s₁, s₂ with +| ⟨s₁⟩, ⟨s₂⟩ => + if h : s₁ = s₂ then isTrue (congrArg _ h) + else isFalse (fun h' => String.noConfusion h' (fun h' => absurd h' h)) + +instance : DecidableEq String := +{decEq := String.decEq} + +def List.asString (s : List Char) : String := +⟨s⟩ + +namespace String +instance : HasLess String := +⟨fun s₁ s₂ => s₁.data < s₂.data⟩ + +@[extern "lean_string_dec_lt"] +instance decLt (s₁ s₂ : @& String) : Decidable (s₁ < s₂) := +List.hasDecidableLt s₁.data s₂.data + +@[extern "lean_string_length"] +def length : (@& String) → Nat +| ⟨s⟩ => s.length + +/- The internal implementation uses dynamic arrays and will perform destructive updates + if the String is not shared. -/ +@[extern "lean_string_push"] +def push : String → Char → String +| ⟨s⟩, c => ⟨s ++ [c]⟩ + +/- The internal implementation uses dynamic arrays and will perform destructive updates + if the String is not shared. -/ +@[extern "lean_string_append"] +def append : String → (@& String) → String +| ⟨a⟩, ⟨b⟩ => ⟨a ++ b⟩ + +/- O(n) in the runtime, where n is the length of the String -/ +def toList (s : String) : List Char := +s.data + +private def csize (c : Char) : Nat := +c.utf8Size.toNat + +private def utf8ByteSizeAux : List Char → Nat → Nat +| [], r => r +| c::cs, r => utf8ByteSizeAux cs (r + csize c) + +@[extern "lean_string_utf8_byte_size"] +def utf8ByteSize : (@& String) → Nat +| ⟨s⟩ => utf8ByteSizeAux s 0 + +@[inline] def bsize (s : String) : Nat := +utf8ByteSize s + +@[inline] def toSubstring (s : String) : Substring := +{str := s, startPos := 0, stopPos := s.bsize} + +private def utf8GetAux : List Char → Pos → Pos → Char +| [], i, p => arbitrary Char +| c::cs, i, p => if i = p then c else utf8GetAux cs (i + csize c) p + +@[extern "lean_string_utf8_get"] +def get : (@& String) → (@& Pos) → Char +| ⟨s⟩, p => utf8GetAux s 0 p + +private def utf8SetAux (c' : Char) : List Char → Pos → Pos → List Char +| [], i, p => [] +| c::cs, i, p => + if i = p then (c'::cs) else c::(utf8SetAux cs (i + csize c) p) + +@[extern "lean_string_utf8_set"] +def set : String → (@& Pos) → Char → String +| ⟨s⟩, i, c => ⟨utf8SetAux c s 0 i⟩ + +@[extern "lean_string_utf8_next"] +def next (s : @& String) (p : @& Pos) : Pos := +let c := get s p; +p + csize c + +private def utf8PrevAux : List Char → Pos → Pos → Pos +| [], i, p => 0 +| c::cs, i, p => + let cz := csize c; + let i' := i + cz; + if i' = p then i else utf8PrevAux cs i' p + +@[extern "lean_string_utf8_prev"] +def prev : (@& String) → (@& Pos) → Pos +| ⟨s⟩, p => if p = 0 then 0 else utf8PrevAux s 0 p + +def front (s : String) : Char := +get s 0 + +def back (s : String) : Char := +get s (prev s (bsize s)) + +@[extern "lean_string_utf8_at_end"] +def atEnd : (@& String) → (@& Pos) → Bool +| s, p => p ≥ utf8ByteSize s + +/- TODO: remove `partial` keywords after we restore the tactic + framework and wellfounded recursion support -/ + +partial def posOfAux (s : String) (c : Char) (stopPos : Pos) : Pos → Pos +| pos => + if pos == stopPos then pos + else if s.get pos == c then pos + else posOfAux (s.next pos) + +@[inline] def posOf (s : String) (c : Char) : Pos := +posOfAux s c s.bsize 0 + +partial def revPosOfAux (s : String) (c : Char) : Pos → Option Pos +| pos => + if s.get pos == c then some pos + else if pos == 0 then none + else revPosOfAux (s.prev pos) + +def revPosOf (s : String) (c : Char) : Option Pos := +if s.bsize == 0 then none +else revPosOfAux s c (s.prev s.bsize) + +private def utf8ExtractAux₂ : List Char → Pos → Pos → List Char +| [], _, _ => [] +| c::cs, i, e => if i = e then [] else c :: utf8ExtractAux₂ cs (i + csize c) e + +private def utf8ExtractAux₁ : List Char → Pos → Pos → Pos → List Char +| [], _, _, _ => [] +| s@(c::cs), i, b, e => if i = b then utf8ExtractAux₂ s i e else utf8ExtractAux₁ cs (i + csize c) b e + +@[extern "lean_string_utf8_extract"] +def extract : (@& String) → (@& Pos) → (@& Pos) → String +| ⟨s⟩, b, e => if b ≥ e then ⟨[]⟩ else ⟨utf8ExtractAux₁ s 0 b e⟩ + +@[specialize] partial def splitAux (s : String) (p : Char → Bool) : Pos → Pos → List String → List String +| b, i, r => + if s.atEnd i then + let r := if p (s.get i) then ""::(s.extract b (i-1))::r else (s.extract b i)::r; + r.reverse + else if p (s.get i) then + let i := s.next i; + splitAux i i (s.extract b (i-1)::r) + else splitAux b (s.next i) r + +@[specialize] def split (s : String) (p : Char → Bool) : List String := +splitAux s p 0 0 [] + +partial def splitOnAux (s sep : String) : Pos → Pos → Pos → List String → List String +| b, i, j, r => + if s.atEnd i then + let r := if sep.atEnd j then ""::(s.extract b (i-j))::r else (s.extract b i)::r; + r.reverse + else if s.get i == sep.get j then + let i := s.next i; + let j := sep.next j; + if sep.atEnd j then splitOnAux i i 0 (s.extract b (i-j)::r) + else splitOnAux b i j r + else splitOnAux b (s.next i) 0 r + +def splitOn (s : String) (sep : String := " ") : List String := +if sep == "" then [s] else splitOnAux s sep 0 0 0 [] + +instance : Inhabited String := +⟨""⟩ + +instance : HasSizeof String := +⟨String.length⟩ + +instance : HasAppend String := +⟨String.append⟩ + +def str : String → Char → String := push + +def pushn (s : String) (c : Char) (n : Nat) : String := +n.repeat (fun s => s.push c) s + +def isEmpty (s : String) : Bool := +s.bsize == 0 + +def join (l : List String) : String := +l.foldl (fun r s => r ++ s) "" + +def singleton (c : Char) : String := +"".push c + +def intercalate (s : String) (ss : List String) : String := +(List.intercalate s.toList (ss.map toList)).asString + +structure Iterator := +(s : String) (i : Pos) + +def mkIterator (s : String) : Iterator := +⟨s, 0⟩ + +namespace Iterator +def toString : Iterator → String +| ⟨s, _⟩ => s + +def remainingBytes : Iterator → Nat +| ⟨s, i⟩ => s.bsize - i + +def pos : Iterator → Pos +| ⟨s, i⟩ => i + +def curr : Iterator → Char +| ⟨s, i⟩ => get s i + +def next : Iterator → Iterator +| ⟨s, i⟩ => ⟨s, s.next i⟩ + +def prev : Iterator → Iterator +| ⟨s, i⟩ => ⟨s, s.prev i⟩ + +def hasNext : Iterator → Bool +| ⟨s, i⟩ => i < utf8ByteSize s + +def hasPrev : Iterator → Bool +| ⟨s, i⟩ => i > 0 + +def setCurr : Iterator → Char → Iterator +| ⟨s, i⟩, c => ⟨s.set i c, i⟩ + +def toEnd : Iterator → Iterator +| ⟨s, _⟩ => ⟨s, s.bsize⟩ + +def extract : Iterator → Iterator → String +| ⟨s₁, b⟩, ⟨s₂, e⟩ => + if s₁ ≠ s₂ || b > e then "" + else s₁.extract b e + +def forward : Iterator → Nat → Iterator +| it, 0 => it +| it, n+1 => forward it.next n + +def remainingToString : Iterator → String +| ⟨s, i⟩ => s.extract i s.bsize + +/- (isPrefixOfRemaining it₁ it₂) is `true` Iff `it₁.remainingToString` is a prefix + of `it₂.remainingToString`. -/ +def isPrefixOfRemaining : Iterator → Iterator → Bool +| ⟨s₁, i₁⟩, ⟨s₂, i₂⟩ => s₁.extract i₁ s₁.bsize = s₂.extract i₂ (i₂ + (s₁.bsize - i₁)) + +def nextn : Iterator → Nat → Iterator +| it, 0 => it +| it, i+1 => nextn it.next i + +def prevn : Iterator → Nat → Iterator +| it, 0 => it +| it, i+1 => prevn it.prev i +end Iterator + +partial def offsetOfPosAux (s : String) (pos : Pos) : Pos → Nat → Nat +| i, offset => + if i == pos || s.atEnd i then offset + else offsetOfPosAux (s.next i) (offset+1) + +def offsetOfPos (s : String) (pos : Pos) : Nat := +offsetOfPosAux s pos 0 0 + +@[specialize] partial def foldlAux {α : Type u} (f : α → Char → α) (s : String) (stopPos : Pos) : Pos → α → α +| i, a => + if i == stopPos then a + else foldlAux (s.next i) (f a (s.get i)) + +@[inline] def foldl {α : Type u} (f : α → Char → α) (a : α) (s : String) : α := +foldlAux f s s.bsize 0 a + +@[specialize] partial def foldrAux {α : Type u} (f : Char → α → α) (a : α) (s : String) (stopPos : Pos) : Pos → α +| i => + if i == stopPos then a + else f (s.get i) (foldrAux (s.next i)) + +@[inline] def foldr {α : Type u} (f : Char → α → α) (a : α) (s : String) : α := +foldrAux f a s s.bsize 0 + +@[specialize] partial def anyAux (s : String) (stopPos : Pos) (p : Char → Bool) : Pos → Bool +| i => + if i == stopPos then false + else if p (s.get i) then true + else anyAux (s.next i) + +@[inline] def any (s : String) (p : Char → Bool) : Bool := +anyAux s s.bsize p 0 + +@[inline] def all (s : String) (p : Char → Bool) : Bool := +!s.any (fun c => !p c) + +def contains (s : String) (c : Char) : Bool := +s.any (fun a => a == c) + +@[specialize] partial def mapAux (f : Char → Char) : Pos → String → String +| i, s => + if s.atEnd i then s + else + let c := f (s.get i); + let s := s.set i c; + mapAux (s.next i) s + +@[inline] def map (f : Char → Char) (s : String) : String := +mapAux f 0 s + +def toNat (s : String) : Nat := +s.foldl (fun n c => n*10 + (c.toNat - '0'.toNat)) 0 + +def isNat (s : String) : Bool := +s.all $ fun c => c.isDigit + +partial def isPrefixOfAux (p s : String) : Pos → Bool +| i => + if p.atEnd i then true + else + let c₁ := p.get i; + let c₂ := s.get i; + c₁ == c₂ && isPrefixOfAux (s.next i) + +/- Return true iff `p` is a prefix of `s` -/ +def isPrefixOf (p : String) (s : String) : Bool := +p.length ≤ s.length && isPrefixOfAux p s 0 + +end String + +namespace Substring + +@[inline] def toString : Substring → String +| ⟨s, b, e⟩ => s.extract b e + +@[inline] def toIterator : Substring → String.Iterator +| ⟨s, b, _⟩ => ⟨s, b⟩ + +@[inline] def get : Substring → String.Pos → Char +| ⟨s, b, _⟩, p => s.get (b+p) + +@[inline] def next : Substring → String.Pos → String.Pos +| ⟨s, b, e⟩, p => + let p := s.next (b+p); + if p > e then e - b else p - b + +@[inline] def prev : Substring → String.Pos → String.Pos +| ⟨s, b, _⟩, p => + if p = b then p else s.prev (b+p) - b + +@[inline] def front (s : Substring) : Char := +s.get 0 + +@[inline] def posOf (s : Substring) (c : Char) : String.Pos := +match s with +| ⟨s, b, e⟩ => (String.posOfAux s c e b) - b + +@[inline] def drop : Substring → Nat → Substring +| ⟨s, b, e⟩, n => + if b + n ≥ e then "".toSubstring + else ⟨s, b+n, e⟩ + +@[inline] def dropRight : Substring → Nat → Substring +| ⟨s, b, e⟩, n => + if e - n ≤ e then "".toSubstring + else ⟨s, b, e - n⟩ + +@[inline] def take : Substring → Nat → Substring +| ⟨s, b, e⟩, n => + let e := if b + n ≥ e then e else b + n; + ⟨s, b, e⟩ + +@[inline] def takeRight : Substring → Nat → Substring +| ⟨s, b, e⟩, n => + let b := if e - n ≤ b then b else e - n; + ⟨s, b, e⟩ + +@[inline] def atEnd : Substring → String.Pos → Bool +| ⟨s, b, e⟩, p => b + p == e + +@[inline] def extract : Substring → String.Pos → String.Pos → Substring +| ⟨s, b, _⟩, b', e' => if b' ≥ e' then ⟨"", 0, 1⟩ else ⟨s, b+b', b+e'⟩ + +partial def splitOnAux (s sep : String) (stopPos : String.Pos) : String.Pos → String.Pos → String.Pos → List Substring → List Substring +| b, i, j, r => + if i == stopPos then + let r := if sep.atEnd j then "".toSubstring::{str := s, startPos := b, stopPos := i-j}::r else {str := s, startPos := b, stopPos := i}::r; + r.reverse + else if s.get i == sep.get j then + let i := s.next i; + let j := sep.next j; + if sep.atEnd j then splitOnAux i i 0 ({str := s, startPos := b, stopPos := i-j}::r) + else splitOnAux b i j r + else splitOnAux b (s.next i) 0 r + +def splitOn (s : Substring) (sep : String := " ") : List Substring := +if sep == "" then [s] else splitOnAux s.str sep s.stopPos s.startPos s.startPos 0 [] + +@[inline] def foldl {α : Type u} (f : α → Char → α) (a : α) (s : Substring) : α := +match s with +| ⟨s, b, e⟩ => String.foldlAux f s e b a + +@[inline] def foldr {α : Type u} (f : Char → α → α) (a : α) (s : Substring) : α := +match s with +| ⟨s, b, e⟩ => String.foldrAux f a s e b + +@[inline] def any (s : Substring) (p : Char → Bool) : Bool := +match s with +| ⟨s, b, e⟩ => String.anyAux s e p b + +@[inline] def all (s : Substring) (p : Char → Bool) : Bool := +!s.any (fun c => !p c) + +def contains (s : Substring) (c : Char) : Bool := +s.any (fun a => a == c) + +@[specialize] partial def takeWhileAux (s : String) (stopPos : String.Pos) (p : Char → Bool) : String.Pos → String.Pos +| i => + if i == stopPos then i + else if p (s.get i) then takeWhileAux (s.next i) + else i + +@[inline] def takeWhile : Substring → (Char → Bool) → Substring +| ⟨s, b, e⟩, p => + let e := takeWhileAux s e p b; + ⟨s, b, e⟩ + +@[inline] def dropWhile : Substring → (Char → Bool) → Substring +| ⟨s, b, e⟩, p => + let b := takeWhileAux s e p b; + ⟨s, b, e⟩ + +@[specialize] partial def takeRightWhileAux (s : String) (begPos : String.Pos) (p : Char → Bool) : String.Pos → String.Pos +| i => + if i == begPos then i + else + let i' := s.prev i; + let c := s.get i'; + if !p c then i + else takeRightWhileAux i' + +@[inline] def takeRightWhile : Substring → (Char → Bool) → Substring +| ⟨s, b, e⟩, p => + let b := takeRightWhileAux s b p e; + ⟨s, b, e⟩ + +@[inline] def dropRightWhile : Substring → (Char → Bool) → Substring +| ⟨s, b, e⟩, p => + let e := takeRightWhileAux s b p e; + ⟨s, b, e⟩ + +@[inline] def trimLeft (s : Substring) : Substring := +s.dropWhile Char.isWhitespace + +@[inline] def trimRight (s : Substring) : Substring := +s.dropRightWhile Char.isWhitespace + +@[inline] def trim : Substring → Substring +| ⟨s, b, e⟩ => + let b := takeWhileAux s e Char.isWhitespace b; + let e := takeRightWhileAux s b Char.isWhitespace e; + ⟨s, b, e⟩ + +def toNat (s : Substring) : Nat := +s.foldl (fun n c => n*10 + (c.toNat - '0'.toNat)) 0 + +def isNat (s : Substring) : Bool := +s.all $ fun c => c.isDigit + +end Substring + +namespace String + +def drop (s : String) (n : Nat) : String := +(s.toSubstring.drop n).toString + +def dropRight (s : String) (n : Nat) : String := +(s.toSubstring.dropRight n).toString + +def take (s : String) (n : Nat) : String := +(s.toSubstring.take n).toString + +def takeRight (s : String) (n : Nat) : String := +(s.toSubstring.takeRight n).toString + +def takeWhile (s : String) (p : Char → Bool) : String := +(s.toSubstring.takeWhile p).toString + +def dropWhile (s : String) (p : Char → Bool) : String := +(s.toSubstring.dropWhile p).toString + +def trimRight (s : String) : String := +s.toSubstring.trimRight.toString + +def trimLeft (s : String) : String := +s.toSubstring.trimLeft.toString + +def trim (s : String) : String := +s.toSubstring.trim.toString + +end String + +protected def Char.toString (c : Char) : String := +String.singleton c diff --git a/stage0/src/Init/Data/ToString.lean b/stage0/src/Init/Data/ToString.lean new file mode 100644 index 0000000000..5eca7af4ac --- /dev/null +++ b/stage0/src/Init/Data/ToString.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.String.Basic +import Init.Data.UInt +import Init.Data.Nat.Div +import Init.Data.Repr +open Sum Subtype Nat + +universes u v + +class HasToString (α : Type u) := +(toString : α → String) + +export HasToString (toString) + +-- This instance is needed because `id` is not reducible +instance {α : Type u} [HasToString α] : HasToString (id α) := +inferInstanceAs (HasToString α) + +instance : HasToString String := +⟨fun s => s⟩ + +instance : HasToString Substring := +⟨fun s => s.toString⟩ + +instance : HasToString String.Iterator := +⟨fun it => it.remainingToString⟩ + +instance : HasToString Bool := +⟨fun b => cond b "true" "false"⟩ + +instance {p : Prop} : HasToString (Decidable p) := +-- Remark: type class inference will not consider local instance `b` in the new Elaborator +⟨fun b => @ite p b _ "true" "false"⟩ + +protected def List.toStringAux {α : Type u} [HasToString α] : Bool → List α → String +| b, [] => "" +| true, x::xs => toString x ++ List.toStringAux false xs +| false, x::xs => ", " ++ toString x ++ List.toStringAux false xs + +protected def List.toString {α : Type u} [HasToString α] : List α → String +| [] => "[]" +| x::xs => "[" ++ List.toStringAux true (x::xs) ++ "]" + +instance {α : Type u} [HasToString α] : HasToString (List α) := +⟨List.toString⟩ + +instance : HasToString Unit := +⟨fun u => "()"⟩ + +instance : HasToString Nat := +⟨fun n => repr n⟩ + +instance : HasToString Char := +⟨fun c => c.toString⟩ + +instance (n : Nat) : HasToString (Fin n) := +⟨fun f => toString (Fin.val f)⟩ + +instance : HasToString UInt8 := +⟨fun n => toString n.toNat⟩ + +instance : HasToString UInt16 := +⟨fun n => toString n.toNat⟩ + +instance : HasToString UInt32 := +⟨fun n => toString n.toNat⟩ + +instance : HasToString UInt64 := +⟨fun n => toString n.toNat⟩ + +instance : HasToString USize := +⟨fun n => toString n.toNat⟩ + +def addParenHeuristic (s : String) : String := +if "(".isPrefixOf s || "[".isPrefixOf s || "{".isPrefixOf s || "#[".isPrefixOf s then s +else if !s.any Char.isWhitespace then s +else "(" ++ s ++ ")" + +instance {α : Type u} [HasToString α] : HasToString (Option α) := +⟨fun o => match o with | none => "none" | (some a) => "(some " ++ addParenHeuristic (toString a) ++ ")"⟩ + +instance {α : Type u} {β : Type v} [HasToString α] [HasToString β] : HasToString (Sum α β) := +⟨fun s => match s with | (inl a) => "(inl " ++ addParenHeuristic (toString a) ++ ")" | (inr b) => "(inr " ++ addParenHeuristic (toString b) ++ ")"⟩ + +instance {α : Type u} {β : Type v} [HasToString α] [HasToString β] : HasToString (α × β) := +⟨fun ⟨a, b⟩ => "(" ++ toString a ++ ", " ++ toString b ++ ")"⟩ + +instance {α : Type u} {β : α → Type v} [HasToString α] [s : ∀ x, HasToString (β x)] : HasToString (Sigma β) := +⟨fun ⟨a, b⟩ => "⟨" ++ toString a ++ ", " ++ toString b ++ "⟩"⟩ + +instance {α : Type u} {p : α → Prop} [HasToString α] : HasToString (Subtype p) := +⟨fun s => toString (val s)⟩ diff --git a/stage0/src/Init/Data/UInt.lean b/stage0/src/Init/Data/UInt.lean new file mode 100644 index 0000000000..f664d20ca0 --- /dev/null +++ b/stage0/src/Init/Data/UInt.lean @@ -0,0 +1,340 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Fin.Basic +import Init.System.Platform + +open Nat + +def uint8Sz : Nat := 256 +structure UInt8 := +(val : Fin uint8Sz) + +@[extern "lean_uint8_of_nat"] +def UInt8.ofNat (n : @& Nat) : UInt8 := ⟨Fin.ofNat n⟩ +abbrev Nat.toUInt8 := UInt8.ofNat +@[extern "lean_uint8_to_nat"] +def UInt8.toNat (n : UInt8) : Nat := n.val.val +@[extern c inline "#1 + #2"] +def UInt8.add (a b : UInt8) : UInt8 := ⟨a.val + b.val⟩ +@[extern c inline "#1 - #2"] +def UInt8.sub (a b : UInt8) : UInt8 := ⟨a.val - b.val⟩ +@[extern c inline "#1 * #2"] +def UInt8.mul (a b : UInt8) : UInt8 := ⟨a.val * b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 / #2"] +def UInt8.div (a b : UInt8) : UInt8 := ⟨a.val / b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 % #2"] +def UInt8.mod (a b : UInt8) : UInt8 := ⟨a.val % b.val⟩ +@[extern "lean_uint8_modn"] +def UInt8.modn (a : UInt8) (n : @& Nat) : UInt8 := ⟨a.val %ₙ n⟩ +@[extern c inline "#1 & #2"] +def UInt8.land (a b : UInt8) : UInt8 := ⟨Fin.land a.val b.val⟩ +@[extern c inline "#1 | #2"] +def UInt8.lor (a b : UInt8) : UInt8 := ⟨Fin.lor a.val b.val⟩ +def UInt8.lt (a b : UInt8) : Prop := a.val < b.val +def UInt8.le (a b : UInt8) : Prop := a.val ≤ b.val + +instance : HasZero UInt8 := ⟨UInt8.ofNat 0⟩ +instance : HasOne UInt8 := ⟨UInt8.ofNat 1⟩ +instance : HasAdd UInt8 := ⟨UInt8.add⟩ +instance : HasSub UInt8 := ⟨UInt8.sub⟩ +instance : HasMul UInt8 := ⟨UInt8.mul⟩ +instance : HasMod UInt8 := ⟨UInt8.mod⟩ +instance : HasModn UInt8 := ⟨UInt8.modn⟩ +instance : HasDiv UInt8 := ⟨UInt8.div⟩ +instance : HasLess UInt8 := ⟨UInt8.lt⟩ +instance : HasLessEq UInt8 := ⟨UInt8.le⟩ +instance : Inhabited UInt8 := ⟨0⟩ + +@[extern c inline "#1 == #2"] +def UInt8.decEq (a b : UInt8) : Decidable (a = b) := +UInt8.casesOn a $ fun n => UInt8.casesOn b $ fun m => + if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt8.noConfusion h' (fun h' => absurd h' h)) + +@[extern c inline "#1 < #2"] +def UInt8.decLt (a b : UInt8) : Decidable (a < b) := +UInt8.casesOn a $ fun n => UInt8.casesOn b $ fun m => + inferInstanceAs (Decidable (n < m)) + +@[extern c inline "#1 <= #2"] +def UInt8.decLe (a b : UInt8) : Decidable (a ≤ b) := +UInt8.casesOn a $ fun n => UInt8.casesOn b $ fun m => + inferInstanceAs (Decidable (n <= m)) + +instance : DecidableEq UInt8 := {decEq := UInt8.decEq} +instance UInt8.hasDecidableLt (a b : UInt8) : Decidable (a < b) := UInt8.decLt a b +instance UInt8.hasDecidableLe (a b : UInt8) : Decidable (a ≤ b) := UInt8.decLe a b + +def uint16Sz : Nat := 65536 +structure UInt16 := +(val : Fin uint16Sz) + +@[extern "lean_uint16_of_nat"] +def UInt16.ofNat (n : @& Nat) : UInt16 := ⟨Fin.ofNat n⟩ +abbrev Nat.toUInt16 := UInt16.ofNat +@[extern "lean_uint16_to_nat"] +def UInt16.toNat (n : UInt16) : Nat := n.val.val +@[extern c inline "#1 + #2"] +def UInt16.add (a b : UInt16) : UInt16 := ⟨a.val + b.val⟩ +@[extern c inline "#1 - #2"] +def UInt16.sub (a b : UInt16) : UInt16 := ⟨a.val - b.val⟩ +@[extern c inline "#1 * #2"] +def UInt16.mul (a b : UInt16) : UInt16 := ⟨a.val * b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 / #2"] +def UInt16.div (a b : UInt16) : UInt16 := ⟨a.val / b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 % #2"] +def UInt16.mod (a b : UInt16) : UInt16 := ⟨a.val % b.val⟩ +@[extern "lean_uint16_modn"] +def UInt16.modn (a : UInt16) (n : @& Nat) : UInt16 := ⟨a.val %ₙ n⟩ +@[extern c inline "#1 & #2"] +def UInt16.land (a b : UInt16) : UInt16 := ⟨Fin.land a.val b.val⟩ +@[extern c inline "#1 | #2"] +def UInt16.lor (a b : UInt16) : UInt16 := ⟨Fin.lor a.val b.val⟩ +def UInt16.lt (a b : UInt16) : Prop := a.val < b.val +def UInt16.le (a b : UInt16) : Prop := a.val ≤ b.val + +instance : HasZero UInt16 := ⟨UInt16.ofNat 0⟩ +instance : HasOne UInt16 := ⟨UInt16.ofNat 1⟩ +instance : HasAdd UInt16 := ⟨UInt16.add⟩ +instance : HasSub UInt16 := ⟨UInt16.sub⟩ +instance : HasMul UInt16 := ⟨UInt16.mul⟩ +instance : HasMod UInt16 := ⟨UInt16.mod⟩ +instance : HasModn UInt16 := ⟨UInt16.modn⟩ +instance : HasDiv UInt16 := ⟨UInt16.div⟩ +instance : HasLess UInt16 := ⟨UInt16.lt⟩ +instance : HasLessEq UInt16 := ⟨UInt16.le⟩ +instance : Inhabited UInt16 := ⟨0⟩ + +@[extern c inline "#1 == #2"] +def UInt16.decEq (a b : UInt16) : Decidable (a = b) := +UInt16.casesOn a $ fun n => UInt16.casesOn b $ fun m => + if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt16.noConfusion h' (fun h' => absurd h' h)) + +@[extern c inline "#1 < #2"] +def UInt16.decLt (a b : UInt16) : Decidable (a < b) := +UInt16.casesOn a $ fun n => UInt16.casesOn b $ fun m => + inferInstanceAs (Decidable (n < m)) + +@[extern c inline "#1 <= #2"] +def UInt16.decLe (a b : UInt16) : Decidable (a ≤ b) := +UInt16.casesOn a $ fun n => UInt16.casesOn b $ fun m => + inferInstanceAs (Decidable (n <= m)) + +instance : DecidableEq UInt16 := {decEq := UInt16.decEq} +instance UInt16.hasDecidableLt (a b : UInt16) : Decidable (a < b) := UInt16.decLt a b +instance UInt16.hasDecidableLe (a b : UInt16) : Decidable (a ≤ b) := UInt16.decLe a b + +def uint32Sz : Nat := 4294967296 +structure UInt32 := +(val : Fin uint32Sz) + +@[extern "lean_uint32_of_nat"] +def UInt32.ofNat (n : @& Nat) : UInt32 := ⟨Fin.ofNat n⟩ +abbrev Nat.toUInt32 := UInt32.ofNat +@[extern "lean_uint32_to_nat"] +def UInt32.toNat (n : UInt32) : Nat := n.val.val +@[extern c inline "#1 + #2"] +def UInt32.add (a b : UInt32) : UInt32 := ⟨a.val + b.val⟩ +@[extern c inline "#1 - #2"] +def UInt32.sub (a b : UInt32) : UInt32 := ⟨a.val - b.val⟩ +@[extern c inline "#1 * #2"] +def UInt32.mul (a b : UInt32) : UInt32 := ⟨a.val * b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 / #2"] +def UInt32.div (a b : UInt32) : UInt32 := ⟨a.val / b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 % #2"] +def UInt32.mod (a b : UInt32) : UInt32 := ⟨a.val % b.val⟩ +@[extern "lean_uint32_modn"] +def UInt32.modn (a : UInt32) (n : @& Nat) : UInt32 := ⟨a.val %ₙ n⟩ +@[extern c inline "#1 & #2"] +def UInt32.land (a b : UInt32) : UInt32 := ⟨Fin.land a.val b.val⟩ +@[extern c inline "#1 | #2"] +def UInt32.lor (a b : UInt32) : UInt32 := ⟨Fin.lor a.val b.val⟩ +def UInt32.lt (a b : UInt32) : Prop := a.val < b.val +def UInt32.le (a b : UInt32) : Prop := a.val ≤ b.val + +instance : HasZero UInt32 := ⟨UInt32.ofNat 0⟩ +instance : HasOne UInt32 := ⟨UInt32.ofNat 1⟩ +instance : HasAdd UInt32 := ⟨UInt32.add⟩ +instance : HasSub UInt32 := ⟨UInt32.sub⟩ +instance : HasMul UInt32 := ⟨UInt32.mul⟩ +instance : HasMod UInt32 := ⟨UInt32.mod⟩ +instance : HasModn UInt32 := ⟨UInt32.modn⟩ +instance : HasDiv UInt32 := ⟨UInt32.div⟩ +instance : HasLess UInt32 := ⟨UInt32.lt⟩ +instance : HasLessEq UInt32 := ⟨UInt32.le⟩ +instance : Inhabited UInt32 := ⟨0⟩ + +@[extern c inline "#1 == #2"] +def UInt32.decEq (a b : UInt32) : Decidable (a = b) := +UInt32.casesOn a $ fun n => UInt32.casesOn b $ fun m => + if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt32.noConfusion h' (fun h' => absurd h' h)) + +@[extern c inline "#1 < #2"] +def UInt32.decLt (a b : UInt32) : Decidable (a < b) := +UInt32.casesOn a $ fun n => UInt32.casesOn b $ fun m => + inferInstanceAs (Decidable (n < m)) + +@[extern c inline "#1 <= #2"] +def UInt32.decLe (a b : UInt32) : Decidable (a ≤ b) := +UInt32.casesOn a $ fun n => UInt32.casesOn b $ fun m => + inferInstanceAs (Decidable (n <= m)) + +instance : DecidableEq UInt32 := {decEq := UInt32.decEq} +instance UInt32.hasDecidableLt (a b : UInt32) : Decidable (a < b) := UInt32.decLt a b +instance UInt32.hasDecidableLe (a b : UInt32) : Decidable (a ≤ b) := UInt32.decLe a b + +def uint64Sz : Nat := 18446744073709551616 +structure UInt64 := +(val : Fin uint64Sz) + +@[extern "lean_uint64_of_nat"] +def UInt64.ofNat (n : @& Nat) : UInt64 := ⟨Fin.ofNat n⟩ +abbrev Nat.toUInt64 := UInt64.ofNat +@[extern "lean_uint64_to_nat"] +def UInt64.toNat (n : UInt64) : Nat := n.val.val +@[extern c inline "#1 + #2"] +def UInt64.add (a b : UInt64) : UInt64 := ⟨a.val + b.val⟩ +@[extern c inline "#1 - #2"] +def UInt64.sub (a b : UInt64) : UInt64 := ⟨a.val - b.val⟩ +@[extern c inline "#1 * #2"] +def UInt64.mul (a b : UInt64) : UInt64 := ⟨a.val * b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 / #2"] +def UInt64.div (a b : UInt64) : UInt64 := ⟨a.val / b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 % #2"] +def UInt64.mod (a b : UInt64) : UInt64 := ⟨a.val % b.val⟩ +@[extern "lean_uint64_modn"] +def UInt64.modn (a : UInt64) (n : @& Nat) : UInt64 := ⟨a.val %ₙ n⟩ +@[extern c inline "#1 & #2"] +def UInt64.land (a b : UInt64) : UInt64 := ⟨Fin.land a.val b.val⟩ +@[extern c inline "#1 | #2"] +def UInt64.lor (a b : UInt64) : UInt64 := ⟨Fin.lor a.val b.val⟩ +def UInt64.lt (a b : UInt64) : Prop := a.val < b.val +def UInt64.le (a b : UInt64) : Prop := a.val ≤ b.val +@[extern c inline "((uint8_t)#1)"] +def UInt64.toUInt8 (a : UInt64) : UInt8 := a.toNat.toUInt8 +@[extern c inline "((uint16_t)#1)"] +def UInt64.toUInt16 (a : UInt64) : UInt16 := a.toNat.toUInt16 +@[extern c inline "((uint32_t)#1)"] +def UInt64.toUInt32 (a : UInt64) : UInt32 := a.toNat.toUInt32 +@[extern c inline "((uint64_t)#1)"] +def UInt32.toUInt64 (a : UInt32) : UInt64 := a.toNat.toUInt64 + +-- TODO(Leo): give reference implementation for shiftLeft and shiftRight, and define them for other UInt types +@[extern c inline "#1 << #2"] +constant UInt64.shiftLeft (a b : UInt64) : UInt64 := (arbitrary Nat).toUInt64 +@[extern c inline "#1 >> #2"] +constant UInt64.shiftRight (a b : UInt64) : UInt64 := (arbitrary Nat).toUInt64 + +instance : HasZero UInt64 := ⟨UInt64.ofNat 0⟩ +instance : HasOne UInt64 := ⟨UInt64.ofNat 1⟩ +instance : HasAdd UInt64 := ⟨UInt64.add⟩ +instance : HasSub UInt64 := ⟨UInt64.sub⟩ +instance : HasMul UInt64 := ⟨UInt64.mul⟩ +instance : HasMod UInt64 := ⟨UInt64.mod⟩ +instance : HasModn UInt64 := ⟨UInt64.modn⟩ +instance : HasDiv UInt64 := ⟨UInt64.div⟩ +instance : HasLess UInt64 := ⟨UInt64.lt⟩ +instance : HasLessEq UInt64 := ⟨UInt64.le⟩ +instance : Inhabited UInt64 := ⟨0⟩ + +@[extern c inline "(uint64_t)#1"] +def Bool.toUInt64 (b : Bool) : UInt64 := if b then 1 else 0 + +@[extern c inline "#1 == #2"] +def UInt64.decEq (a b : UInt64) : Decidable (a = b) := +UInt64.casesOn a $ fun n => UInt64.casesOn b $ fun m => + if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt64.noConfusion h' (fun h' => absurd h' h)) + +@[extern c inline "#1 < #2"] +def UInt64.decLt (a b : UInt64) : Decidable (a < b) := +UInt64.casesOn a $ fun n => UInt64.casesOn b $ fun m => + inferInstanceAs (Decidable (n < m)) + +@[extern c inline "#1 <= #2"] +def UInt64.decLe (a b : UInt64) : Decidable (a ≤ b) := +UInt64.casesOn a $ fun n => UInt64.casesOn b $ fun m => + inferInstanceAs (Decidable (n <= m)) + +instance : DecidableEq UInt64 := {decEq := UInt64.decEq} +instance UInt64.hasDecidableLt (a b : UInt64) : Decidable (a < b) := UInt64.decLt a b +instance UInt64.hasDecidableLe (a b : UInt64) : Decidable (a ≤ b) := UInt64.decLe a b + +def usizeSz : Nat := (2:Nat) ^ System.Platform.numBits +structure USize := +(val : Fin usizeSz) + +theorem usizeSzGt0 : usizeSz > 0 := +Nat.posPowOfPos System.Platform.numBits (Nat.zeroLtSucc _) + +@[extern "lean_usize_of_nat"] +def USize.ofNat (n : @& Nat) : USize := ⟨Fin.ofNat' n usizeSzGt0⟩ +abbrev Nat.toUSize := USize.ofNat +@[extern "lean_usize_to_nat"] +def USize.toNat (n : USize) : Nat := n.val.val +@[extern c inline "#1 + #2"] +def USize.add (a b : USize) : USize := ⟨a.val + b.val⟩ +@[extern c inline "#1 - #2"] +def USize.sub (a b : USize) : USize := ⟨a.val - b.val⟩ +@[extern c inline "#1 * #2"] +def USize.mul (a b : USize) : USize := ⟨a.val * b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 / #2"] +def USize.div (a b : USize) : USize := ⟨a.val / b.val⟩ +@[extern c inline "#2 == 0 ? 0 : #1 % #2"] +def USize.mod (a b : USize) : USize := ⟨a.val % b.val⟩ +@[extern "lean_usize_modn"] +def USize.modn (a : USize) (n : @& Nat) : USize := ⟨a.val %ₙ n⟩ +@[extern c inline "#1 & #2"] +def USize.land (a b : USize) : USize := ⟨Fin.land a.val b.val⟩ +@[extern c inline "#1 | #2"] +def USize.lor (a b : USize) : USize := ⟨Fin.lor a.val b.val⟩ +@[extern c inline "#1"] +def UInt32.toUSize (a : UInt32) : USize := a.toNat.toUSize +@[extern c inline "((size_t)#1)"] +def UInt64.toUSize (a : UInt64) : USize := a.toNat.toUSize +@[extern c inline "(uint32_t)#1"] +def USize.toUInt32 (a : USize) : UInt32 := a.toNat.toUInt32 + +-- TODO(Leo): give reference implementation for shiftLeft and shiftRight, and define them for other UInt types +@[extern c inline "#1 << #2"] +constant USize.shiftLeft (a b : USize) : USize := (arbitrary Nat).toUSize +@[extern c inline "#1 >> #2"] +constant USize.shiftRight (a b : USize) : USize := (arbitrary Nat).toUSize +def USize.lt (a b : USize) : Prop := a.val < b.val +def USize.le (a b : USize) : Prop := a.val ≤ b.val + +instance : HasZero USize := ⟨USize.ofNat 0⟩ +instance : HasOne USize := ⟨USize.ofNat 1⟩ +instance : HasAdd USize := ⟨USize.add⟩ +instance : HasSub USize := ⟨USize.sub⟩ +instance : HasMul USize := ⟨USize.mul⟩ +instance : HasMod USize := ⟨USize.mod⟩ +instance : HasModn USize := ⟨USize.modn⟩ +instance : HasDiv USize := ⟨USize.div⟩ +instance : HasLess USize := ⟨USize.lt⟩ +instance : HasLessEq USize := ⟨USize.le⟩ +instance : Inhabited USize := ⟨0⟩ + +@[extern c inline "#1 == #2"] +def USize.decEq (a b : USize) : Decidable (a = b) := +USize.casesOn a $ fun n => USize.casesOn b $ fun m => + if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => USize.noConfusion h' (fun h' => absurd h' h)) + +@[extern c inline "#1 < #2"] +def USize.decLt (a b : USize) : Decidable (a < b) := +USize.casesOn a $ fun n => USize.casesOn b $ fun m => + inferInstanceAs (Decidable (n < m)) + +@[extern c inline "#1 <= #2"] +def USize.decLe (a b : USize) : Decidable (a ≤ b) := +USize.casesOn a $ fun n => USize.casesOn b $ fun m => + inferInstanceAs (Decidable (n <= m)) + +instance : DecidableEq USize := {decEq := USize.decEq} +instance USize.hasDecidableLt (a b : USize) : Decidable (a < b) := USize.decLt a b +instance USize.hasDecidableLe (a b : USize) : Decidable (a ≤ b) := USize.decLe a b + +theorem USize.modnLt {m : Nat} : ∀ (u : USize), m > 0 → USize.toNat (u %ₙ m) < m +| ⟨u⟩, h => Fin.modnLt u h diff --git a/stage0/src/Init/Default.lean b/stage0/src/Init/Default.lean new file mode 100644 index 0000000000..2b16aeac7a --- /dev/null +++ b/stage0/src/Init/Default.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Core +import Init.Control +import Init.Data.Basic +import Init.Coe +import Init.WF +import Init.Data +import Init.System +import Init.Util +import Init.Fix diff --git a/stage0/src/Init/Fix.lean b/stage0/src/Init/Fix.lean new file mode 100644 index 0000000000..90f1a91a89 --- /dev/null +++ b/stage0/src/Init/Fix.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.UInt +universe u + +def bfix1 {α β : Type u} (base : α → β) (rec : (α → β) → α → β) : Nat → α → β +| 0, a => base a +| n+1, a => rec (bfix1 n) a + +@[extern c inline "lean_fixpoint(#4, #5)"] +def fixCore1 {α β : Type u} (base : @& (α → β)) (rec : (α → β) → α → β) : α → β := +bfix1 base rec usizeSz + +@[inline] def fixCore {α β : Type u} (base : @& (α → β)) (rec : (α → β) → α → β) : α → β := +fixCore1 base rec + +@[inline] def fix1 {α β : Type u} [Inhabited β] (rec : (α → β) → α → β) : α → β := +fixCore1 (fun _ => arbitrary β) rec + +@[inline] def fix {α β : Type u} [Inhabited β] (rec : (α → β) → α → β) : α → β := +fixCore1 (fun _ => arbitrary β) rec + +def bfix2 {α₁ α₂ β : Type u} (base : α₁ → α₂ → β) (rec : (α₁ → α₂ → β) → α₁ → α₂ → β) : Nat → α₁ → α₂ → β +| 0, a₁, a₂ => base a₁ a₂ +| n+1, a₁, a₂ => rec (bfix2 n) a₁ a₂ + +@[extern c inline "lean_fixpoint2(#5, #6, #7)"] +def fixCore2 {α₁ α₂ β : Type u} (base : α₁ → α₂ → β) (rec : (α₁ → α₂ → β) → α₁ → α₂ → β) : α₁ → α₂ → β := +bfix2 base rec usizeSz + +@[inline] def fix2 {α₁ α₂ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → β) → α₁ → α₂ → β) : α₁ → α₂ → β := +fixCore2 (fun _ _ => arbitrary β) rec + +def bfix3 {α₁ α₂ α₃ β : Type u} (base : α₁ → α₂ → α₃ → β) (rec : (α₁ → α₂ → α₃ → β) → α₁ → α₂ → α₃ → β) : Nat → α₁ → α₂ → α₃ → β +| 0, a₁, a₂, a₃ => base a₁ a₂ a₃ +| n+1, a₁, a₂, a₃ => rec (bfix3 n) a₁ a₂ a₃ + +@[extern c inline "lean_fixpoint3(#6, #7, #8, #9)"] +def fixCore3 {α₁ α₂ α₃ β : Type u} (base : α₁ → α₂ → α₃ → β) (rec : (α₁ → α₂ → α₃ → β) → α₁ → α₂ → α₃ → β) : α₁ → α₂ → α₃ → β := +bfix3 base rec usizeSz + +@[inline] def fix3 {α₁ α₂ α₃ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → β) → α₁ → α₂ → α₃ → β) : α₁ → α₂ → α₃ → β := +fixCore3 (fun _ _ _ => arbitrary β) rec + +def bfix4 {α₁ α₂ α₃ α₄ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → β) (rec : (α₁ → α₂ → α₃ → α₄ → β) → α₁ → α₂ → α₃ → α₄ → β) : Nat → α₁ → α₂ → α₃ → α₄ → β +| 0, a₁, a₂, a₃, a₄ => base a₁ a₂ a₃ a₄ +| n+1, a₁, a₂, a₃, a₄ => rec (bfix4 n) a₁ a₂ a₃ a₄ + +@[extern c inline "lean_fixpoint4(#7, #8, #9, #10, #11)"] +def fixCore4 {α₁ α₂ α₃ α₄ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → β) (rec : (α₁ → α₂ → α₃ → α₄ → β) → α₁ → α₂ → α₃ → α₄ → β) : α₁ → α₂ → α₃ → α₄ → β := +bfix4 base rec usizeSz + +@[inline] def fix4 {α₁ α₂ α₃ α₄ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → α₄ → β) → α₁ → α₂ → α₃ → α₄ → β) : α₁ → α₂ → α₃ → α₄ → β := +fixCore4 (fun _ _ _ _ => arbitrary β) rec + +def bfix5 {α₁ α₂ α₃ α₄ α₅ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → β) : Nat → α₁ → α₂ → α₃ → α₄ → α₅ → β +| 0, a₁, a₂, a₃, a₄, a₅ => base a₁ a₂ a₃ a₄ a₅ +| n+1, a₁, a₂, a₃, a₄, a₅ => rec (bfix5 n) a₁ a₂ a₃ a₄ a₅ + +@[extern c inline "lean_fixpoint5(#8, #9, #10, #11, #12, #13)"] +def fixCore5 {α₁ α₂ α₃ α₄ α₅ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → β := +bfix5 base rec usizeSz + +@[inline] def fix5 {α₁ α₂ α₃ α₄ α₅ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → β := +fixCore5 (fun _ _ _ _ _ => arbitrary β) rec + +def bfix6 {α₁ α₂ α₃ α₄ α₅ α₆ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) : Nat → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β +| 0, a₁, a₂, a₃, a₄, a₅, a₆ => base a₁ a₂ a₃ a₄ a₅ a₆ +| n+1, a₁, a₂, a₃, a₄, a₅, a₆ => rec (bfix6 n) a₁ a₂ a₃ a₄ a₅ a₆ + +@[extern c inline "lean_fixpoint6(#9, #10, #11, #12, #13, #14, #15)"] +def fixCore6 {α₁ α₂ α₃ α₄ α₅ α₆ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β := +bfix6 base rec usizeSz + +@[inline] def fix6 {α₁ α₂ α₃ α₄ α₅ α₆ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β := +fixCore6 (fun _ _ _ _ _ _ => arbitrary β) rec diff --git a/stage0/src/Init/Lean.lean b/stage0/src/Init/Lean.lean new file mode 100644 index 0000000000..dff3747ac2 --- /dev/null +++ b/stage0/src/Init/Lean.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Path +import Init.Lean.Compiler +import Init.Lean.Environment +import Init.Lean.Modifiers +import Init.Lean.ProjFns +import Init.Lean.Runtime +import Init.Lean.Attributes +import Init.Lean.Parser +import Init.Lean.ReducibilityAttrs +import Init.Lean.Elaborator +import Init.Lean.EqnCompiler +import Init.Lean.Class +import Init.Lean.LocalContext +import Init.Lean.MetavarContext +import Init.Lean.TypeClass +import Init.Lean.Trace +import Init.Lean.AuxRecursor +import Init.Lean.Linter +import Init.Lean.Meta diff --git a/stage0/src/Init/Lean/Attributes.lean b/stage0/src/Init/Lean/Attributes.lean new file mode 100644 index 0000000000..a6baafe245 --- /dev/null +++ b/stage0/src/Init/Lean/Attributes.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Scopes +import Init.Lean.Syntax + +namespace Lean + +inductive AttributeApplicationTime +| afterTypeChecking | afterCompilation | beforeElaboration + +structure AttributeImpl := +(name : Name) +(descr : String) +(add (env : Environment) (decl : Name) (args : Syntax) (persistent : Bool) : IO Environment) +(addScoped (env : Environment) (decl : Name) (args : Syntax) : IO Environment + := throw (IO.userError ("attribute '" ++ toString name ++ "' does not support scopes"))) +(erase (env : Environment) (decl : Name) (persistent : Bool) : IO Environment + := throw (IO.userError ("attribute '" ++ toString name ++ "' does not support removal"))) +(activateScoped (env : Environment) (scope : Name) : IO Environment := pure env) +(pushScope (env : Environment) : IO Environment := pure env) +(popScope (env : Environment) : IO Environment := pure env) +(applicationTime := AttributeApplicationTime.afterTypeChecking) + +instance AttributeImpl.inhabited : Inhabited AttributeImpl := +⟨{ name := arbitrary _, descr := arbitrary _, add := fun env _ _ _ => pure env }⟩ + +def mkAttributeMapRef : IO (IO.Ref (HashMap Name AttributeImpl)) := +IO.mkRef {} + +@[init mkAttributeMapRef] +constant attributeMapRef : IO.Ref (HashMap Name AttributeImpl) := arbitrary _ + +def mkAttributeArrayRef : IO (IO.Ref (Array AttributeImpl)) := +IO.mkRef #[] + +@[init mkAttributeArrayRef] +constant attributeArrayRef : IO.Ref (Array AttributeImpl) := arbitrary _ + +/- Low level attribute registration function. -/ +def registerAttribute (attr : AttributeImpl) : IO Unit := +do m ← attributeMapRef.get; + when (m.contains attr.name) $ throw (IO.userError ("invalid attribute declaration, '" ++ toString attr.name ++ "' has already been used")); + initializing ← IO.initializing; + unless initializing $ throw (IO.userError ("failed to register attribute, attributes can only be registered during initialization")); + attributeMapRef.modify (fun m => m.insert attr.name attr); + attributeArrayRef.modify (fun attrs => attrs.push attr) + +/- Return true iff `n` is the name of a registered attribute. -/ +@[export lean_is_attribute] +def isAttribute (n : Name) : IO Bool := +do m ← attributeMapRef.get; pure (m.contains n) + +/- Return the name of all registered attributes. -/ +def getAttributeNames : IO (List Name) := +do m ← attributeMapRef.get; pure $ m.fold (fun r n _ => n::r) [] + +def getAttributeImpl (attrName : Name) : IO AttributeImpl := +do m ← attributeMapRef.get; + match m.find attrName with + | some attr => pure attr + | none => throw (IO.userError ("unknown attribute '" ++ toString attrName ++ "'")) + +@[export lean_attribute_application_time] +def attributeApplicationTime (n : Name) : IO AttributeApplicationTime := +do attr ← getAttributeImpl n; + pure attr.applicationTime + +namespace Environment + +/- Add attribute `attr` to declaration `decl` with arguments `args`. If `persistent == true`, then attribute is saved on .olean file. + It throws an error when + - `attr` is not the name of an attribute registered in the system. + - `attr` does not support `persistent == false`. + - `args` is not valid for `attr`. -/ +@[export lean_add_attribute] +def addAttribute (env : Environment) (decl : Name) (attrName : Name) (args : Syntax := Syntax.missing) (persistent := true) : IO Environment := +do attr ← getAttributeImpl attrName; + attr.add env decl args persistent + +/- Add a scoped attribute `attr` to declaration `decl` with arguments `args` and scope `decl.getPrefix`. + Scoped attributes are always persistent. + It returns `Except.error` when + - `attr` is not the name of an attribute registered in the system. + - `attr` does not support scoped attributes. + - `args` is not valid for `attr`. + + Remark: the attribute will not be activated if `decl` is not inside the current namespace `env.getNamespace`. -/ +@[export lean_add_scoped_attribute] +def addScopedAttribute (env : Environment) (decl : Name) (attrName : Name) (args : Syntax := Syntax.missing) : IO Environment := +do attr ← getAttributeImpl attrName; + attr.addScoped env decl args + +/- Remove attribute `attr` from declaration `decl`. The effect is the current scope. + It returns `Except.error` when + - `attr` is not the name of an attribute registered in the system. + - `attr` does not support erasure. + - `args` is not valid for `attr`. -/ +@[export lean_erase_attribute] +def eraseAttribute (env : Environment) (decl : Name) (attrName : Name) (persistent := true) : IO Environment := +do attr ← getAttributeImpl attrName; + attr.erase env decl persistent + +/- Activate the scoped attribute `attr` for all declarations in scope `scope`. + We use this function to implement the command `open foo`. -/ +@[export lean_activate_scoped_attribute] +def activateScopedAttribute (env : Environment) (attrName : Name) (scope : Name) : IO Environment := +do attr ← getAttributeImpl attrName; + attr.activateScoped env scope + +/- Activate all scoped attributes at `scope` -/ +@[export lean_activate_scoped_attributes] +def activateScopedAttributes (env : Environment) (scope : Name) : IO Environment := +do attrs ← attributeArrayRef.get; + attrs.foldlM (fun env attr => attr.activateScoped env scope) env + +/- We use this function to implement commands `namespace foo` and `section foo`. + It activates scoped attributes in the new resulting namespace. -/ +@[export lean_push_scope] +def pushScope (env : Environment) (header : Name) (isNamespace : Bool) : IO Environment := +do let env := env.pushScopeCore header isNamespace; + let ns := env.getNamespace; + attrs ← attributeArrayRef.get; + attrs.foldlM (fun env attr => do env ← attr.pushScope env; if isNamespace then attr.activateScoped env ns else pure env) env + +/- We use this function to implement commands `end foo` for closing namespaces and sections. -/ +@[export lean_pop_scope] +def popScope (env : Environment) : IO Environment := +do let env := env.popScopeCore; + attrs ← attributeArrayRef.get; + attrs.foldlM (fun env attr => attr.popScope env) env + +end Environment + +/-- + Tag attributes are simple and efficient. They are useful for marking declarations in the modules where + they were defined. + + The startup cost for this kind of attribute is very small since `addImportedFn` is a constant function. + + They provide the predicate `tagAttr.hasTag env decl` which returns true iff declaration `decl` + is tagged in the environment `env`. -/ +structure TagAttribute := +(attr : AttributeImpl) +(ext : PersistentEnvExtension Name NameSet) + +def registerTagAttribute (name : Name) (descr : String) (validate : Environment → Name → Except String Unit := fun _ _ => Except.ok ()) : IO TagAttribute := +do ext : PersistentEnvExtension Name NameSet ← registerPersistentEnvExtension { + name := name, + addImportedFn := fun _ => pure {}, + addEntryFn := fun (s : NameSet) n => s.insert n, + exportEntriesFn := fun es => + let r : Array Name := es.fold (fun a e => a.push e) #[]; + r.qsort Name.quickLt, + statsFn := fun s => "tag attribute" ++ Format.line ++ "number of local entries: " ++ format s.size + }; + let attrImpl : AttributeImpl := { + name := name, + descr := descr, + add := fun env decl args persistent => do + unless args.isMissing $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', unexpected argument")); + unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent")); + unless (env.getModuleIdxFor decl).isNone $ + throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module")); + match validate env decl with + | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg)) + | _ => pure $ ext.addEntry env decl + }; + registerAttribute attrImpl; + pure { attr := attrImpl, ext := ext } + +namespace TagAttribute + +instance : Inhabited TagAttribute := ⟨{attr := arbitrary _, ext := arbitrary _}⟩ + +def hasTag (attr : TagAttribute) (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 + +end TagAttribute + +/-- + A `TagAttribute` variant where we can attach parameters to attributes. + It is slightly more expensive and consumes a little bit more memory than `TagAttribute`. + + They provide the function `pAttr.getParam env decl` which returns `some p` iff declaration `decl` + contains the attribute `pAttr` with parameter `p`. -/ +structure ParametricAttribute (α : Type) := +(attr : AttributeImpl) +(ext : PersistentEnvExtension (Name × α) (NameMap α)) + +def registerParametricAttribute {α : Type} [Inhabited α] (name : Name) (descr : String) + (getParam : Environment → Name → Syntax → Except String α) + (afterSet : Environment → Name → α → Except String Environment := fun env _ _ => Except.ok env) : IO (ParametricAttribute α) := +do ext : PersistentEnvExtension (Name × α) (NameMap α) ← registerPersistentEnvExtension { + name := name, + addImportedFn := fun _ => pure {}, + addEntryFn := fun (s : NameMap α) (p : Name × α) => s.insert p.1 p.2, + exportEntriesFn := fun m => + let r : Array (Name × α) := m.fold (fun a n p => a.push (n, p)) #[]; + r.qsort (fun a b => Name.quickLt a.1 b.1), + statsFn := fun s => "parametric attribute" ++ Format.line ++ "number of local entries: " ++ format s.size + }; + let attrImpl : AttributeImpl := { + name := name, + descr := descr, + add := fun env decl args persistent => do + unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent")); + unless (env.getModuleIdxFor decl).isNone $ + throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module")); + match getParam env decl args with + | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg)) + | Except.ok val => do + let env := ext.addEntry env (decl, val); + match afterSet env decl val with + | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg)) + | Except.ok env => pure env + }; + registerAttribute attrImpl; + pure { attr := attrImpl, ext := ext } + +namespace ParametricAttribute + +instance {α : Type} : Inhabited (ParametricAttribute α) := ⟨{attr := arbitrary _, ext := arbitrary _}⟩ + +def getParam {α : Type} [Inhabited α] (attr : ParametricAttribute α) (env : Environment) (decl : Name) : Option α := +match env.getModuleIdxFor decl with +| some modIdx => + match (attr.ext.getModuleEntries env modIdx).binSearch (decl, arbitrary _) (fun a b => Name.quickLt a.1 b.1) with + | some (_, val) => some val + | none => none +| none => (attr.ext.getState env).find decl + +def setParam {α : Type} (attr : ParametricAttribute α) (env : Environment) (decl : Name) (param : α) : Except String Environment := +if (env.getModuleIdxFor decl).isSome then + Except.error ("invalid '" ++ toString attr.attr.name ++ "'.setParam, declaration is in an imported module") +else if ((attr.ext.getState env).find decl).isSome then + Except.error ("invalid '" ++ toString attr.attr.name ++ "'.setParam, attribute has already been set") +else + Except.ok (attr.ext.addEntry env (decl, param)) + +end ParametricAttribute + +/- + Given a list `[a₁, ..., a_n]` of elements of type `α`, `EnumAttributes` provides an attribute `Attr_i` for + associating a value `a_i` with an declaration. `α` is usually an enumeration type. + Note that whenever we register an `EnumAttributes`, we create `n` attributes, but only one environment extension. -/ +structure EnumAttributes (α : Type) := +(attrs : List AttributeImpl) +(ext : PersistentEnvExtension (Name × α) (NameMap α)) + +def registerEnumAttributes {α : Type} [Inhabited α] (extName : Name) (attrDescrs : List (Name × String × α)) (validate : Environment → Name → α → Except String Unit := fun _ _ _ => Except.ok ()) (applicationTime := AttributeApplicationTime.afterTypeChecking) : IO (EnumAttributes α) := +do ext : PersistentEnvExtension (Name × α) (NameMap α) ← registerPersistentEnvExtension { + name := extName, + addImportedFn := fun _ => pure {}, + addEntryFn := fun (s : NameMap α) (p : Name × α) => s.insert p.1 p.2, + exportEntriesFn := fun m => + let r : Array (Name × α) := m.fold (fun a n p => a.push (n, p)) #[]; + r.qsort (fun a b => Name.quickLt a.1 b.1), + statsFn := fun s => "enumeration attribute extension" ++ Format.line ++ "number of local entries: " ++ format s.size + }; + let attrs := attrDescrs.map $ fun ⟨name, descr, val⟩ => { AttributeImpl . + name := name, + descr := descr, + applicationTime := applicationTime, + add := fun env decl args persistent => do + unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent")); + unless (env.getModuleIdxFor decl).isNone $ + throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module")); + match validate env decl val with + | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg)) + | _ => pure $ ext.addEntry env (decl, val) + }; + attrs.forM registerAttribute; + pure { ext := ext, attrs := attrs } + +namespace EnumAttributes + +instance {α : Type} : Inhabited (EnumAttributes α) := ⟨{attrs := [], ext := arbitrary _}⟩ + +def getValue {α : Type} [Inhabited α] (attr : EnumAttributes α) (env : Environment) (decl : Name) : Option α := +match env.getModuleIdxFor decl with +| some modIdx => + match (attr.ext.getModuleEntries env modIdx).binSearch (decl, arbitrary _) (fun a b => Name.quickLt a.1 b.1) with + | some (_, val) => some val + | none => none +| none => (attr.ext.getState env).find decl + +def setValue {α : Type} (attrs : EnumAttributes α) (env : Environment) (decl : Name) (val : α) : Except String Environment := +if (env.getModuleIdxFor decl).isSome then + Except.error ("invalid '" ++ toString attrs.ext.name ++ "'.setValue, declaration is in an imported module") +else if ((attrs.ext.getState env).find decl).isSome then + Except.error ("invalid '" ++ toString attrs.ext.name ++ "'.setValue, attribute has already been set") +else + Except.ok (attrs.ext.addEntry env (decl, val)) + +end EnumAttributes + +/- Helper function for converting a Syntax object representing attribute parameters into an identifier. + It returns `none` if the parameter is not a simple identifier. + + Remark: in the future, attributes should define their own parsers, and we should use `match_syntax` to + decode the Syntax object. -/ +def attrParamSyntaxToIdentifier (s : Syntax) : Option Name := +match s with +| Syntax.node k args => + if k == nullKind && args.size == 1 then match args.get! 0 with + | Syntax.ident _ _ id _ => some id + | _ => none + else + none +| _ => none + +end Lean diff --git a/stage0/src/Init/Lean/AuxRecursor.lean b/stage0/src/Init/Lean/AuxRecursor.lean new file mode 100644 index 0000000000..5a822fa3c0 --- /dev/null +++ b/stage0/src/Init/Lean/AuxRecursor.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment + +namespace Lean + +def mkAuxRecursorExtension : IO TagDeclarationExtension := +mkTagDeclarationExtension `auxRec + +@[init mkAuxRecursorExtension] +constant auxRecExt : TagDeclarationExtension := arbitrary _ + +@[export lean_mark_aux_recursor] +def markAuxRecursor (env : Environment) (n : Name) : Environment := +auxRecExt.tag env n + +@[export lean_is_aux_recursor] +def isAuxRecursor (env : Environment) (n : Name) : Bool := +auxRecExt.isTagged env n + +def mkNoConfusionExtension : IO TagDeclarationExtension := +mkTagDeclarationExtension `noConf + +@[init mkNoConfusionExtension] +constant noConfusionExt : TagDeclarationExtension := arbitrary _ + +@[export lean_mark_no_confusion] +def markNoConfusion (env : Environment) (n : Name) : Environment := +noConfusionExt.tag env n + +@[export lean_is_no_confusion] +def isNoConfusion (env : Environment) (n : Name) : Bool := +noConfusionExt.isTagged env n + +end Lean diff --git a/stage0/src/Init/Lean/Class.lean b/stage0/src/Init/Lean/Class.lean new file mode 100644 index 0000000000..5e2e3baf7a --- /dev/null +++ b/stage0/src/Init/Lean/Class.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes + +namespace Lean + +inductive ClassEntry +| «class» (name : Name) (hasOutParam : Bool) +| «instance» (name : Name) (ofClass : Name) + +namespace ClassEntry + +@[inline] def getName : ClassEntry → Name +| «class» n _ => n +| «instance» n _ => n + +def lt (a b : ClassEntry) : Bool := +Name.quickLt a.getName b.getName + +end ClassEntry + +structure ClassState := +(classToInstances : SMap Name (List Name) := SMap.empty) +(hasOutParam : SMap Name Bool := SMap.empty) +(instances : SMap Name Unit := SMap.empty) + +namespace ClassState + +instance : Inhabited ClassState := ⟨{}⟩ + +def addEntry (s : ClassState) (entry : ClassEntry) : ClassState := +match entry with +| ClassEntry.«class» clsName hasOutParam => + { hasOutParam := s.hasOutParam.insert clsName hasOutParam, .. s } +| ClassEntry.«instance» instName clsName => + { instances := s.instances.insert instName (), + classToInstances := match s.classToInstances.find clsName with + | some insts => s.classToInstances.insert clsName (instName :: insts) + | none => s.classToInstances.insert clsName [instName], + .. s } + +def switch : ClassState → ClassState +| ⟨m₁, m₂, m₃⟩ => ⟨m₁.switch, m₂.switch, m₃.switch⟩ + +end ClassState + +/- TODO: add support for scoped instances -/ +def mkClassExtension : IO (SimplePersistentEnvExtension ClassEntry ClassState) := +registerSimplePersistentEnvExtension { + name := `classExt, + addEntryFn := ClassState.addEntry, + addImportedFn := fun es => (mkStateFromImportedEntries ClassState.addEntry {} es).switch +} + +@[init mkClassExtension] +constant classExtension : SimplePersistentEnvExtension ClassEntry ClassState := arbitrary _ + +@[export lean_is_class] +def isClass (env : Environment) (n : Name) : Bool := +(classExtension.getState env).hasOutParam.contains n + +@[export lean_is_instance] +def isInstance (env : Environment) (n : Name) : Bool := +(classExtension.getState env).instances.contains n + +@[export lean_get_class_instances] +def getClassInstances (env : Environment) (n : Name) : List Name := +match (classExtension.getState env).classToInstances.find n with +| some insts => insts +| none => [] + +@[export lean_has_out_params] +def hasOutParams (env : Environment) (n : Name) : Bool := +match (classExtension.getState env).hasOutParam.find n with +| some b => b +| none => false + +@[export lean_is_out_param] +def isOutParam (e : Expr) : Bool := +e.isAppOfArity `outParam 1 + +def Expr.hasOutParam : Expr → Bool +| Expr.forallE _ d b _ => isOutParam d || Expr.hasOutParam b +| _ => false + +def addClass (env : Environment) (clsName : Name) : Except String Environment := +if isClass env clsName then Except.error ("class has already been declared '" ++ toString clsName ++ "'") +else match env.find clsName with + | none => Except.error ("unknown declaration '" ++ toString clsName ++ "'") + | some decl@(ConstantInfo.inductInfo _) => Except.ok (classExtension.addEntry env (ClassEntry.«class» clsName decl.type.hasOutParam)) + | some _ => Except.error ("invalid 'class', declaration '" ++ toString clsName ++ "' must be inductive datatype or structure") + +private def consumeNLambdas : Nat → Expr → Option Expr +| 0, e => some e +| i+1, Expr.lam _ _ b _ => consumeNLambdas i b +| _, _ => none + +partial def getClassName (env : Environment) : Expr → Option Name +| Expr.forallE _ _ b _ => getClassName b +| e => do + Expr.const c _ _ ← pure e.getAppFn | none; + info ← env.find c; + match info.value? with + | some val => do + body ← consumeNLambdas e.getAppNumArgs val; + getClassName body + | none => + if isClass env c then some c + else none + +@[export lean_add_instance] +def addInstance (env : Environment) (instName : Name) : Except String Environment := +match env.find instName with +| none => Except.error ("unknown declaration '" ++ toString instName ++ "'") +| some decl => + match getClassName env decl.type with + | none => Except.error ("invalid instance '" ++ toString instName ++ "', failed to retrieve class") + | some clsName => Except.ok (classExtension.addEntry env (ClassEntry.«instance» instName clsName)) + +@[init] def registerClassAttr : IO Unit := +registerAttribute { + name := `class, + descr := "type class", + add := fun env decl args persistent => do + unless args.isMissing $ throw (IO.userError ("invalid attribute 'class', unexpected argument")); + unless persistent $ throw (IO.userError ("invalid attribute 'class', must be persistent")); + IO.ofExcept (addClass env decl) +} + +@[init] def registerInstanceAttr : IO Unit := +registerAttribute { + name := `instance, + descr := "type class instance", + add := fun env decl args persistent => do + unless args.isMissing $ throw (IO.userError ("invalid attribute 'instance', unexpected argument")); + unless persistent $ throw (IO.userError ("invalid attribute 'instance', must be persistent")); + IO.ofExcept (addInstance env decl) +} + +end Lean diff --git a/stage0/src/Init/Lean/Compiler.lean b/stage0/src/Init/Lean/Compiler.lean new file mode 100644 index 0000000000..b4e6d4fada --- /dev/null +++ b/stage0/src/Init/Lean/Compiler.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.InlineAttrs +import Init.Lean.Compiler.Specialize +import Init.Lean.Compiler.ConstFolding +import Init.Lean.Compiler.ClosedTermCache +import Init.Lean.Compiler.ExternAttr +import Init.Lean.Compiler.ImplementedByAttr +import Init.Lean.Compiler.NeverExtractAttr +import Init.Lean.Compiler.IR diff --git a/stage0/src/Init/Lean/Compiler/ClosedTermCache.lean b/stage0/src/Init/Lean/Compiler/ClosedTermCache.lean new file mode 100644 index 0000000000..5922ade937 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/ClosedTermCache.lean @@ -0,0 +1,33 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment + +namespace Lean + +abbrev ClosedTermCache := SMap Expr Name + +def mkClosedTermCacheExtension : IO (SimplePersistentEnvExtension (Expr × Name) ClosedTermCache) := +registerSimplePersistentEnvExtension { + name := `closedTermCache, + addImportedFn := fun as => + let cache : ClosedTermCache := mkStateFromImportedEntries (fun s (p : Expr × Name) => s.insert p.1 p.2) {} as; + cache.switch, + addEntryFn := fun s ⟨e, n⟩ => s.insert e n +} + +@[init mkClosedTermCacheExtension] +constant closedTermCacheExt : SimplePersistentEnvExtension (Expr × Name) ClosedTermCache := arbitrary _ + +@[export lean_cache_closed_term_name] +def cacheClosedTermName (env : Environment) (e : Expr) (n : Name) : Environment := +closedTermCacheExt.addEntry env (e, n) + +@[export lean_get_closed_term_name] +def getClosedTermName (env : Environment) (e : Expr) : Option Name := +(closedTermCacheExt.getState env).find e + +end Lean diff --git a/stage0/src/Init/Lean/Compiler/ConstFolding.lean b/stage0/src/Init/Lean/Compiler/ConstFolding.lean new file mode 100644 index 0000000000..fbce3f1957 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/ConstFolding.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.System.Platform +import Init.Lean.Expr +import Init.Lean.Compiler.Util + +/- Constant folding for primitives that have special runtime support. -/ + +namespace Lean +namespace Compiler + +def BinFoldFn := Bool → Expr → Expr → Option Expr +def UnFoldFn := Bool → Expr → Option Expr + +def mkUIntTypeName (nbytes : Nat) : Name := +mkNameSimple ("UInt" ++ toString nbytes) + +structure NumScalarTypeInfo := +(nbits : Nat) +(id : Name := mkUIntTypeName nbits) +(ofNatFn : Name := mkNameStr id "ofNat") +(toNatFn : Name := mkNameStr id "toNat") +(size : Nat := 2^nbits) + +def numScalarTypes : List NumScalarTypeInfo := +[{nbits := 8}, {nbits := 16}, {nbits := 32}, {nbits := 64}, + {id := `USize, nbits := System.Platform.numBits}] + +def isOfNat (fn : Name) : Bool := +numScalarTypes.any (fun info => info.ofNatFn == fn) + +def isToNat (fn : Name) : Bool := +numScalarTypes.any (fun info => info.toNatFn == fn) + +def getInfoFromFn (fn : Name) : List NumScalarTypeInfo → Option NumScalarTypeInfo +| [] => none +| info::infos => + if info.ofNatFn == fn then some info + else getInfoFromFn infos + +def getInfoFromVal : Expr → Option NumScalarTypeInfo +| Expr.app (Expr.const fn _ _) _ _ => getInfoFromFn fn numScalarTypes +| _ => none + +@[export lean_get_num_lit] +def getNumLit : Expr → Option Nat +| Expr.lit (Literal.natVal n) _ => some n +| Expr.app (Expr.const fn _ _) a _ => if isOfNat fn then getNumLit a else none +| _ => none + +def mkUIntLit (info : NumScalarTypeInfo) (n : Nat) : Expr := +mkApp (mkConst info.ofNatFn) (mkNatLit (n%info.size)) + +def mkUInt32Lit (n : Nat) : Expr := +mkUIntLit {nbits := 32} n + +def foldBinUInt (fn : NumScalarTypeInfo → Bool → Nat → Nat → Nat) (beforeErasure : Bool) (a₁ a₂ : Expr) : Option Expr := +do n₁ ← getNumLit a₁; + n₂ ← getNumLit a₂; + info ← getInfoFromVal a₁; + pure $ mkUIntLit info (fn info beforeErasure n₁ n₂) + +def foldUIntAdd := foldBinUInt $ fun _ _ => HasAdd.add +def foldUIntMul := foldBinUInt $ fun _ _ => HasMul.mul +def foldUIntDiv := foldBinUInt $ fun _ _ => HasDiv.div +def foldUIntMod := foldBinUInt $ fun _ _ => HasMod.mod +def foldUIntSub := foldBinUInt $ fun info _ a b => (a + (info.size - b)) + +def preUIntBinFoldFns : List (Name × BinFoldFn) := +[(`add, foldUIntAdd), (`mul, foldUIntMul), (`div, foldUIntDiv), + (`mod, foldUIntMod), (`sub, foldUIntSub)] + +def uintBinFoldFns : List (Name × BinFoldFn) := +numScalarTypes.foldl (fun r info => r ++ (preUIntBinFoldFns.map (fun ⟨suffix, fn⟩ => (info.id ++ suffix, fn)))) [] + +def foldNatBinOp (fn : Nat → Nat → Nat) (a₁ a₂ : Expr) : Option Expr := +do n₁ ← getNumLit a₁; + n₂ ← getNumLit a₂; + pure $ mkNatLit (fn n₁ n₂) + +def foldNatAdd (_ : Bool) := foldNatBinOp HasAdd.add +def foldNatMul (_ : Bool) := foldNatBinOp HasMul.mul +def foldNatDiv (_ : Bool) := foldNatBinOp HasDiv.div +def foldNatMod (_ : Bool) := foldNatBinOp HasMod.mod +def foldNatPow (_ : Bool) := foldNatBinOp HasPow.pow + +def mkNatEq (a b : Expr) : Expr := +mkAppN (mkConst `Eq [levelOne]) #[(mkConst `Nat), a, b] + +def mkNatLt (a b : Expr) : Expr := +mkAppN (mkConst `HasLt.lt [levelZero]) #[mkConst `Nat, mkConst `Nat.HasLt, a, b] + +def mkNatLe (a b : Expr) : Expr := +mkAppN (mkConst `HasLt.le [levelZero]) #[mkConst `Nat, mkConst `Nat.HasLe, a, b] + +def toDecidableExpr (beforeErasure : Bool) (pred : Expr) (r : Bool) : Expr := +match beforeErasure, r with +| false, true => mkDecIsTrue neutralExpr neutralExpr +| false, false => mkDecIsFalse neutralExpr neutralExpr +| true, true => mkDecIsTrue pred (mkLcProof pred) +| true, false => mkDecIsFalse pred (mkLcProof pred) + +def foldNatBinPred (mkPred : Expr → Expr → Expr) (fn : Nat → Nat → Bool) + (beforeErasure : Bool) (a₁ a₂ : Expr) : Option Expr := +do n₁ ← getNumLit a₁; + n₂ ← getNumLit a₂; + pure $ toDecidableExpr beforeErasure (mkPred a₁ a₂) (fn n₁ n₂) + +def foldNatDecEq := foldNatBinPred mkNatEq (fun a b => a = b) +def foldNatDecLt := foldNatBinPred mkNatLt (fun a b => a < b) +def foldNatDecLe := foldNatBinPred mkNatLe (fun a b => a ≤ b) + +def natFoldFns : List (Name × BinFoldFn) := +[(`Nat.add, foldNatAdd), + (`Nat.mul, foldNatMul), + (`Nat.div, foldNatDiv), + (`Nat.mod, foldNatMod), + (`Nat.pow, foldNatPow), + (`Nat.pow._main, foldNatPow), + (`Nat.decEq, foldNatDecEq), + (`Nat.decLt, foldNatDecLt), + (`Nat.decLe, foldNatDecLe)] + +def getBoolLit : Expr → Option Bool +| Expr.const `Bool.true _ _ => some true +| Expr.const `Bool.false _ _ => some false +| _ => none + +def foldStrictAnd (_ : Bool) (a₁ a₂ : Expr) : Option Expr := +let v₁ := getBoolLit a₁; +let v₂ := getBoolLit a₂; +match v₁, v₂ with +| some true, _ => a₂ +| some false, _ => a₁ +| _, some true => a₁ +| _, some false => a₂ +| _, _ => none + +def foldStrictOr (_ : Bool) (a₁ a₂ : Expr) : Option Expr := +let v₁ := getBoolLit a₁; +let v₂ := getBoolLit a₂; +match v₁, v₂ with +| some true, _ => a₁ +| some false, _ => a₂ +| _, some true => a₂ +| _, some false => a₁ +| _, _ => none + +def boolFoldFns : List (Name × BinFoldFn) := +[(`strictOr, foldStrictOr), (`strictAnd, foldStrictAnd)] + +def binFoldFns : List (Name × BinFoldFn) := +boolFoldFns ++ uintBinFoldFns ++ natFoldFns + +def foldNatSucc (_ : Bool) (a : Expr) : Option Expr := +do n ← getNumLit a; + pure $ mkNatLit (n+1) + +def foldCharOfNat (beforeErasure : Bool) (a : Expr) : Option Expr := +do guard (!beforeErasure); + n ← getNumLit a; + pure $ + if isValidChar n.toUInt32 then mkUInt32Lit n + else mkUInt32Lit 0 + +def foldToNat (_ : Bool) (a : Expr) : Option Expr := +do n ← getNumLit a; + pure $ mkNatLit n + +def uintFoldToNatFns : List (Name × UnFoldFn) := +numScalarTypes.foldl (fun r info => (info.toNatFn, foldToNat) :: r) [] + +def unFoldFns : List (Name × UnFoldFn) := +[(`Nat.succ, foldNatSucc), + (`Char.ofNat, foldCharOfNat)] +++ uintFoldToNatFns + +def findBinFoldFn (fn : Name) : Option BinFoldFn := +binFoldFns.lookup fn + +def findUnFoldFn (fn : Name) : Option UnFoldFn := +unFoldFns.lookup fn + +@[export lean_fold_bin_op] +def foldBinOp (beforeErasure : Bool) (f : Expr) (a : Expr) (b : Expr) : Option Expr := +match f with +| Expr.const fn _ _ => do + foldFn ← findBinFoldFn fn; + foldFn beforeErasure a b +| _ => none + +@[export lean_fold_un_op] +def foldUnOp (beforeErasure : Bool) (f : Expr) (a : Expr) : Option Expr := +match f with +| Expr.const fn _ _ => do + foldFn ← findUnFoldFn fn; + foldFn beforeErasure a +| _ => none + +end Compiler +end Lean diff --git a/stage0/src/Init/Lean/Compiler/ExportAttr.lean b/stage0/src/Init/Lean/Compiler/ExportAttr.lean new file mode 100644 index 0000000000..10c303d200 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/ExportAttr.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes + +namespace Lean + +private def isValidCppId (id : String) : Bool := +let first := id.get 0; +first.isAlpha && (id.toSubstring.drop 1).all (fun c => c.isAlpha || c.isDigit || c == '_') + +private def isValidCppName : Name → Bool +| Name.str Name.anonymous s _ => isValidCppId s +| Name.str p s _ => isValidCppId s && isValidCppName p +| _ => false + +def mkExportAttr : IO (ParametricAttribute Name) := +registerParametricAttribute `export "name to be used by code generators" $ fun _ _ stx => + match attrParamSyntaxToIdentifier stx with + | some exportName => + if isValidCppName exportName then Except.ok exportName + else Except.error "invalid 'export' function name, is not a valid C++ identifier" + | _ => Except.error "unexpected kind of argument" + +@[init mkExportAttr] +constant exportAttr : ParametricAttribute Name := arbitrary _ + +@[export lean_get_export_name_for] +def getExportNameFor (env : Environment) (n : Name) : Option Name := +exportAttr.getParam env n + +def isExport (env : Environment) (n : Name) : Bool := +(getExportNameFor env n).isSome + +end Lean diff --git a/stage0/src/Init/Lean/Compiler/ExternAttr.lean b/stage0/src/Init/Lean/Compiler/ExternAttr.lean new file mode 100644 index 0000000000..75a402f9ee --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/ExternAttr.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Option.Basic +import Init.Lean.Expr +import Init.Lean.Environment +import Init.Lean.Attributes +import Init.Lean.ProjFns + +namespace Lean + +inductive ExternEntry +| adhoc (backend : Name) +| inline (backend : Name) (pattern : String) +| standard (backend : Name) (fn : String) +| foreign (backend : Name) (fn : String) + +/- +- `@[extern]` + encoding: ```.entries = [adhoc `all]``` +- `@[extern "level_hash"]` + encoding: ```.entries = [standard `all "levelHash"]``` +- `@[extern cpp "lean::string_size" llvm "lean_str_size"]` + encoding: ```.entries = [standard `cpp "lean::string_size", standard `llvm "leanStrSize"]``` +- `@[extern cpp inline "#1 + #2"]` + encoding: ```.entries = [inline `cpp "#1 + #2"]``` +- `@[extern cpp "foo" llvm adhoc]` + encoding: ```.entries = [standard `cpp "foo", adhoc `llvm]``` +- `@[extern 2 cpp "io_prim_println"]` + encoding: ```.arity = 2, .entries = [standard `cpp "ioPrimPrintln"]``` +-/ +structure ExternAttrData := +(arity : Option Nat := none) +(entries : List ExternEntry) + +instance ExternAttrData.inhabited : Inhabited ExternAttrData := ⟨{ entries := [] }⟩ + +private partial def syntaxToExternEntries (a : Array Syntax) : Nat → List ExternEntry → Except String (List ExternEntry) +| i, entries => + if i == a.size then Except.ok entries + else match a.get! i with + | Syntax.ident _ _ backend _ => + let i := i + 1; + if i == a.size then Except.error "string or identifier expected" + else match (a.get! i).isIdOrAtom with + | some "adhoc" => syntaxToExternEntries (i+1) (ExternEntry.adhoc backend :: entries) + | some "inline" => + let i := i + 1; + match (a.get! i).isStrLit with + | some pattern => syntaxToExternEntries (i+1) (ExternEntry.inline backend pattern :: entries) + | none => Except.error "string literal expected" + | _ => match (a.get! i).isStrLit with + | some fn => syntaxToExternEntries (i+1) (ExternEntry.standard backend fn :: entries) + | none => Except.error "string literal expected" + | _ => Except.error "identifier expected" + +private def syntaxToExternAttrData (s : Syntax) : ExceptT String Id ExternAttrData := +match s with +| Syntax.missing => Except.ok { entries := [ ExternEntry.adhoc `all ] } +| Syntax.node _ args => + if args.size == 0 then Except.error "unexpected kind of argument" + else + let (arity, i) : Option Nat × Nat := match (args.get! 0).isNatLit with + | some arity => (some arity, 1) + | none => (none, 0); + match (args.get! i).isStrLit with + | some str => + if args.size == i+1 then + Except.ok { arity := arity, entries := [ ExternEntry.standard `all str ] } + else + Except.error "invalid extern attribute" + | none => match syntaxToExternEntries args i [] with + | Except.ok entries => Except.ok { arity := arity, entries := entries } + | Except.error msg => Except.error msg +| _ => Except.error "unexpected kind of argument" + +@[extern "lean_add_extern"] +constant addExtern (env : Environment) (n : Name) : ExceptT String Id Environment := arbitrary _ + +def mkExternAttr : IO (ParametricAttribute ExternAttrData) := +registerParametricAttribute `extern "builtin and foreign functions" + (fun _ _ => syntaxToExternAttrData) + (fun env declName _ => + if env.isProjectionFn declName || env.isConstructor declName then + addExtern env declName + else + pure env) + +@[init mkExternAttr] +constant externAttr : ParametricAttribute ExternAttrData := arbitrary _ + +@[export lean_get_extern_attr_data] +def getExternAttrData (env : Environment) (n : Name) : Option ExternAttrData := +externAttr.getParam env n + +private def parseOptNum : Nat → String.Iterator → Nat → String.Iterator × Nat +| 0, it, r => (it, r) +| n+1, it, r => + if !it.hasNext then (it, r) + else + let c := it.curr; + if '0' <= c && c <= '9' + then parseOptNum n it.next (r*10 + (c.toNat - '0'.toNat)) + else (it, r) + +def expandExternPatternAux (args : List String) : Nat → String.Iterator → String → String +| 0, it, r => r +| i+1, it, r => + if ¬ it.hasNext then r + else let c := it.curr; + if c ≠ '#' then expandExternPatternAux i it.next (r.push c) + else + let it := it.next; + let (it, j) := parseOptNum it.remainingBytes it 0; + let j := j-1; + expandExternPatternAux i it (r ++ args.getD j "") + +def expandExternPattern (pattern : String) (args : List String) : String := +expandExternPatternAux args pattern.length pattern.mkIterator "" + +def mkSimpleFnCall (fn : String) (args : List String) : String := +fn ++ "(" ++ ((args.intersperse ", ").foldl HasAppend.append "") ++ ")" + +def ExternEntry.backend : ExternEntry → Name +| ExternEntry.adhoc n => n +| ExternEntry.inline n _ => n +| ExternEntry.standard n _ => n +| ExternEntry.foreign n _ => n + +def getExternEntryForAux (backend : Name) : List ExternEntry → Option ExternEntry +| [] => none +| e::es => + if e.backend == `all then some e + else if e.backend == backend then some e + else getExternEntryForAux es + +def getExternEntryFor (d : ExternAttrData) (backend : Name) : Option ExternEntry := +getExternEntryForAux backend d.entries + +def isExtern (env : Environment) (fn : Name) : Bool := +(getExternAttrData env fn).isSome + +/- We say a Lean function marked as `[extern ""]` is for all backends, and it is implemented using `extern "C"`. + Thus, there is no name mangling. -/ +def isExternC (env : Environment) (fn : Name) : Bool := +match getExternAttrData env fn with +| some { entries := [ ExternEntry.standard `all _ ], .. } => true +| _ => false + +def getExternNameFor (env : Environment) (backend : Name) (fn : Name) : Option String := +do data ← getExternAttrData env fn; + entry ← getExternEntryFor data backend; + match entry with + | ExternEntry.standard _ n => pure n + | ExternEntry.foreign _ n => pure n + | _ => failure + +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR.lean b/stage0/src/Init/Lean/Compiler/IR.lean new file mode 100644 index 0000000000..463562fc61 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.Format +import Init.Lean.Compiler.IR.CompilerM +import Init.Lean.Compiler.IR.PushProj +import Init.Lean.Compiler.IR.ElimDeadVars +import Init.Lean.Compiler.IR.SimpCase +import Init.Lean.Compiler.IR.ResetReuse +import Init.Lean.Compiler.IR.NormIds +import Init.Lean.Compiler.IR.Checker +import Init.Lean.Compiler.IR.Borrow +import Init.Lean.Compiler.IR.Boxing +import Init.Lean.Compiler.IR.RC +import Init.Lean.Compiler.IR.ExpandResetReuse +import Init.Lean.Compiler.IR.UnboxResult +import Init.Lean.Compiler.IR.ElimDeadBranches +import Init.Lean.Compiler.IR.EmitC + +namespace Lean +namespace IR + +private def compileAux (decls : Array Decl) : CompilerM Unit := +do logDecls `init decls; + checkDecls decls; + decls ← elimDeadBranches decls; + logDecls `elim_dead_branches decls; + let decls := decls.map Decl.pushProj; + logDecls `push_proj decls; + let decls := decls.map Decl.insertResetReuse; + logDecls `reset_reuse decls; + let decls := decls.map Decl.elimDead; + logDecls `elim_dead decls; + let decls := decls.map Decl.simpCase; + logDecls `simp_case decls; + let decls := decls.map Decl.normalizeIds; + decls ← inferBorrow decls; + logDecls `borrow decls; + decls ← explicitBoxing decls; + logDecls `boxing decls; + decls ← explicitRC decls; + logDecls `rc decls; + let decls := decls.map Decl.expandResetReuse; + logDecls `expand_reset_reuse decls; + let decls := decls.map Decl.pushProj; + logDecls `push_proj decls; + logDecls `result decls; + checkDecls decls; + addDecls decls; + pure () + +@[export lean_ir_compile] +def compile (env : Environment) (opts : Options) (decls : Array Decl) : Log × (Except String Environment) := +match (compileAux decls opts).run { env := env } with +| EStateM.Result.ok _ s => (s.log, Except.ok s.env) +| EStateM.Result.error msg s => (s.log, Except.error msg) + +def addBoxedVersionAux (decl : Decl) : CompilerM Unit := +do env ← getEnv; + if !ExplicitBoxing.requiresBoxedVersion env decl then pure () + else do + let decl := ExplicitBoxing.mkBoxedVersion decl; + let decls : Array Decl := #[decl]; + decls ← explicitRC decls; + decls.forM $ fun decl => modifyEnv $ fun env => addDeclAux env decl; + pure () + +-- Remark: we are ignoring the `Log` here. This should be fine. +@[export lean_ir_add_boxed_version] +def addBoxedVersion (env : Environment) (decl : Decl) : Except String Environment := +match (addBoxedVersionAux decl Options.empty).run { env := env } with +| EStateM.Result.ok _ s => Except.ok s.env +| EStateM.Result.error msg s => Except.error msg + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/Basic.lean b/stage0/src/Init/Lean/Compiler/IR/Basic.lean new file mode 100644 index 0000000000..cb6ad1bb26 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/Basic.lean @@ -0,0 +1,595 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Array +import Init.Lean.Name +import Init.Lean.KVMap +import Init.Lean.Format +import Init.Lean.Compiler.ExternAttr +/- +Implements (extended) λPure and λRc proposed in the article +"Counting Immutable Beans", Sebastian Ullrich and Leonardo de Moura. + +The Lean to IR transformation produces λPure code, and +this part is implemented in C++. The procedures described in the paper +above are implemented in Lean. +-/ +namespace Lean +namespace IR + +/- Function identifier -/ +abbrev FunId := Name +abbrev Index := Nat +/- Variable identifier -/ +structure VarId := +(idx : Index) +/- Join point identifier -/ +structure JoinPointId := +(idx : Index) + +abbrev Index.lt (a b : Index) : Bool := a < b + +namespace VarId +instance : HasBeq VarId := ⟨fun a b => a.idx == b.idx⟩ +instance : HasToString VarId := ⟨fun a => "x_" ++ toString a.idx⟩ +instance : HasFormat VarId := ⟨fun a => toString a⟩ +instance : Hashable VarId := ⟨fun a => hash a.idx⟩ +end VarId + +namespace JoinPointId +instance : HasBeq JoinPointId := ⟨fun a b => a.idx == b.idx⟩ +instance : HasToString JoinPointId := ⟨fun a => "block_" ++ toString a.idx⟩ +instance : HasFormat JoinPointId := ⟨fun a => toString a⟩ +instance : Hashable JoinPointId := ⟨fun a => hash a.idx⟩ +end JoinPointId + +abbrev MData := KVMap +namespace MData +abbrev empty : MData := {KVMap .} +instance : HasEmptyc MData := ⟨empty⟩ +end MData + +/- Low Level IR types. Most are self explanatory. + + - `usize` represents the C++ `size_t` Type. We have it here + because it is 32-bit in 32-bit machines, and 64-bit in 64-bit machines, + and we want the C++ backend for our Compiler to generate platform independent code. + + - `irrelevant` for Lean types, propositions and proofs. + + - `object` a pointer to a value in the heap. + + - `tobject` a pointer to a value in the heap or tagged pointer + (i.e., the least significant bit is 1) storing a scalar value. + + - `struct` and `union` are used to return small values (e.g., `Option`, `Prod`, `Except`) + on the stack. + +Remark: the RC operations for `tobject` are slightly more expensive because we +first need to test whether the `tobject` is really a pointer or not. + +Remark: the Lean runtime assumes that sizeof(void*) == sizeof(sizeT). +Lean cannot be compiled on old platforms where this is not True. + +Since values of type `struct` and `union` are only used to return values, +We assume they must be used/consumed "linearly". We use the term "linear" here +to mean "exactly once" in each execution. That is, given `x : S`, where `S` is a struct, +then one of the following must hold in each (execution) branch. +1- `x` occurs only at a single `ret x` instruction. That is, it is being consumed by being returned. +2- `x` occurs only at a single `ctor`. That is, it is being "consumed" by being stored into another `struct/union`. +3- We extract (aka project) every single field of `x` exactly once. That is, we are consuming `x` by consuming each + of one of its components. Minor refinement: we don't need to consume scalar fields or struct/union + fields that do not contain object fields. +-/ +inductive IRType +| float | uint8 | uint16 | uint32 | uint64 | usize +| irrelevant | object | tobject +| struct (leanTypeName : Option Name) (types : Array IRType) : IRType +| union (leanTypeName : Name) (types : Array IRType) : IRType + +namespace IRType + +partial def beq : IRType → IRType → Bool +| float, float => true +| uint8, uint8 => true +| uint16, uint16 => true +| uint32, uint32 => true +| uint64, uint64 => true +| usize, usize => true +| irrelevant, irrelevant => true +| object, object => true +| tobject, tobject => true +| struct n₁ tys₁, struct n₂ tys₂ => n₁ == n₂ && Array.isEqv tys₁ tys₂ beq +| union n₁ tys₁, union n₂ tys₂ => n₁ == n₂ && Array.isEqv tys₁ tys₂ beq +| _, _ => false + +instance HasBeq : HasBeq IRType := ⟨beq⟩ + +def isScalar : IRType → Bool +| float => true +| uint8 => true +| uint16 => true +| uint32 => true +| uint64 => true +| usize => true +| _ => false + +def isObj : IRType → Bool +| object => true +| tobject => true +| _ => false + +def isIrrelevant : IRType → Bool +| irrelevant => true +| _ => false + +def isStruct : IRType → Bool +| struct _ _ => true +| _ => false + +def isUnion : IRType → Bool +| union _ _ => true +| _ => false + +end IRType + +/- Arguments to applications, constructors, etc. + We use `irrelevant` for Lean types, propositions and proofs that have been erased. + Recall that for a Function `f`, we also generate `f._rarg` which does not take + `irrelevant` arguments. However, `f._rarg` is only safe to be used in full applications. -/ +inductive Arg +| var (id : VarId) +| irrelevant + +namespace Arg +protected def beq : Arg → Arg → Bool +| var x, var y => x == y +| irrelevant, irrelevant => true +| _, _ => false + +instance : HasBeq Arg := ⟨Arg.beq⟩ +instance : Inhabited Arg := ⟨irrelevant⟩ +end Arg + +@[export lean_ir_mk_var_arg] def mkVarArg (id : VarId) : Arg := Arg.var id + +inductive LitVal +| num (v : Nat) +| str (v : String) + +def LitVal.beq : LitVal → LitVal → Bool +| LitVal.num v₁, LitVal.num v₂ => v₁ == v₂ +| LitVal.str v₁, LitVal.str v₂ => v₁ == v₂ +| _, _ => false + +instance LitVal.HasBeq : HasBeq LitVal := ⟨LitVal.beq⟩ + +/- Constructor information. + + - `name` is the Name of the Constructor in Lean. + - `cidx` is the Constructor index (aka tag). + - `size` is the number of arguments of type `object/tobject`. + - `usize` is the number of arguments of type `usize`. + - `ssize` is the number of bytes used to store scalar values. + +Recall that a Constructor object contains a header, then a sequence of +pointers to other Lean objects, a sequence of `USize` (i.e., `size_t`) +scalar values, and a sequence of other scalar values. -/ +structure CtorInfo := +(name : Name) (cidx : Nat) (size : Nat) (usize : Nat) (ssize : Nat) + +def CtorInfo.beq : CtorInfo → CtorInfo → Bool +| ⟨n₁, cidx₁, size₁, usize₁, ssize₁⟩, ⟨n₂, cidx₂, size₂, usize₂, ssize₂⟩ => + n₁ == n₂ && cidx₁ == cidx₂ && size₁ == size₂ && usize₁ == usize₂ && ssize₁ == ssize₂ + +instance CtorInfo.HasBeq : HasBeq CtorInfo := ⟨CtorInfo.beq⟩ + +def CtorInfo.isRef (info : CtorInfo) : Bool := +info.size > 0 || info.usize > 0 || info.ssize > 0 + +def CtorInfo.isScalar (info : CtorInfo) : Bool := +!info.isRef + +inductive Expr +/- We use `ctor` mainly for constructing Lean object/tobject values `lean_ctor_object` in the runtime. + This instruction is also used to creat `struct` and `union` return values. + For `union`, only `i.cidx` is relevant. For `struct`, `i` is irrelevant. -/ +| ctor (i : CtorInfo) (ys : Array Arg) +| reset (n : Nat) (x : VarId) +/- `reuse x in ctor_i ys` instruction in the paper. -/ +| reuse (x : VarId) (i : CtorInfo) (updtHeader : Bool) (ys : Array Arg) +/- Extract the `tobject` value at Position `sizeof(void*)*i` from `x`. + We also use `proj` for extracting fields from `struct` return values, and casting `union` return values. -/ +| proj (i : Nat) (x : VarId) +/- Extract the `Usize` value at Position `sizeof(void*)*i` from `x`. -/ +| uproj (i : Nat) (x : VarId) +/- Extract the scalar value at Position `sizeof(void*)*n + offset` from `x`. -/ +| sproj (n : Nat) (offset : Nat) (x : VarId) +/- Full application. -/ +| fap (c : FunId) (ys : Array Arg) +/- Partial application that creates a `pap` value (aka closure in our nonstandard terminology). -/ +| pap (c : FunId) (ys : Array Arg) +/- Application. `x` must be a `pap` value. -/ +| ap (x : VarId) (ys : Array Arg) +/- Given `x : ty` where `ty` is a scalar type, this operation returns a value of Type `tobject`. + For small scalar values, the Result is a tagged pointer, and no memory allocation is performed. -/ +| box (ty : IRType) (x : VarId) +/- Given `x : [t]object`, obtain the scalar value. -/ +| unbox (x : VarId) +| lit (v : LitVal) +/- Return `1 : uint8` Iff `RC(x) > 1` -/ +| isShared (x : VarId) +/- Return `1 : uint8` Iff `x : tobject` is a tagged pointer (storing a scalar value). -/ +| isTaggedPtr (x : VarId) + +@[export lean_ir_mk_ctor_expr] def mkCtorExpr (n : Name) (cidx : Nat) (size : Nat) (usize : Nat) (ssize : Nat) (ys : Array Arg) : Expr := Expr.ctor ⟨n, cidx, size, usize, ssize⟩ ys +@[export lean_ir_mk_proj_expr] def mkProjExpr (i : Nat) (x : VarId) : Expr := Expr.proj i x +@[export lean_ir_mk_uproj_expr] def mkUProjExpr (i : Nat) (x : VarId) : Expr := Expr.uproj i x +@[export lean_ir_mk_sproj_expr] def mkSProjExpr (n : Nat) (offset : Nat) (x : VarId) : Expr := Expr.sproj n offset x +@[export lean_ir_mk_fapp_expr] def mkFAppExpr (c : FunId) (ys : Array Arg) : Expr := Expr.fap c ys +@[export lean_ir_mk_papp_expr] def mkPAppExpr (c : FunId) (ys : Array Arg) : Expr := Expr.pap c ys +@[export lean_ir_mk_app_expr] def mkAppExpr (x : VarId) (ys : Array Arg) : Expr := Expr.ap x ys +@[export lean_ir_mk_num_expr] def mkNumExpr (v : Nat) : Expr := Expr.lit (LitVal.num v) +@[export lean_ir_mk_str_expr] def mkStrExpr (v : String) : Expr := Expr.lit (LitVal.str v) + +structure Param := +(x : VarId) (borrow : Bool) (ty : IRType) + +instance paramInh : Inhabited Param := ⟨{ x := { idx := 0 }, borrow := false, ty := IRType.object }⟩ + +@[export lean_ir_mk_param] def mkParam (x : VarId) (borrow : Bool) (ty : IRType) : Param := ⟨x, borrow, ty⟩ + +inductive AltCore (FnBody : Type) : Type +| ctor (info : CtorInfo) (b : FnBody) : AltCore +| default (b : FnBody) : AltCore + +inductive FnBody +/- `let x : ty := e; b` -/ +| vdecl (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) +/- Join point Declaration `block_j (xs) := e; b` -/ +| jdecl (j : JoinPointId) (xs : Array Param) (v : FnBody) (b : FnBody) +/- Store `y` at Position `sizeof(void*)*i` in `x`. `x` must be a Constructor object and `RC(x)` must be 1. + This operation is not part of λPure is only used during optimization. -/ +| set (x : VarId) (i : Nat) (y : Arg) (b : FnBody) +| setTag (x : VarId) (cidx : Nat) (b : FnBody) +/- Store `y : Usize` at Position `sizeof(void*)*i` in `x`. `x` must be a Constructor object and `RC(x)` must be 1. -/ +| uset (x : VarId) (i : Nat) (y : VarId) (b : FnBody) +/- Store `y : ty` at Position `sizeof(void*)*i + offset` in `x`. `x` must be a Constructor object and `RC(x)` must be 1. + `ty` must not be `object`, `tobject`, `irrelevant` nor `Usize`. -/ +| sset (x : VarId) (i : Nat) (offset : Nat) (y : VarId) (ty : IRType) (b : FnBody) +/- RC increment for `object`. If c == `true`, then `inc` must check whether `x` is a tagged pointer or not. + If `persistent == true` then `x` is statically known to be a persistent object. -/ +| inc (x : VarId) (n : Nat) (c : Bool) (persistent : Bool) (b : FnBody) +/- RC decrement for `object`. If c == `true`, then `inc` must check whether `x` is a tagged pointer or not. + If `persistent == true` then `x` is statically known to be a persistent object. -/ +| dec (x : VarId) (n : Nat) (c : Bool) (persistent : Bool) (b : FnBody) +| del (x : VarId) (b : FnBody) +| mdata (d : MData) (b : FnBody) +| case (tid : Name) (x : VarId) (xType : IRType) (cs : Array (AltCore FnBody)) +| ret (x : Arg) +/- Jump to join point `j` -/ +| jmp (j : JoinPointId) (ys : Array Arg) +| unreachable + +instance : Inhabited FnBody := ⟨FnBody.unreachable⟩ + +abbrev FnBody.nil := FnBody.unreachable + +@[export lean_ir_mk_vdecl] def mkVDecl (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) : FnBody := FnBody.vdecl x ty e b +@[export lean_ir_mk_jdecl] def mkJDecl (j : JoinPointId) (xs : Array Param) (v : FnBody) (b : FnBody) : FnBody := FnBody.jdecl j xs v b +@[export lean_ir_mk_uset] def mkUSet (x : VarId) (i : Nat) (y : VarId) (b : FnBody) : FnBody := FnBody.uset x i y b +@[export lean_ir_mk_sset] def mkSSet (x : VarId) (i : Nat) (offset : Nat) (y : VarId) (ty : IRType) (b : FnBody) : FnBody := FnBody.sset x i offset y ty b +@[export lean_ir_mk_case] def mkCase (tid : Name) (x : VarId) (cs : Array (AltCore FnBody)) : FnBody := +-- Tyhe field `xType` is set by `explicitBoxing` compiler pass. +FnBody.case tid x IRType.object cs +@[export lean_ir_mk_ret] def mkRet (x : Arg) : FnBody := FnBody.ret x +@[export lean_ir_mk_jmp] def mkJmp (j : JoinPointId) (ys : Array Arg) : FnBody := FnBody.jmp j ys +@[export lean_ir_mk_unreachable] def mkUnreachable : Unit → FnBody := fun _ => FnBody.unreachable + +abbrev Alt := AltCore FnBody +@[matchPattern] abbrev Alt.ctor := @AltCore.ctor FnBody +@[matchPattern] abbrev Alt.default := @AltCore.default FnBody + +instance altInh : Inhabited Alt := +⟨Alt.default (arbitrary _)⟩ + +def FnBody.isTerminal : FnBody → Bool +| FnBody.case _ _ _ _ => true +| FnBody.ret _ => true +| FnBody.jmp _ _ => true +| FnBody.unreachable => true +| _ => false + +def FnBody.body : FnBody → FnBody +| FnBody.vdecl _ _ _ b => b +| FnBody.jdecl _ _ _ b => b +| FnBody.set _ _ _ b => b +| FnBody.uset _ _ _ b => b +| FnBody.sset _ _ _ _ _ b => b +| FnBody.setTag _ _ b => b +| FnBody.inc _ _ _ _ b => b +| FnBody.dec _ _ _ _ b => b +| FnBody.del _ b => b +| FnBody.mdata _ b => b +| other => other + +def FnBody.setBody : FnBody → FnBody → FnBody +| FnBody.vdecl x t v _, b => FnBody.vdecl x t v b +| FnBody.jdecl j xs v _, b => FnBody.jdecl j xs v b +| FnBody.set x i y _, b => FnBody.set x i y b +| FnBody.uset x i y _, b => FnBody.uset x i y b +| FnBody.sset x i o y t _, b => FnBody.sset x i o y t b +| FnBody.setTag x i _, b => FnBody.setTag x i b +| FnBody.inc x n c p _, b => FnBody.inc x n c p b +| FnBody.dec x n c p _, b => FnBody.dec x n c p b +| FnBody.del x _, b => FnBody.del x b +| FnBody.mdata d _, b => FnBody.mdata d b +| other, b => other + +@[inline] def FnBody.resetBody (b : FnBody) : FnBody := +b.setBody FnBody.nil + +/- If b is a non terminal, then return a pair `(c, b')` s.t. `b == c <;> b'`, + and c.body == FnBody.nil -/ +@[inline] def FnBody.split (b : FnBody) : FnBody × FnBody := +let b' := b.body; +let c := b.resetBody; +(c, b') + +def AltCore.body : Alt → FnBody +| Alt.ctor _ b => b +| Alt.default b => b + +def AltCore.setBody : Alt → FnBody → Alt +| Alt.ctor c _, b => Alt.ctor c b +| Alt.default _, b => Alt.default b + +@[inline] def AltCore.modifyBody (f : FnBody → FnBody) : AltCore FnBody → Alt +| Alt.ctor c b => Alt.ctor c (f b) +| Alt.default b => Alt.default (f b) + +@[inline] def AltCore.mmodifyBody {m : Type → Type} [Monad m] (f : FnBody → m FnBody) : AltCore FnBody → m Alt +| Alt.ctor c b => Alt.ctor c <$> f b +| Alt.default b => Alt.default <$> f b + +def Alt.isDefault : Alt → Bool +| Alt.ctor _ _ => false +| Alt.default _ => true + +def push (bs : Array FnBody) (b : FnBody) : Array FnBody := +let b := b.resetBody; +bs.push b + +partial def flattenAux : FnBody → Array FnBody → (Array FnBody) × FnBody +| b, r => + if b.isTerminal then (r, b) + else flattenAux b.body (push r b) + +def FnBody.flatten (b : FnBody) : (Array FnBody) × FnBody := +flattenAux b #[] + +partial def reshapeAux : Array FnBody → Nat → FnBody → FnBody +| a, i, b => + if i == 0 then b + else + let i := i - 1; + let (curr, a) := a.swapAt! i (arbitrary _); + let b := curr.setBody b; + reshapeAux a i b + +def reshape (bs : Array FnBody) (term : FnBody) : FnBody := +reshapeAux bs bs.size term + +@[inline] def modifyJPs (bs : Array FnBody) (f : FnBody → FnBody) : Array FnBody := +bs.map $ fun b => match b with + | FnBody.jdecl j xs v k => FnBody.jdecl j xs (f v) k + | other => other + +@[inline] def mmodifyJPs {m : Type → Type} [Monad m] (bs : Array FnBody) (f : FnBody → m FnBody) : m (Array FnBody) := +bs.mapM $ fun b => match b with + | FnBody.jdecl j xs v k => do v ← f v; pure $ FnBody.jdecl j xs v k + | other => pure other + +@[export lean_ir_mk_alt] def mkAlt (n : Name) (cidx : Nat) (size : Nat) (usize : Nat) (ssize : Nat) (b : FnBody) : Alt := Alt.ctor ⟨n, cidx, size, usize, ssize⟩ b + +inductive Decl +| fdecl (f : FunId) (xs : Array Param) (ty : IRType) (b : FnBody) +| extern (f : FunId) (xs : Array Param) (ty : IRType) (ext : ExternAttrData) + +namespace Decl + +instance : Inhabited Decl := +⟨fdecl (arbitrary _) (arbitrary _) IRType.irrelevant (arbitrary _)⟩ + +def name : Decl → FunId +| Decl.fdecl f _ _ _ => f +| Decl.extern f _ _ _ => f + +def params : Decl → Array Param +| Decl.fdecl _ xs _ _ => xs +| Decl.extern _ xs _ _ => xs + +def resultType : Decl → IRType +| Decl.fdecl _ _ t _ => t +| Decl.extern _ _ t _ => t + +def isExtern : Decl → Bool +| Decl.extern _ _ _ _ => true +| _ => false + +end Decl + +@[export lean_ir_mk_decl] def mkDecl (f : FunId) (xs : Array Param) (ty : IRType) (b : FnBody) : Decl := Decl.fdecl f xs ty b + +@[export lean_ir_mk_extern_decl] def mkExternDecl (f : FunId) (xs : Array Param) (ty : IRType) (e : ExternAttrData) : Decl := +Decl.extern f xs ty e + +/-- Set of variable and join point names -/ +abbrev IndexSet := RBTree Index Index.lt +instance vsetInh : Inhabited IndexSet := ⟨{}⟩ + +def mkIndexSet (idx : Index) : IndexSet := +RBTree.empty.insert idx + +inductive LocalContextEntry +| param : IRType → LocalContextEntry +| localVar : IRType → Expr → LocalContextEntry +| joinPoint : Array Param → FnBody → LocalContextEntry + +abbrev LocalContext := RBMap Index LocalContextEntry Index.lt + +def LocalContext.addLocal (ctx : LocalContext) (x : VarId) (t : IRType) (v : Expr) : LocalContext := +ctx.insert x.idx (LocalContextEntry.localVar t v) + +def LocalContext.addJP (ctx : LocalContext) (j : JoinPointId) (xs : Array Param) (b : FnBody) : LocalContext := +ctx.insert j.idx (LocalContextEntry.joinPoint xs b) + +def LocalContext.addParam (ctx : LocalContext) (p : Param) : LocalContext := +ctx.insert p.x.idx (LocalContextEntry.param p.ty) + +def LocalContext.addParams (ctx : LocalContext) (ps : Array Param) : LocalContext := +ps.foldl LocalContext.addParam ctx + +def LocalContext.isJP (ctx : LocalContext) (idx : Index) : Bool := +match ctx.find idx with +| some (LocalContextEntry.joinPoint _ _) => true +| other => false + +def LocalContext.getJPBody (ctx : LocalContext) (j : JoinPointId) : Option FnBody := +match ctx.find j.idx with +| some (LocalContextEntry.joinPoint _ b) => some b +| other => none + +def LocalContext.getJPParams (ctx : LocalContext) (j : JoinPointId) : Option (Array Param) := +match ctx.find j.idx with +| some (LocalContextEntry.joinPoint ys _) => some ys +| other => none + +def LocalContext.isParam (ctx : LocalContext) (idx : Index) : Bool := +match ctx.find idx with +| some (LocalContextEntry.param _) => true +| other => false + +def LocalContext.isLocalVar (ctx : LocalContext) (idx : Index) : Bool := +match ctx.find idx with +| some (LocalContextEntry.localVar _ _) => true +| other => false + +def LocalContext.contains (ctx : LocalContext) (idx : Index) : Bool := +ctx.contains idx + +def LocalContext.eraseJoinPointDecl (ctx : LocalContext) (j : JoinPointId) : LocalContext := +ctx.erase j.idx + +def LocalContext.getType (ctx : LocalContext) (x : VarId) : Option IRType := +match ctx.find x.idx with +| some (LocalContextEntry.param t) => some t +| some (LocalContextEntry.localVar t _) => some t +| other => none + +def LocalContext.getValue (ctx : LocalContext) (x : VarId) : Option Expr := +match ctx.find x.idx with +| some (LocalContextEntry.localVar _ v) => some v +| other => none + +abbrev IndexRenaming := RBMap Index Index Index.lt + +class HasAlphaEqv (α : Type) := +(aeqv : IndexRenaming → α → α → Bool) + +export HasAlphaEqv (aeqv) + +def VarId.alphaEqv (ρ : IndexRenaming) (v₁ v₂ : VarId) : Bool := +match ρ.find v₁.idx with +| some v => v == v₂.idx +| none => v₁ == v₂ + +instance VarId.hasAeqv : HasAlphaEqv VarId := ⟨VarId.alphaEqv⟩ + +def Arg.alphaEqv (ρ : IndexRenaming) : Arg → Arg → Bool +| Arg.var v₁, Arg.var v₂ => aeqv ρ v₁ v₂ +| Arg.irrelevant, Arg.irrelevant => true +| _, _ => false + +instance Arg.hasAeqv : HasAlphaEqv Arg := ⟨Arg.alphaEqv⟩ + +def args.alphaEqv (ρ : IndexRenaming) (args₁ args₂ : Array Arg) : Bool := +Array.isEqv args₁ args₂ (fun a b => aeqv ρ a b) + +instance args.hasAeqv : HasAlphaEqv (Array Arg) := ⟨args.alphaEqv⟩ + +def Expr.alphaEqv (ρ : IndexRenaming) : Expr → Expr → Bool +| Expr.ctor i₁ ys₁, Expr.ctor i₂ ys₂ => i₁ == i₂ && aeqv ρ ys₁ ys₂ +| Expr.reset n₁ x₁, Expr.reset n₂ x₂ => n₁ == n₂ && aeqv ρ x₁ x₂ +| Expr.reuse x₁ i₁ u₁ ys₁, Expr.reuse x₂ i₂ u₂ ys₂ => aeqv ρ x₁ x₂ && i₁ == i₂ && u₁ == u₂ && aeqv ρ ys₁ ys₂ +| Expr.proj i₁ x₁, Expr.proj i₂ x₂ => i₁ == i₂ && aeqv ρ x₁ x₂ +| Expr.uproj i₁ x₁, Expr.uproj i₂ x₂ => i₁ == i₂ && aeqv ρ x₁ x₂ +| Expr.sproj n₁ o₁ x₁, Expr.sproj n₂ o₂ x₂ => n₁ == n₂ && o₁ == o₂ && aeqv ρ x₁ x₂ +| Expr.fap c₁ ys₁, Expr.fap c₂ ys₂ => c₁ == c₂ && aeqv ρ ys₁ ys₂ +| Expr.pap c₁ ys₁, Expr.pap c₂ ys₂ => c₁ == c₂ && aeqv ρ ys₂ ys₂ +| Expr.ap x₁ ys₁, Expr.ap x₂ ys₂ => aeqv ρ x₁ x₂ && aeqv ρ ys₁ ys₂ +| Expr.box ty₁ x₁, Expr.box ty₂ x₂ => ty₁ == ty₂ && aeqv ρ x₁ x₂ +| Expr.unbox x₁, Expr.unbox x₂ => aeqv ρ x₁ x₂ +| Expr.lit v₁, Expr.lit v₂ => v₁ == v₂ +| Expr.isShared x₁, Expr.isShared x₂ => aeqv ρ x₁ x₂ +| Expr.isTaggedPtr x₁, Expr.isTaggedPtr x₂ => aeqv ρ x₁ x₂ +| _, _ => false + +instance Expr.hasAeqv : HasAlphaEqv Expr:= ⟨Expr.alphaEqv⟩ + +def addVarRename (ρ : IndexRenaming) (x₁ x₂ : Nat) := +if x₁ == x₂ then ρ else ρ.insert x₁ x₂ + +def addParamRename (ρ : IndexRenaming) (p₁ p₂ : Param) : Option IndexRenaming := +if p₁.ty == p₂.ty && p₁.borrow = p₂.borrow then some (addVarRename ρ p₁.x.idx p₂.x.idx) +else none + +def addParamsRename (ρ : IndexRenaming) (ps₁ ps₂ : Array Param) : Option IndexRenaming := +if ps₁.size != ps₂.size then none +else Array.foldl₂ (fun ρ p₁ p₂ => do ρ ← ρ; addParamRename ρ p₁ p₂) (some ρ) ps₁ ps₂ + +partial def FnBody.alphaEqv : IndexRenaming → FnBody → FnBody → Bool +| ρ, FnBody.vdecl x₁ t₁ v₁ b₁, FnBody.vdecl x₂ t₂ v₂ b₂ => t₁ == t₂ && aeqv ρ v₁ v₂ && FnBody.alphaEqv (addVarRename ρ x₁.idx x₂.idx) b₁ b₂ +| ρ, FnBody.jdecl j₁ ys₁ v₁ b₁, FnBody.jdecl j₂ ys₂ v₂ b₂ => match addParamsRename ρ ys₁ ys₂ with + | some ρ' => FnBody.alphaEqv ρ' v₁ v₂ && FnBody.alphaEqv (addVarRename ρ j₁.idx j₂.idx) b₁ b₂ + | none => false +| ρ, FnBody.set x₁ i₁ y₁ b₁, FnBody.set x₂ i₂ y₂ b₂ => aeqv ρ x₁ x₂ && i₁ == i₂ && aeqv ρ y₁ y₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.uset x₁ i₁ y₁ b₁, FnBody.uset x₂ i₂ y₂ b₂ => aeqv ρ x₁ x₂ && i₁ == i₂ && aeqv ρ y₁ y₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.sset x₁ i₁ o₁ y₁ t₁ b₁, FnBody.sset x₂ i₂ o₂ y₂ t₂ b₂ => + aeqv ρ x₁ x₂ && i₁ = i₂ && o₁ = o₂ && aeqv ρ y₁ y₂ && t₁ == t₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.setTag x₁ i₁ b₁, FnBody.setTag x₂ i₂ b₂ => aeqv ρ x₁ x₂ && i₁ == i₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.inc x₁ n₁ c₁ p₁ b₁, FnBody.inc x₂ n₂ c₂ p₂ b₂ => aeqv ρ x₁ x₂ && n₁ == n₂ && c₁ == c₂ && p₁ == p₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.dec x₁ n₁ c₁ p₁ b₁, FnBody.dec x₂ n₂ c₂ p₂ b₂ => aeqv ρ x₁ x₂ && n₁ == n₂ && c₁ == c₂ && p₁ == p₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.del x₁ b₁, FnBody.del x₂ b₂ => aeqv ρ x₁ x₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.mdata m₁ b₁, FnBody.mdata m₂ b₂ => m₁ == m₂ && FnBody.alphaEqv ρ b₁ b₂ +| ρ, FnBody.case n₁ x₁ _ alts₁, FnBody.case n₂ x₂ _ alts₂ => n₁ == n₂ && aeqv ρ x₁ x₂ && Array.isEqv alts₁ alts₂ (fun alt₁ alt₂ => + match alt₁, alt₂ with + | Alt.ctor i₁ b₁, Alt.ctor i₂ b₂ => i₁ == i₂ && FnBody.alphaEqv ρ b₁ b₂ + | Alt.default b₁, Alt.default b₂ => FnBody.alphaEqv ρ b₁ b₂ + | _, _ => false) +| ρ, FnBody.jmp j₁ ys₁, FnBody.jmp j₂ ys₂ => j₁ == j₂ && aeqv ρ ys₁ ys₂ +| ρ, FnBody.ret x₁, FnBody.ret x₂ => aeqv ρ x₁ x₂ +| _, FnBody.unreachable, FnBody.unreachable => true +| _, _, _ => false + +def FnBody.beq (b₁ b₂ : FnBody) : Bool := +FnBody.alphaEqv ∅ b₁ b₂ + +instance FnBody.HasBeq : HasBeq FnBody := ⟨FnBody.beq⟩ + +abbrev VarIdSet := RBTree VarId (fun x y => x.idx < y.idx) +namespace VarIdSet +instance : Inhabited VarIdSet := ⟨{}⟩ +end VarIdSet + +def mkIf (x : VarId) (t e : FnBody) : FnBody := +FnBody.case `Bool x IRType.uint8 #[ + Alt.ctor {name := `Bool.false, cidx := 0, size := 0, usize := 0, ssize := 0} e, + Alt.ctor {name := `Bool.true, cidx := 1, size := 0, usize := 0, ssize := 0} t +] + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/Borrow.lean b/stage0/src/Init/Lean/Compiler/IR/Borrow.lean new file mode 100644 index 0000000000..18b81300e8 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/Borrow.lean @@ -0,0 +1,316 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Nat +import Init.Lean.Compiler.ExportAttr +import Init.Lean.Compiler.IR.CompilerM +import Init.Lean.Compiler.IR.NormIds + +namespace Lean +namespace IR +namespace Borrow +/- We perform borrow inference in a block of mutually recursive functions. + Join points are viewed as local functions, and are identified using + their local id + the name of the surrounding function. + + We keep a mapping from function and joint points to parameters (`Array Param`). + Recall that `Param` contains the field `borrow`. + The type `Key` is the the key of this map. -/ +inductive Key +| decl (name : FunId) +| jp (name : FunId) (jpid : JoinPointId) + +namespace Key +def beq : Key → Key → Bool +| decl n₁, decl n₂ => n₁ == n₂ +| jp n₁ id₁, jp n₂ id₂ => n₁ == n₂ && id₁ == id₂ +| _, _ => false + +instance : HasBeq Key := ⟨beq⟩ + +def getHash : Key → USize +| decl n => hash n +| jp n id => mixHash (hash n) (hash id) + +instance : Hashable Key := ⟨getHash⟩ +end Key + +abbrev ParamMap := HashMap Key (Array Param) + +def ParamMap.fmt (map : ParamMap) : Format := +let fmts := map.fold (fun fmt k ps => + let k := match k with + | Key.decl n => format n + | Key.jp n id => format n ++ ":" ++ format id; + fmt ++ Format.line ++ k ++ " -> " ++ formatParams ps) + Format.nil; +"{" ++ (Format.nest 1 fmts) ++ "}" + +instance : HasFormat ParamMap := ⟨ParamMap.fmt⟩ +instance : HasToString ParamMap := ⟨fun m => Format.pretty (format m)⟩ + +namespace InitParamMap + +/- Mark parameters that take a reference as borrow -/ +def initBorrow (ps : Array Param) : Array Param := +ps.map $ fun p => { borrow := p.ty.isObj, .. p } + +/- We do perform borrow inference for constants marked as `export`. + Reason: we current write wrappers in C++ for using exported functions. + These wrappers use smart pointers such as `object_ref`. + When writing a new wrapper we need to know whether an argument is a borrow + inference or not. + + We can revise this decision when we implement code for generating + the wrappers automatically. -/ +def initBorrowIfNotExported (exported : Bool) (ps : Array Param) : Array Param := +if exported then ps else initBorrow ps + +partial def visitFnBody (fnid : FunId) : FnBody → StateM ParamMap Unit +| FnBody.jdecl j xs v b => do + modify $ fun m => m.insert (Key.jp fnid j) (initBorrow xs); + visitFnBody v; + visitFnBody b +| e => + unless (e.isTerminal) $ do + let (instr, b) := e.split; + visitFnBody b + +def visitDecls (env : Environment) (decls : Array Decl) : StateM ParamMap Unit := +decls.forM $ fun decl => match decl with + | Decl.fdecl f xs _ b => do + let exported := isExport env f; + modify $ fun m => m.insert (Key.decl f) (initBorrowIfNotExported exported xs); + visitFnBody f b + | _ => pure () +end InitParamMap + +def mkInitParamMap (env : Environment) (decls : Array Decl) : ParamMap := +(InitParamMap.visitDecls env decls *> get).run' {} + +/- Apply the inferred borrow annotations stored at `ParamMap` to a block of mutually + recursive functions. -/ +namespace ApplyParamMap + +partial def visitFnBody : FnBody → FunId → ParamMap → FnBody +| FnBody.jdecl j xs v b, fnid, map => + let v := visitFnBody v fnid map; + let b := visitFnBody b fnid map; + match map.find (Key.jp fnid j) with + | some ys => FnBody.jdecl j ys v b + | none => FnBody.jdecl j xs v b +| e, fnid, map => + if e.isTerminal then e + else + let (instr, b) := e.split; + let b := visitFnBody b fnid map; + instr.setBody b + +def visitDecls (decls : Array Decl) (map : ParamMap) : Array Decl := +decls.map $ fun decl => match decl with + | Decl.fdecl f xs ty b => + let b := visitFnBody b f map; + match map.find (Key.decl f) with + | some xs => Decl.fdecl f xs ty b + | none => Decl.fdecl f xs ty b + | other => other + +end ApplyParamMap + +def applyParamMap (decls : Array Decl) (map : ParamMap) : Array Decl := +-- dbgTrace ("applyParamMap " ++ toString map) $ fun _ => +ApplyParamMap.visitDecls decls map + +structure BorrowInfCtx := +(env : Environment) +(currFn : FunId := arbitrary _) -- Function being analyzed. +(paramSet : IndexSet := {}) -- Set of all function parameters in scope. This is used to implement the heuristic at `ownArgsUsingParams` + +structure BorrowInfState := +/- `map` is a mapping storing the inferred borrow annotations for all functions (and joint points) in a mutually recursive declaration. -/ +(map : ParamMap) +/- Set of variables that must be `owned`. -/ +(owned : IndexSet := {}) +(modifiedOwned : Bool := false) +(modifiedParamMap : Bool := false) + +abbrev M := ReaderT BorrowInfCtx (StateM BorrowInfState) + +def markModifiedParamMap : M Unit := +modify $ fun s => { modifiedParamMap := true, .. s } + +def ownVar (x : VarId) : M Unit := +-- dbgTrace ("ownVar " ++ toString x) $ fun _ => +modify $ fun s => + if s.owned.contains x.idx then s + else { owned := s.owned.insert x.idx, modifiedOwned := true, .. s } + +def ownArg (x : Arg) : M Unit := +match x with +| (Arg.var x) => ownVar x +| _ => pure () + +def ownArgs (xs : Array Arg) : M Unit := +xs.forM ownArg + +def isOwned (x : VarId) : M Bool := +do s ← get; + pure $ s.owned.contains x.idx + +/- Updates `map[k]` using the current set of `owned` variables. -/ +def updateParamMap (k : Key) : M Unit := +do s ← get; + match s.map.find k with + | some ps => do + ps ← ps.mapM $ fun (p : Param) => + if p.borrow && s.owned.contains p.x.idx then do + markModifiedParamMap; pure { borrow := false, .. p } + else + pure p; + modify $ fun s => { map := s.map.insert k ps, .. s } + | none => pure () + +def getParamInfo (k : Key) : M (Array Param) := +do s ← get; + match s.map.find k with + | some ps => pure ps + | none => + match k with + | (Key.decl fn) => do + ctx ← read; + match findEnvDecl ctx.env fn with + | some decl => pure decl.params + | none => pure #[] -- unreachable if well-formed input + | _ => pure #[] -- unreachable if well-formed input + +/- For each ps[i], if ps[i] is owned, then mark xs[i] as owned. -/ +def ownArgsUsingParams (xs : Array Arg) (ps : Array Param) : M Unit := +xs.size.forM $ fun i => do + let x := xs.get! i; + let p := ps.get! i; + unless p.borrow $ ownArg x + +/- For each xs[i], if xs[i] is owned, then mark ps[i] as owned. + We use this action to preserve tail calls. That is, if we have + a tail call `f xs`, if the i-th parameter is borrowed, but `xs[i]` is owned + we would have to insert a `dec xs[i]` after `f xs` and consequently + "break" the tail call. -/ +def ownParamsUsingArgs (xs : Array Arg) (ps : Array Param) : M Unit := +xs.size.forM $ fun i => do + let x := xs.get! i; + let p := ps.get! i; + match x with + | Arg.var x => whenM (isOwned x) $ ownVar p.x + | _ => pure () + +/- Mark `xs[i]` as owned if it is one of the parameters `ps`. + We use this action to mark function parameters that are being "packed" inside constructors. + This is a heuristic, and is not related with the effectiveness of the reset/reuse optimization. + It is useful for code such as + ``` + def f (x y : obj) := + let z := ctor_1 x y; + ret z + ``` +-/ +def ownArgsIfParam (xs : Array Arg) : M Unit := +do ctx ← read; + xs.forM $ fun x => + match x with + | Arg.var x => when (ctx.paramSet.contains x.idx) $ ownVar x + | _ => pure () + +def collectExpr (z : VarId) : Expr → M Unit +| Expr.reset _ x => ownVar z *> ownVar x +| Expr.reuse x _ _ ys => ownVar z *> ownVar x *> ownArgsIfParam ys +| Expr.ctor _ xs => ownVar z *> ownArgsIfParam xs +| Expr.proj _ x => whenM (isOwned z) $ ownVar x +| Expr.fap g xs => do ps ← getParamInfo (Key.decl g); + -- dbgTrace ("collectExpr: " ++ toString g ++ " " ++ toString (formatParams ps)) $ fun _ => + ownVar z *> ownArgsUsingParams xs ps +| Expr.ap x ys => ownVar z *> ownVar x *> ownArgs ys +| Expr.pap _ xs => ownVar z *> ownArgs xs +| other => pure () + +def preserveTailCall (x : VarId) (v : Expr) (b : FnBody) : M Unit := +do ctx ← read; +match v, b with +| (Expr.fap g ys), (FnBody.ret (Arg.var z)) => + when (ctx.currFn == g && x == z) $ do + -- dbgTrace ("preserveTailCall " ++ toString b) $ fun _ => do + ps ← getParamInfo (Key.decl g); + ownParamsUsingArgs ys ps +| _, _ => pure () + +def updateParamSet (ctx : BorrowInfCtx) (ps : Array Param) : BorrowInfCtx := +{ paramSet := ps.foldl (fun s p => s.insert p.x.idx) ctx.paramSet, .. ctx } + +partial def collectFnBody : FnBody → M Unit +| FnBody.jdecl j ys v b => do + adaptReader (fun ctx => updateParamSet ctx ys) (collectFnBody v); + ctx ← read; + updateParamMap (Key.jp ctx.currFn j); + collectFnBody b +| FnBody.vdecl x _ v b => collectFnBody b *> collectExpr x v *> preserveTailCall x v b +| FnBody.jmp j ys => do + ctx ← read; + ps ← getParamInfo (Key.jp ctx.currFn j); + ownArgsUsingParams ys ps; -- for making sure the join point can reuse + ownParamsUsingArgs ys ps -- for making sure the tail call is preserved +| FnBody.case _ _ _ alts => alts.forM $ fun alt => collectFnBody alt.body +| e => unless (e.isTerminal) $ collectFnBody e.body + +@[specialize] partial def whileModifingOwnedAux (x : M Unit) : Unit → M Unit +| _ => do + modify $ fun s => { modifiedOwned := false, .. s }; + x; + s ← get; + if s.modifiedOwned then whileModifingOwnedAux () + else pure () + +/- Keep executing `x` while it modifies ownedSet -/ +@[inline] def whileModifingOwned (x : M Unit) : M Unit := +whileModifingOwnedAux x () + +partial def collectDecl : Decl → M Unit +| Decl.fdecl f ys _ b => + adaptReader (fun ctx => let ctx := updateParamSet ctx ys; { currFn := f, .. ctx }) $ do + modify $ fun (s : BorrowInfState) => { owned := {}, .. s }; + whileModifingOwned (collectFnBody b); + updateParamMap (Key.decl f) +| _ => pure () + +@[specialize] partial def whileModifingParamMapAux (x : M Unit) : Unit → M Unit +| _ => do + modify $ fun s => { modifiedParamMap := false, .. s }; + s ← get; + -- dbgTrace (toString s.map) $ fun _ => do + x; + s ← get; + if s.modifiedParamMap then whileModifingParamMapAux () + else pure () + +/- Keep executing `x` while it modifies paramMap -/ +@[inline] def whileModifingParamMap (x : M Unit) : M Unit := +whileModifingParamMapAux x () + +def collectDecls (decls : Array Decl) : M ParamMap := +do whileModifingParamMap (decls.forM collectDecl); + s ← get; + pure s.map + +def infer (env : Environment) (decls : Array Decl) : ParamMap := +(collectDecls decls { env := env }).run' { map := mkInitParamMap env decls } + +end Borrow + +def inferBorrow (decls : Array Decl) : CompilerM (Array Decl) := +do env ← getEnv; + let paramMap := Borrow.infer env decls; + pure (Borrow.applyParamMap decls paramMap) + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/Boxing.lean b/stage0/src/Init/Lean/Compiler/IR/Boxing.lean new file mode 100644 index 0000000000..0953a3664b --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/Boxing.lean @@ -0,0 +1,345 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.EState +import Init.Control.Reader +import Init.Data.AssocList +import Init.Data.Nat +import Init.Lean.Runtime +import Init.Lean.Compiler.ClosedTermCache +import Init.Lean.Compiler.ExternAttr +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.CompilerM +import Init.Lean.Compiler.IR.FreeVars +import Init.Lean.Compiler.IR.ElimDeadVars + +namespace Lean +namespace IR +namespace ExplicitBoxing +/- +Add explicit boxing and unboxing instructions. +Recall that the Lean to λ_pure compiler produces code without these instructions. + +Assumptions: +- This transformation is applied before explicit RC instructions (`inc`, `dec`) are inserted. +- This transformation is applied before `FnBody.case` has been simplified and `Alt.default` is used. + Reason: if there is no `Alt.default` branch, then we can decide whether `x` at `FnBody.case x alts` is an + enumeration type by simply inspecting the `CtorInfo` values at `alts`. +- This transformation is applied before lower level optimizations are applied which use + `Expr.isShared`, `Expr.isTaggedPtr`, and `FnBody.set`. +- This transformation is applied after `reset` and `reuse` instructions have been added. + Reason: `resetreuse.lean` ignores `box` and `unbox` instructions. +-/ + +def mkBoxedName (n : Name) : Name := +mkNameStr n "_boxed" + +def isBoxedName : Name → Bool +| Name.str _ "_boxed" _ => true +| _ => false + +abbrev N := StateM Nat + +private def mkFresh : N VarId := +modifyGet $ fun n => ({ idx := n }, n + 1) + +def requiresBoxedVersion (env : Environment) (decl : Decl) : Bool := +let ps := decl.params; +(ps.size > 0 && (decl.resultType.isScalar || ps.any (fun p => p.ty.isScalar || p.borrow) || isExtern env decl.name)) +|| ps.size > closureMaxArgs + +def mkBoxedVersionAux (decl : Decl) : N Decl := +do let ps := decl.params; + qs ← ps.mapM (fun _ => do x ← mkFresh; pure { Param . x := x, ty := IRType.object, borrow := false }); + (newVDecls, xs) ← qs.size.foldM + (fun i (r : Array FnBody × Array Arg) => + let (newVDecls, xs) := r; + let p := ps.get! i; + let q := qs.get! i; + if !p.ty.isScalar then pure (newVDecls, xs.push (Arg.var q.x)) + else do + x ← mkFresh; + pure (newVDecls.push (FnBody.vdecl x p.ty (Expr.unbox q.x) (arbitrary _)), xs.push (Arg.var x))) + (#[], #[]); + r ← mkFresh; + let newVDecls := newVDecls.push (FnBody.vdecl r decl.resultType (Expr.fap decl.name xs) (arbitrary _)); + body ← + if !decl.resultType.isScalar then do { + pure $ reshape newVDecls (FnBody.ret (Arg.var r)) + } else do { + newR ← mkFresh; + let newVDecls := newVDecls.push (FnBody.vdecl newR IRType.object (Expr.box decl.resultType r) (arbitrary _)); + pure $ reshape newVDecls (FnBody.ret (Arg.var newR)) + }; + pure $ Decl.fdecl (mkBoxedName decl.name) qs IRType.object body + +def mkBoxedVersion (decl : Decl) : Decl := +(mkBoxedVersionAux decl).run' 1 + +def addBoxedVersions (env : Environment) (decls : Array Decl) : Array Decl := +let boxedDecls := decls.foldl + (fun (newDecls : Array Decl) decl => if requiresBoxedVersion env decl then newDecls.push (mkBoxedVersion decl) else newDecls) + #[]; +decls ++ boxedDecls + +/- Infer scrutinee type using `case` alternatives. + This can be done whenever `alts` does not contain an `Alt.default _` value. -/ +def getScrutineeType (alts : Array Alt) : IRType := +let isScalar := + alts.size > 1 && -- Recall that we encode Unit and PUnit using `object`. + alts.all (fun alt => match alt with + | Alt.ctor c _ => c.isScalar + | Alt.default _ => false); +match isScalar with +| false => IRType.object +| true => + let n := alts.size; + if n < 256 then IRType.uint8 + else if n < 65536 then IRType.uint16 + else if n < 4294967296 then IRType.uint32 + else IRType.object -- in practice this should be unreachable + +def eqvTypes (t₁ t₂ : IRType) : Bool := +(t₁.isScalar == t₂.isScalar) && (!t₁.isScalar || t₁ == t₂) + +structure BoxingContext := +(f : FunId := arbitrary _) (localCtx : LocalContext := {}) (resultType : IRType := IRType.irrelevant) (decls : Array Decl) (env : Environment) + +structure BoxingState := +(nextIdx : Index) +/- We create auxiliary declarations when boxing constant and literals. + The idea is to avoid code such as + ``` + let x1 := Uint64.inhabited; + let x2 := box x1; + ... + ``` + We currently do not cache these declarations in an environment extension, but + we use auxDeclCache to avoid creating equivalent auxiliary declarations more than once when + processing the same IR declaration. +-/ +(auxDecls : Array Decl := #[]) +(auxDeclCache : AssocList FnBody Expr := AssocList.empty) +(nextAuxId : Nat := 1) + +abbrev M := ReaderT BoxingContext (StateT BoxingState Id) + +def mkFresh : M VarId := +do oldS ← getModify (fun s => { nextIdx := s.nextIdx + 1, .. s }); + pure { idx := oldS.nextIdx } + +def getEnv : M Environment := BoxingContext.env <$> read +def getLocalContext : M LocalContext := BoxingContext.localCtx <$> read +def getResultType : M IRType := BoxingContext.resultType <$> read + +def getVarType (x : VarId) : M IRType := +do localCtx ← getLocalContext; + match localCtx.getType x with + | some t => pure t + | none => pure IRType.object -- unreachable, we assume the code is well formed +def getJPParams (j : JoinPointId) : M (Array Param) := +do localCtx ← getLocalContext; + match localCtx.getJPParams j with + | some ys => pure ys + | none => pure #[] -- unreachable, we assume the code is well formed +def getDecl (fid : FunId) : M Decl := +do ctx ← read; + match findEnvDecl' ctx.env fid ctx.decls with + | some decl => pure decl + | none => pure (arbitrary _) -- unreachable if well-formed + +@[inline] def withParams {α : Type} (xs : Array Param) (k : M α) : M α := +adaptReader (fun (ctx : BoxingContext) => { localCtx := ctx.localCtx.addParams xs, .. ctx }) k + +@[inline] def withVDecl {α : Type} (x : VarId) (ty : IRType) (v : Expr) (k : M α) : M α := +adaptReader (fun (ctx : BoxingContext) => { localCtx := ctx.localCtx.addLocal x ty v, .. ctx }) k + +@[inline] def withJDecl {α : Type} (j : JoinPointId) (xs : Array Param) (v : FnBody) (k : M α) : M α := +adaptReader (fun (ctx : BoxingContext) => { localCtx := ctx.localCtx.addJP j xs v, .. ctx }) k + +/- If `x` declaration is of the form `x := Expr.lit _` or `x := Expr.fap c #[]`, + and `x`'s type is not cheap to box (e.g., it is `UInt64), then return its value. -/ +private def isExpensiveConstantValueBoxing (x : VarId) (xType : IRType) : M (Option Expr) := +if !xType.isScalar then pure none -- We assume unboxing is always cheap +else match xType with +| IRType.uint8 => pure none +| IRType.uint16 => pure none +| _ => do + localCtx ← getLocalContext; + match localCtx.getValue x with + | some val => + match val with + | Expr.lit _ => pure $ some val + | Expr.fap _ args => pure $ if args.size == 0 then some val else none + | _ => pure none + | _ => pure none + +/- Auxiliary function used by castVarIfNeeded. + It is used when the expected type does not match `xType`. + If `xType` is scalar, then we need to "box" it. Otherwise, we need to "unbox" it. -/ +def mkCast (x : VarId) (xType : IRType) (expectedType : IRType) : M Expr := +do opt? ← isExpensiveConstantValueBoxing x xType; + match opt? with + | some v => do + ctx ← read; + s ← get; + /- Create auxiliary FnBody + ``` + let x_1 : xType := v; + let x_2 : expectedType := Expr.box xType x_1; + ret x_2 + ``` + -/ + let body : FnBody := + FnBody.vdecl { idx := 1 } xType v $ + FnBody.vdecl { idx := 2 } expectedType (Expr.box xType { idx := 1 }) $ + FnBody.ret (mkVarArg { idx := 2 }); + match s.auxDeclCache.find body with + | some v => pure v + | none => do + let auxName := ctx.f ++ ((`_boxed_const).appendIndexAfter s.nextAuxId); + let auxConst := Expr.fap auxName #[]; + let auxDecl := Decl.fdecl auxName #[] expectedType body; + modify $ fun s => { + auxDecls := s.auxDecls.push auxDecl, + auxDeclCache := s.auxDeclCache.cons body auxConst, + nextAuxId := s.nextAuxId + 1, + .. s + }; + pure auxConst + | none => pure $ if xType.isScalar then Expr.box xType x else Expr.unbox x + +@[inline] def castVarIfNeeded (x : VarId) (expected : IRType) (k : VarId → M FnBody) : M FnBody := +do xType ← getVarType x; + if eqvTypes xType expected then k x + else do + y ← mkFresh; + v ← mkCast x xType expected; + FnBody.vdecl y expected v <$> k y + +@[inline] def castArgIfNeeded (x : Arg) (expected : IRType) (k : Arg → M FnBody) : M FnBody := +match x with +| Arg.var x => castVarIfNeeded x expected (fun x => k (Arg.var x)) +| _ => k x + +@[specialize] def castArgsIfNeededAux (xs : Array Arg) (typeFromIdx : Nat → IRType) : M (Array Arg × Array FnBody) := +xs.iterateM (#[], #[]) $ fun i (x : Arg) (r : Array Arg × Array FnBody) => + let expected := typeFromIdx i.val; + let (xs, bs) := r; + match x with + | Arg.irrelevant => pure (xs.push x, bs) + | Arg.var x => do + xType ← getVarType x; + if eqvTypes xType expected then pure (xs.push (Arg.var x), bs) + else do + y ← mkFresh; + v ← mkCast x xType expected; + let b := FnBody.vdecl y expected v FnBody.nil; + pure (xs.push (Arg.var y), bs.push b) + +@[inline] def castArgsIfNeeded (xs : Array Arg) (ps : Array Param) (k : Array Arg → M FnBody) : M FnBody := +do (ys, bs) ← castArgsIfNeededAux xs (fun i => (ps.get! i).ty); + b ← k ys; + pure (reshape bs b) + +@[inline] def boxArgsIfNeeded (xs : Array Arg) (k : Array Arg → M FnBody) : M FnBody := +do (ys, bs) ← castArgsIfNeededAux xs (fun _ => IRType.object); + b ← k ys; + pure (reshape bs b) + +def unboxResultIfNeeded (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) : M FnBody := +if ty.isScalar then do + y ← mkFresh; + pure $ FnBody.vdecl y IRType.object e (FnBody.vdecl x ty (Expr.unbox y) b) +else + pure $ FnBody.vdecl x ty e b + +def castResultIfNeeded (x : VarId) (ty : IRType) (e : Expr) (eType : IRType) (b : FnBody) : M FnBody := +if eqvTypes ty eType then pure $ FnBody.vdecl x ty e b +else do + y ← mkFresh; + v ← mkCast y eType ty; + pure $ FnBody.vdecl y eType e (FnBody.vdecl x ty v b) + +def visitVDeclExpr (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) : M FnBody := +match e with +| Expr.ctor c ys => + if c.isScalar && ty.isScalar then + pure $ FnBody.vdecl x ty (Expr.lit (LitVal.num c.cidx)) b + else + boxArgsIfNeeded ys $ fun ys => pure $ FnBody.vdecl x ty (Expr.ctor c ys) b +| Expr.reuse w c u ys => + boxArgsIfNeeded ys $ fun ys => pure $ FnBody.vdecl x ty (Expr.reuse w c u ys) b +| Expr.fap f ys => do + decl ← getDecl f; + castArgsIfNeeded ys decl.params $ fun ys => + castResultIfNeeded x ty (Expr.fap f ys) decl.resultType b +| Expr.pap f ys => do + env ← getEnv; + decl ← getDecl f; + let f := if requiresBoxedVersion env decl then mkBoxedName f else f; + boxArgsIfNeeded ys $ fun ys => pure $ FnBody.vdecl x ty (Expr.pap f ys) b +| Expr.ap f ys => + boxArgsIfNeeded ys $ fun ys => + unboxResultIfNeeded x ty (Expr.ap f ys) b +| other => + pure $ FnBody.vdecl x ty e b + +partial def visitFnBody : FnBody → M FnBody +| FnBody.vdecl x t v b => do + b ← withVDecl x t v (visitFnBody b); + visitVDeclExpr x t v b +| FnBody.jdecl j xs v b => do + v ← withParams xs (visitFnBody v); + b ← withJDecl j xs v (visitFnBody b); + pure $ FnBody.jdecl j xs v b +| FnBody.uset x i y b => do + b ← visitFnBody b; + castVarIfNeeded y IRType.usize $ fun y => + pure $ FnBody.uset x i y b +| FnBody.sset x i o y ty b => do + b ← visitFnBody b; + castVarIfNeeded y ty $ fun y => + pure $ FnBody.sset x i o y ty b +| FnBody.mdata d b => + FnBody.mdata d <$> visitFnBody b +| FnBody.case tid x _ alts => do + let expected := getScrutineeType alts; + alts ← alts.mapM $ fun alt => alt.mmodifyBody visitFnBody; + castVarIfNeeded x expected $ fun x => do + pure $ FnBody.case tid x expected alts +| FnBody.ret x => do + expected ← getResultType; + castArgIfNeeded x expected (fun x => pure $ FnBody.ret x) +| FnBody.jmp j ys => do + ps ← getJPParams j; + castArgsIfNeeded ys ps (fun ys => pure $ FnBody.jmp j ys) +| other => + pure other + +def run (env : Environment) (decls : Array Decl) : Array Decl := +let ctx : BoxingContext := { decls := decls, env := env }; +let decls := decls.foldl (fun (newDecls : Array Decl) (decl : Decl) => + match decl with + | Decl.fdecl f xs t b => + let nextIdx := decl.maxIndex + 1; + let (b, s) := (withParams xs (visitFnBody b) { f := f, resultType := t, .. ctx }).run { nextIdx := nextIdx }; + let newDecls := newDecls ++ s.auxDecls; + let newDecl := Decl.fdecl f xs t b; + let newDecl := newDecl.elimDead; + newDecls.push newDecl + | d => newDecls.push d) + #[]; +addBoxedVersions env decls + +end ExplicitBoxing + +def explicitBoxing (decls : Array Decl) : CompilerM (Array Decl) := +do env ← getEnv; + pure $ ExplicitBoxing.run env decls + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/Checker.lean b/stage0/src/Init/Lean/Compiler/IR/Checker.lean new file mode 100644 index 0000000000..3debe8b48b --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/Checker.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.CompilerM + +namespace Lean +namespace IR + +namespace Checker + +structure CheckerContext := +(env : Environment) (localCtx : LocalContext := {}) (decls : Array Decl) + +structure CheckerState := +(foundVars : IndexSet := {}) + +abbrev M := ReaderT CheckerContext (ExceptT String (StateT CheckerState Id)) + +def markIndex (i : Index) : M Unit := +do s ← get; + when (s.foundVars.contains i) $ throw ("variable / joinpoint index " ++ toString i ++ " has already been used"); + modify $ fun s => { foundVars := s.foundVars.insert i, .. s } + +def markVar (x : VarId) : M Unit := +markIndex x.idx + +def markJP (j : JoinPointId) : M Unit := +markIndex j.idx + +def getDecl (c : Name) : M Decl := +do ctx ← read; + match findEnvDecl' ctx.env c ctx.decls with + | none => throw ("unknown declaration '" ++ toString c ++ "'") + | some d => pure d + +def checkVar (x : VarId) : M Unit := +do ctx ← read; + unless (ctx.localCtx.isLocalVar x.idx || ctx.localCtx.isParam x.idx) $ throw ("unknown variable '" ++ toString x ++ "'") + +def checkJP (j : JoinPointId) : M Unit := +do ctx ← read; + unless (ctx.localCtx.isJP j.idx) $ throw ("unknown join point '" ++ toString j ++ "'") + +def checkArg (a : Arg) : M Unit := +match a with +| Arg.var x => checkVar x +| other => pure () + +def checkArgs (as : Array Arg) : M Unit := +as.forM checkArg + +@[inline] def checkEqTypes (ty₁ ty₂ : IRType) : M Unit := +unless (ty₁ == ty₂) $ throw ("unexpected type") + +@[inline] def checkType (ty : IRType) (p : IRType → Bool) : M Unit := +unless (p ty) $ throw ("unexpected type") + +def checkObjType (ty : IRType) : M Unit := checkType ty IRType.isObj + +def checkScalarType (ty : IRType) : M Unit := checkType ty IRType.isScalar + +def getType (x : VarId) : M IRType := +do ctx ← read; + match ctx.localCtx.getType x with + | some ty => pure ty + | none => throw ("unknown variable '" ++ toString x ++ "'") + +@[inline] def checkVarType (x : VarId) (p : IRType → Bool) : M Unit := +do ty ← getType x; checkType ty p + +def checkObjVar (x : VarId) : M Unit := +checkVarType x IRType.isObj + +def checkScalarVar (x : VarId) : M Unit := +checkVarType x IRType.isScalar + +def checkFullApp (c : FunId) (ys : Array Arg) : M Unit := +do decl ← getDecl c; + unless (ys.size == decl.params.size) (throw ("incorrect number of arguments to '" ++ toString c ++ "', " ++ toString ys.size ++ " provided, " ++ toString decl.params.size ++ " expected")); + checkArgs ys + +def checkPartialApp (c : FunId) (ys : Array Arg) : M Unit := +do decl ← getDecl c; + unless (ys.size < decl.params.size) (throw ("too many arguments too partial application '" ++ toString c ++ "', num. args: " ++ toString ys.size ++ ", arity: " ++ toString decl.params.size)); + checkArgs ys + +def checkExpr (ty : IRType) : Expr → M Unit +| Expr.pap f ys => checkPartialApp f ys *> checkObjType ty -- partial applications should always produce a closure object +| Expr.ap x ys => checkObjVar x *> checkArgs ys +| Expr.fap f ys => checkFullApp f ys +| Expr.ctor c ys => when (!ty.isStruct && !ty.isUnion && c.isRef) (checkObjType ty) *> checkArgs ys +| Expr.reset _ x => checkObjVar x *> checkObjType ty +| Expr.reuse x i u ys => checkObjVar x *> checkArgs ys *> checkObjType ty +| Expr.box xty x => checkObjType ty *> checkScalarVar x *> checkVarType x (fun t => t == xty) +| Expr.unbox x => checkScalarType ty *> checkObjVar x +| Expr.proj i x => do xType ← getType x; + match xType with + | IRType.object => checkObjType ty + | IRType.tobject => checkObjType ty + | IRType.struct _ tys => if h : i < tys.size then checkEqTypes (tys.get ⟨i,h⟩) ty else throw "invalid proj index" + | IRType.union _ tys => if h : i < tys.size then checkEqTypes (tys.get ⟨i,h⟩) ty else throw "invalid proj index" + | other => throw "unexpected type" +| Expr.uproj _ x => checkObjVar x *> checkType ty (fun t => t == IRType.usize) +| Expr.sproj _ _ x => checkObjVar x *> checkScalarType ty +| Expr.isShared x => checkObjVar x *> checkType ty (fun t => t == IRType.uint8) +| Expr.isTaggedPtr x => checkObjVar x *> checkType ty (fun t => t == IRType.uint8) +| Expr.lit (LitVal.str _) => checkObjType ty +| Expr.lit _ => pure () + +@[inline] def withParams (ps : Array Param) (k : M Unit) : M Unit := +do ctx ← read; + localCtx ← ps.foldlM (fun (ctx : LocalContext) p => do + markVar p.x; + pure $ ctx.addParam p) ctx.localCtx; + adaptReader (fun _ => { localCtx := localCtx, .. ctx }) k + +partial def checkFnBody : FnBody → M Unit +| FnBody.vdecl x t v b => do + checkExpr t v; + markVar x; + ctx ← read; + adaptReader (fun (ctx : CheckerContext) => { localCtx := ctx.localCtx.addLocal x t v, .. ctx }) (checkFnBody b) +| FnBody.jdecl j ys v b => do + markJP j; + withParams ys (checkFnBody v); + ctx ← read; + adaptReader (fun (ctx : CheckerContext) => { localCtx := ctx.localCtx.addJP j ys v, .. ctx }) (checkFnBody b) +| FnBody.set x _ y b => checkVar x *> checkArg y *> checkFnBody b +| FnBody.uset x _ y b => checkVar x *> checkVar y *> checkFnBody b +| FnBody.sset x _ _ y _ b => checkVar x *> checkVar y *> checkFnBody b +| FnBody.setTag x _ b => checkVar x *> checkFnBody b +| FnBody.inc x _ _ _ b => checkVar x *> checkFnBody b +| FnBody.dec x _ _ _ b => checkVar x *> checkFnBody b +| FnBody.del x b => checkVar x *> checkFnBody b +| FnBody.mdata _ b => checkFnBody b +| FnBody.jmp j ys => checkJP j *> checkArgs ys +| FnBody.ret x => checkArg x +| FnBody.case _ x _ alts => checkVar x *> alts.forM (fun alt => checkFnBody alt.body) +| FnBody.unreachable => pure () + +def checkDecl : Decl → M Unit +| Decl.fdecl f xs t b => withParams xs (checkFnBody b) +| Decl.extern f xs t _ => withParams xs (pure ()) + +end Checker + +def checkDecl (decls : Array Decl) (decl : Decl) : CompilerM Unit := +do env ← getEnv; + match (Checker.checkDecl decl { env := env, decls := decls }).run' {} with + | Except.error msg => throw ("IR check failed at '" ++ toString decl.name ++ "', error: " ++ msg) + | other => pure () + +def checkDecls (decls : Array Decl) : CompilerM Unit := +decls.forM (checkDecl decls) + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/CompilerM.lean b/stage0/src/Init/Lean/Compiler/IR/CompilerM.lean new file mode 100644 index 0000000000..54f271cb86 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/CompilerM.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Reader +import Init.Lean.Environment +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.Format + +namespace Lean +namespace IR + +inductive LogEntry +| step (cls : Name) (decls : Array Decl) +| message (msg : Format) + +namespace LogEntry +protected def fmt : LogEntry → Format +| step cls decls => Format.bracket "[" (format cls) "]" ++ decls.foldl (fun fmt decl => fmt ++ Format.line ++ format decl) Format.nil +| message msg => msg + +instance : HasFormat LogEntry := ⟨LogEntry.fmt⟩ +end LogEntry + +abbrev Log := Array LogEntry + +def Log.format (log : Log) : Format := +log.foldl (fun fmt entry => fmt ++ Format.line ++ format entry) Format.nil + +@[export lean_ir_log_to_string] +def Log.toString (log : Log) : String := +log.format.pretty + +structure CompilerState := +(env : Environment) (log : Log := #[]) + +abbrev CompilerM := ReaderT Options (EStateM String CompilerState) + +def log (entry : LogEntry) : CompilerM Unit := +modify $ fun s => { log := s.log.push entry, .. s } + +def tracePrefixOptionName := `trace.compiler.ir + +private def isLogEnabledFor (opts : Options) (optName : Name) : Bool := +match opts.find optName with +| some (DataValue.ofBool v) => v +| other => opts.getBool tracePrefixOptionName + +private def logDeclsAux (optName : Name) (cls : Name) (decls : Array Decl) : CompilerM Unit := +do opts ← read; + when (isLogEnabledFor opts optName) $ log (LogEntry.step cls decls) + +@[inline] def logDecls (cls : Name) (decl : Array Decl) : CompilerM Unit := +logDeclsAux (tracePrefixOptionName ++ cls) cls decl + +private def logMessageIfAux {α : Type} [HasFormat α] (optName : Name) (a : α) : CompilerM Unit := +do opts ← read; + when (isLogEnabledFor opts optName) $ log (LogEntry.message (format a)) + +@[inline] def logMessageIf {α : Type} [HasFormat α] (cls : Name) (a : α) : CompilerM Unit := +logMessageIfAux (tracePrefixOptionName ++ cls) a + +@[inline] def logMessage {α : Type} [HasFormat α] (cls : Name) (a : α) : CompilerM Unit := +logMessageIfAux tracePrefixOptionName a + +@[inline] def modifyEnv (f : Environment → Environment) : CompilerM Unit := +modify $ fun s => { env := f s.env, .. s } + +abbrev DeclMap := SMap Name Decl + +/- Create an array of decls to be saved on .olean file. + `decls` may contain duplicate entries, but we assume the one that occurs last is the most recent one. -/ +private def mkEntryArray (decls : List Decl) : Array Decl := +/- Remove duplicates by adding decls into a map -/ +let map : HashMap Name Decl := {}; +let map := decls.foldl (fun (map : HashMap Name Decl) decl => map.insert decl.name decl) map; +map.fold (fun a k v => a.push v) #[] + +def mkDeclMapExtension : IO (SimplePersistentEnvExtension Decl DeclMap) := +registerSimplePersistentEnvExtension { + name := `IRDecls, + addImportedFn := fun as => + let m : DeclMap := mkStateFromImportedEntries (fun s (d : Decl) => s.insert d.name d) {} as; + m.switch, + addEntryFn := fun s d => s.insert d.name d, + toArrayFn := mkEntryArray +} + +@[init mkDeclMapExtension] +constant declMapExt : SimplePersistentEnvExtension Decl DeclMap := arbitrary _ + +@[export lean_ir_find_env_decl] +def findEnvDecl (env : Environment) (n : Name) : Option Decl := +(declMapExt.getState env).find n + +def findDecl (n : Name) : CompilerM (Option Decl) := +do s ← get; + pure $ findEnvDecl s.env n + +def containsDecl (n : Name) : CompilerM Bool := +do s ← get; + pure $ (declMapExt.getState s.env).contains n + +def getDecl (n : Name) : CompilerM Decl := +do (some decl) ← findDecl n | throw ("unknown declaration '" ++ toString n ++ "'"); + pure decl + +@[export lean_ir_add_decl] +def addDeclAux (env : Environment) (decl : Decl) : Environment := +declMapExt.addEntry env decl + +def getDecls (env : Environment) : List Decl := +declMapExt.getEntries env + +def getEnv : CompilerM Environment := +do s ← get; pure s.env + +def addDecl (decl : Decl) : CompilerM Unit := +modifyEnv (fun env => declMapExt.addEntry env decl) + +def addDecls (decls : Array Decl) : CompilerM Unit := +decls.forM addDecl + +def findEnvDecl' (env : Environment) (n : Name) (decls : Array Decl) : Option Decl := +match decls.find? (fun decl => if decl.name == n then some decl else none) with +| some decl => some decl +| none => (declMapExt.getState env).find n + +def findDecl' (n : Name) (decls : Array Decl) : CompilerM (Option Decl) := +do s ← get; pure $ findEnvDecl' s.env n decls + +def containsDecl' (n : Name) (decls : Array Decl) : CompilerM Bool := +if decls.any (fun decl => decl.name == n) then pure true +else do + s ← get; + pure $ (declMapExt.getState s.env).contains n + +def getDecl' (n : Name) (decls : Array Decl) : CompilerM Decl := +do (some decl) ← findDecl' n decls | throw ("unknown declaration '" ++ toString n ++ "'"); + pure decl + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/CtorLayout.lean b/stage0/src/Init/Lean/Compiler/IR/CtorLayout.lean new file mode 100644 index 0000000000..892dc2fad8 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/CtorLayout.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment +import Init.Lean.Compiler.IR.Format + +namespace Lean +namespace IR + +inductive CtorFieldInfo +| irrelevant +| object (i : Nat) +| usize (i : Nat) +| scalar (sz : Nat) (offset : Nat) (type : IRType) + +namespace CtorFieldInfo + +def format : CtorFieldInfo → Format +| irrelevant => "◾" +| object i => "obj@" ++ fmt i +| usize i => "usize@" ++ fmt i +| scalar sz offset type => "scalar#" ++ fmt sz ++ "@" ++ fmt offset ++ ":" ++ fmt type + +instance : HasFormat CtorFieldInfo := ⟨format⟩ + +end CtorFieldInfo + +structure CtorLayout := +(cidx : Nat) +(fieldInfo : List CtorFieldInfo) +(numObjs : Nat) +(numUSize : Nat) +(scalarSize : Nat) + +@[extern "lean_ir_get_ctor_layout"] +constant getCtorLayout (env : Environment) (ctorName : Name) : Except String CtorLayout := arbitrary _ + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/ElimDeadBranches.lean b/stage0/src/Init/Lean/Compiler/IR/ElimDeadBranches.lean new file mode 100644 index 0000000000..db15655e4f --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/ElimDeadBranches.lean @@ -0,0 +1,288 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Reader +import Init.Data.Option +import Init.Data.Nat +import Init.Lean.Compiler.IR.Format +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.CompilerM + +namespace Lean +namespace IR +namespace UnreachableBranches + +/-- Value used in the abstract interpreter -/ +inductive Value +| bot -- undefined +| top -- any value +| ctor (i : CtorInfo) (vs : Array Value) +| choice (vs : List Value) + +namespace Value + +instance : Inhabited Value := ⟨top⟩ + +protected partial def beq : Value → Value → Bool +| bot, bot => true +| top, top => true +| ctor i₁ vs₁, ctor i₂ vs₂ => i₁ == i₂ && Array.isEqv vs₁ vs₂ beq +| choice vs₁, choice vs₂ => + vs₁.all (fun v₁ => vs₂.any $ fun v₂ => beq v₁ v₂) + && + vs₂.all (fun v₂ => vs₁.any $ fun v₁ => beq v₁ v₂) +| _, _ => false + +instance : HasBeq Value := ⟨Value.beq⟩ + +partial def addChoice (merge : Value → Value → Value) : List Value → Value → List Value +| [], v => [v] +| v₁@(ctor i₁ vs₁) :: cs, v₂@(ctor i₂ vs₂) => + if i₁ == i₂ then merge v₁ v₂ :: cs + else v₁ :: addChoice cs v₂ +| _, _ => panic! "invalid addChoice" + +partial def merge : Value → Value → Value +| bot, v => v +| v, bot => v +| top, _ => top +| _, top => top +| v₁@(ctor i₁ vs₁), v₂@(ctor i₂ vs₂) => + if i₁ == i₂ then ctor i₁ $ vs₁.size.fold (fun i r => r.push (merge (vs₁.get! i) (vs₂.get! i))) #[] + else choice [v₁, v₂] +| choice vs₁, choice vs₂ => choice $ vs₁.foldl (addChoice merge) vs₂ +| choice vs, v => choice $ addChoice merge vs v +| v, choice vs => choice $ addChoice merge vs v + +protected partial def format : Value → Format +| top => "top" +| bot => "bot" +| choice vs => fmt "@" ++ @List.format _ ⟨format⟩ vs +| ctor i vs => fmt "#" ++ if vs.isEmpty then fmt i.name else Format.paren (fmt i.name ++ @formatArray _ ⟨format⟩ vs) + +instance : HasFormat Value := ⟨Value.format⟩ +instance : HasToString Value := ⟨Format.pretty ∘ Value.format⟩ + +/- Make sure constructors of recursive inductive datatypes can only occur once in each path. + We use this function this function to implement a simple widening operation for our abstract + interpreter. -/ +partial def truncate (env : Environment) : Value → NameSet → Value +| ctor i vs, found => + let I := i.name.getPrefix; + if found.contains I then + top + else + let cont (found' : NameSet) : Value := + ctor i (vs.map $ fun v => truncate v found'); + match env.find I with + | some (ConstantInfo.inductInfo d) => + if d.isRec then cont (found.insert I) + else cont found + | _ => cont found +| choice vs, found => + let newVs := vs.map $ fun v => truncate v found; + if newVs.elem top then top + else choice newVs +| v, _ => v + +/- Widening operator that guarantees termination in our abstract interpreter. -/ +def widening (env : Environment) (v₁ v₂ : Value) : Value := +truncate env (merge v₁ v₂) {} + +end Value + +abbrev FunctionSummaries := SMap FunId Value + +def mkFunctionSummariesExtension : IO (SimplePersistentEnvExtension (FunId × Value) FunctionSummaries) := +registerSimplePersistentEnvExtension { + name := `unreachBranchesFunSummary, + addImportedFn := fun as => + let cache : FunctionSummaries := mkStateFromImportedEntries (fun s (p : FunId × Value) => s.insert p.1 p.2) {} as; + cache.switch, + addEntryFn := fun s ⟨e, n⟩ => s.insert e n +} + +@[init mkFunctionSummariesExtension] +constant functionSummariesExt : SimplePersistentEnvExtension (FunId × Value) FunctionSummaries := arbitrary _ + +def addFunctionSummary (env : Environment) (fid : FunId) (v : Value) : Environment := +functionSummariesExt.addEntry env (fid, v) + +def getFunctionSummary (env : Environment) (fid : FunId) : Option Value := +(functionSummariesExt.getState env).find fid + +abbrev Assignment := HashMap VarId Value + +structure InterpContext := +(currFnIdx : Nat := 0) +(decls : Array Decl) +(env : Environment) +(lctx : LocalContext := {}) + +structure InterpState := +(assignments : Array Assignment) +(funVals : PArray Value) -- we take snapshots during fixpoint computations + +abbrev M := ReaderT InterpContext (StateM InterpState) + +open Value + +def findVarValue (x : VarId) : M Value := +do ctx ← read; + s ← get; + let assignment := s.assignments.get! ctx.currFnIdx; + pure $ assignment.findD x bot + +def findArgValue (arg : Arg) : M Value := +match arg with +| Arg.var x => findVarValue x +| _ => pure top + +def updateVarAssignment (x : VarId) (v : Value) : M Unit := +do v' ← findVarValue x; + ctx ← read; + modify $ fun s => { assignments := s.assignments.modify ctx.currFnIdx $ fun a => a.insert x (merge v v'), .. s } + +partial def projValue : Value → Nat → Value +| ctor _ vs, i => vs.getD i bot +| choice vs, i => vs.foldl (fun r v => merge r (projValue v i)) bot +| v, _ => v + +def interpExpr : Expr → M Value +| Expr.ctor i ys => ctor i <$> ys.mapM (fun y => findArgValue y) +| Expr.proj i x => do v ← findVarValue x; pure $ projValue v i +| Expr.fap fid ys => do + ctx ← read; + match getFunctionSummary ctx.env fid with + | some v => pure v + | none => do + s ← get; + match ctx.decls.findIdx? (fun decl => decl.name == fid) with + | some idx => pure $ s.funVals.get! idx + | none => pure top +| _ => pure top + +partial def containsCtor : Value → CtorInfo → Bool +| top, _ => true +| ctor i _, j => i == j +| choice vs, j => vs.any $ fun v => containsCtor v j +| _, _ => false + +def updateCurrFnSummary (v : Value) : M Unit := +do ctx ← read; + let currFnIdx := ctx.currFnIdx; + modify $ fun s => { funVals := s.funVals.modify currFnIdx (fun v' => widening ctx.env v v'), .. s } + +/-- Return true if the assignment of at least one parameter has been updated. -/ +def updateJPParamsAssignment (ys : Array Param) (xs : Array Arg) : M Bool := +do ctx ← read; + let currFnIdx := ctx.currFnIdx; + ys.size.foldM (fun i r => do + let y := ys.get! i; + let x := xs.get! i; + yVal ← findVarValue y.x; + xVal ← findArgValue x; + let newVal := merge yVal xVal; + if newVal == yVal then pure r + else do + modify $ fun s => { assignments := s.assignments.modify currFnIdx $ fun a => a.insert y.x newVal, .. s }; + pure true) + false + +partial def interpFnBody : FnBody → M Unit +| FnBody.vdecl x _ e b => do + v ← interpExpr e; + updateVarAssignment x v; + interpFnBody b +| FnBody.jdecl j ys v b => + adaptReader (fun (ctx : InterpContext) => { lctx := ctx.lctx.addJP j ys v, .. ctx }) $ + interpFnBody b +| FnBody.case _ x _ alts => do + v ← findVarValue x; + alts.forM $ fun alt => + match alt with + | Alt.ctor i b => when (containsCtor v i) $ interpFnBody b + | Alt.default b => interpFnBody b +| FnBody.ret x => do + v ← findArgValue x; + -- dbgTrace ("ret " ++ toString v) $ fun _ => + updateCurrFnSummary v +| FnBody.jmp j xs => do + ctx ← read; + let ys := (ctx.lctx.getJPParams j).get!; + updated ← updateJPParamsAssignment ys xs; + when updated $ + interpFnBody $ (ctx.lctx.getJPBody j).get! +| e => unless (e.isTerminal) $ interpFnBody e.body + +def inferStep : M Bool := +do ctx ← read; + modify $ fun s => { assignments := ctx.decls.map $ fun _ => {}, .. s }; + ctx.decls.size.foldM (fun idx modified => do + match ctx.decls.get! idx with + | Decl.fdecl fid ys _ b => do + s ← get; + -- dbgTrace (">> " ++ toString fid) $ fun _ => + let currVals := s.funVals.get! idx; + adaptReader (fun (ctx : InterpContext) => { currFnIdx := idx, .. ctx }) $ do + ys.forM $ fun y => updateVarAssignment y.x top; + interpFnBody b; + s ← get; + let newVals := s.funVals.get! idx; + pure (modified || currVals != newVals) + | Decl.extern _ _ _ _ => pure modified) + false + +partial def inferMain : Unit → M Unit +| _ => do + modified ← inferStep; + if modified then inferMain () else pure () + +partial def elimDeadAux (assignment : Assignment) : FnBody → FnBody +| FnBody.vdecl x t e b => FnBody.vdecl x t e (elimDeadAux b) +| FnBody.jdecl j ys v b => FnBody.jdecl j ys (elimDeadAux v) (elimDeadAux b) +| FnBody.case tid x xType alts => + let v := assignment.findD x bot; + let alts := alts.map $ fun alt => + match alt with + | Alt.ctor i b => Alt.ctor i $ if containsCtor v i then elimDeadAux b else FnBody.unreachable + | Alt.default b => Alt.default (elimDeadAux b); + FnBody.case tid x xType alts +| e => + if e.isTerminal then e + else + let (instr, b) := e.split; + let b := elimDeadAux b; + instr.setBody b + +partial def elimDead (assignment : Assignment) : Decl → Decl +| Decl.fdecl fid ys t b => Decl.fdecl fid ys t $ elimDeadAux assignment b +| other => other + +end UnreachableBranches + +open UnreachableBranches + +def elimDeadBranches (decls : Array Decl) : CompilerM (Array Decl) := +do s ← get; + let env := s.env; + let assignments : Array Assignment := decls.map $ fun _ => {}; + let funVals := mkPArray decls.size Value.bot; + let ctx : InterpContext := { decls := decls, env := env }; + let s : InterpState := { assignments := assignments, funVals := funVals }; + let (_, s) := (inferMain () ctx).run s; + let funVals := s.funVals; + let assignments := s.assignments; + modify $ fun s => + let env := decls.size.fold (fun i env => + -- dbgTrace (">> " ++ toString (decls.get! i).name ++ " " ++ toString (funVals.get! i)) $ fun _ => + addFunctionSummary env (decls.get! i).name (funVals.get! i)) + s.env; + { env := env, .. s }; + pure $ decls.mapIdx $ fun i decl => elimDead (assignments.get! i) decl + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/ElimDeadVars.lean b/stage0/src/Init/Lean/Compiler/IR/ElimDeadVars.lean new file mode 100644 index 0000000000..fe2e47f266 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/ElimDeadVars.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.FreeVars + +namespace Lean +namespace IR + +partial def reshapeWithoutDeadAux : Array FnBody → FnBody → IndexSet → FnBody +| bs, b, used => + if bs.isEmpty then b + else + let curr := bs.back; + let bs := bs.pop; + let keep (_ : Unit) := + let used := curr.collectFreeIndices used; + let b := curr.setBody b; + reshapeWithoutDeadAux bs b used; + let keepIfUsed (vidx : Index) := + if used.contains vidx then keep () + else reshapeWithoutDeadAux bs b used; + match curr with + | FnBody.vdecl x _ _ _ => keepIfUsed x.idx + -- TODO: we should keep all struct/union projections because they are used to ensure struct/union values are fully consumed. + | FnBody.jdecl j _ _ _ => keepIfUsed j.idx + | _ => keep () + +def reshapeWithoutDead (bs : Array FnBody) (term : FnBody) : FnBody := +reshapeWithoutDeadAux bs term term.freeIndices + +partial def FnBody.elimDead : FnBody → FnBody +| b => + let (bs, term) := b.flatten; + let bs := modifyJPs bs FnBody.elimDead; + let term := match term with + | FnBody.case tid x xType alts => + let alts := alts.map $ fun alt => alt.modifyBody FnBody.elimDead; + FnBody.case tid x xType alts + | other => other; + reshapeWithoutDead bs term + +/-- Eliminate dead let-declarations and join points -/ +def Decl.elimDead : Decl → Decl +| Decl.fdecl f xs t b => Decl.fdecl f xs t b.elimDead +| other => other + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/EmitC.lean b/stage0/src/Init/Lean/Compiler/IR/EmitC.lean new file mode 100644 index 0000000000..90acb752a7 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/EmitC.lean @@ -0,0 +1,720 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Conditional +import Init.Lean.Runtime +import Init.Lean.Compiler.NameMangling +import Init.Lean.Compiler.ExportAttr +import Init.Lean.Compiler.InitAttr +import Init.Lean.Compiler.IR.CompilerM +import Init.Lean.Compiler.IR.EmitUtil +import Init.Lean.Compiler.IR.NormIds +import Init.Lean.Compiler.IR.SimpCase +import Init.Lean.Compiler.IR.Boxing + +namespace Lean +namespace IR +open ExplicitBoxing (requiresBoxedVersion mkBoxedName isBoxedName) +namespace EmitC + +def leanMainFn := "_lean_main" + +structure Context := +(env : Environment) +(modName : Name) +(jpMap : JPParamsMap := {}) +(mainFn : FunId := arbitrary _) +(mainParams : Array Param := #[]) + +abbrev M := ReaderT Context (EStateM String String) + +def getEnv : M Environment := Context.env <$> read +def getModName : M Name := Context.modName <$> read +def getDecl (n : Name) : M Decl := +do env ← getEnv; + match findEnvDecl env n with + | some d => pure d + | none => throw ("unknown declaration '" ++ toString n ++ "'") + +@[inline] def emit {α : Type} [HasToString α] (a : α) : M Unit := +modify (fun out => out ++ toString a) + +@[inline] def emitLn {α : Type} [HasToString α] (a : α) : M Unit := +emit a *> emit "\n" + +def emitLns {α : Type} [HasToString α] (as : List α) : M Unit := +as.forM $ fun a => emitLn a + +def argToCString (x : Arg) : String := +match x with +| Arg.var x => toString x +| _ => "lean_box(0)" + +def emitArg (x : Arg) : M Unit := +emit (argToCString x) + +def toCType : IRType → String +| IRType.float => "double" +| IRType.uint8 => "uint8_t" +| IRType.uint16 => "uint16_t" +| IRType.uint32 => "uint32_t" +| IRType.uint64 => "uint64_t" +| IRType.usize => "size_t" +| IRType.object => "lean_object*" +| IRType.tobject => "lean_object*" +| IRType.irrelevant => "lean_object*" +| IRType.struct _ _ => panic! "not implemented yet" +| IRType.union _ _ => panic! "not implemented yet" + +def throwInvalidExportName {α : Type} (n : Name) : M α := +throw ("invalid export name '" ++ toString n ++ "'") + +def toCName (n : Name) : M String := +do env ← getEnv; + -- TODO: we should support simple export names only + match getExportNameFor env n with + | some (Name.str Name.anonymous s _) => pure s + | some _ => throwInvalidExportName n + | none => if n == `main then pure leanMainFn else pure n.mangle + +def emitCName (n : Name) : M Unit := +toCName n >>= emit + +def toCInitName (n : Name) : M String := +do env ← getEnv; + -- TODO: we should support simple export names only + match getExportNameFor env n with + | some (Name.str Name.anonymous s _) => pure $ "_init_" ++ s + | some _ => throwInvalidExportName n + | none => pure ("_init_" ++ n.mangle) + +def emitCInitName (n : Name) : M Unit := +toCInitName n >>= emit + +def emitFnDeclAux (decl : Decl) (cppBaseName : String) (addExternForConsts : Bool) : M Unit := +do let ps := decl.params; + env ← getEnv; + when (ps.isEmpty && addExternForConsts) (emit "extern "); + emit (toCType decl.resultType ++ " " ++ cppBaseName); + unless (ps.isEmpty) $ do { + emit "("; + -- We omit irrelevant parameters for extern constants + let ps := if isExternC env decl.name then ps.filter (fun p => !p.ty.isIrrelevant) else ps; + if ps.size > closureMaxArgs && isBoxedName decl.name then + emit "lean_object**" + else + ps.size.forM $ fun i => do { + when (i > 0) (emit ", "); + emit (toCType (ps.get! i).ty) + }; + emit ")" + }; + emitLn ";" + +def emitFnDecl (decl : Decl) (addExternForConsts : Bool) : M Unit := +do cppBaseName ← toCName decl.name; + emitFnDeclAux decl cppBaseName addExternForConsts + +def emitExternDeclAux (decl : Decl) (cNameStr : String) : M Unit := +do let cName := mkNameSimple cNameStr; + env ← getEnv; + let extC := isExternC env decl.name; + emitFnDeclAux decl cNameStr (!extC) + +def emitFnDecls : M Unit := +do env ← getEnv; + let decls := getDecls env; + let modDecls : NameSet := decls.foldl (fun s d => s.insert d.name) {}; + let usedDecls : NameSet := decls.foldl (fun s d => collectUsedDecls env d (s.insert d.name)) {}; + let usedDecls := usedDecls.toList; + usedDecls.forM $ fun n => do + decl ← getDecl n; + match getExternNameFor env `c decl.name with + | some cName => emitExternDeclAux decl cName + | none => emitFnDecl decl (!modDecls.contains n) + +def emitMainFn : M Unit := +do d ← getDecl `main; + match d with + | Decl.fdecl f xs t b => do + unless (xs.size == 2 || xs.size == 1) (throw "invalid main function, incorrect arity when generating code"); + env ← getEnv; + let usesLeanAPI := usesLeanNamespace env d; + if usesLeanAPI then + emitLn "void lean_initialize();" + else + emitLn "void lean_initialize_runtime_module();"; + emitLn "int main(int argc, char ** argv) {\nlean_object* in; lean_object* res;"; + if usesLeanAPI then + emitLn "lean_initialize();" + else + emitLn "lean_initialize_runtime_module();"; + modName ← getModName; + emitLn ("res = initialize_" ++ (modName.mangle "") ++ "(lean_io_mk_world());"); + emitLns ["lean_io_mark_end_initialization();", + "if (lean_io_result_is_ok(res)) {", + "lean_dec_ref(res);", + "lean_init_task_manager();"]; + if xs.size == 2 then do { + emitLns ["in = lean_box(0);", + "int i = argc;", + "while (i > 1) {", + " lean_object* n;", + " i--;", + " n = lean_alloc_ctor(1,2,0); lean_ctor_set(n, 0, lean_mk_string(argv[i])); lean_ctor_set(n, 1, in);", + " in = n;", + "}"]; + emitLn ("res = " ++ leanMainFn ++ "(in, lean_io_mk_world());") + } else do { + emitLn ("res = " ++ leanMainFn ++ "(lean_io_mk_world());") + }; + emitLn "}"; + emitLns ["if (lean_io_result_is_ok(res)) {", + " int ret = lean_unbox(lean_io_result_get_value(res));", + " lean_dec_ref(res);", + " return ret;", + "} else {", + " lean_io_result_show_error(res);", + " lean_dec_ref(res);", + " return 1;", + "}"]; + emitLn "}" + | other => throw "function declaration expected" + +def hasMainFn : M Bool := +do env ← getEnv; + let decls := getDecls env; + pure $ decls.any (fun d => d.name == `main) + +def emitMainFnIfNeeded : M Unit := +whenM hasMainFn emitMainFn + +def emitFileHeader : M Unit := +do env ← getEnv; + modName ← getModName; + emitLn "// Lean compiler output"; + emitLn ("// Module: " ++ toString modName); + emit "// Imports:"; + env.imports.forM $ fun m => emit (" " ++ toString m); + emitLn ""; + emitLn "#include \"runtime/lean.h\""; + emitLns [ + "#if defined(__clang__)", + "#pragma clang diagnostic ignored \"-Wunused-parameter\"", + "#pragma clang diagnostic ignored \"-Wunused-label\"", + "#elif defined(__GNUC__) && !defined(__CLANG__)", + "#pragma GCC diagnostic ignored \"-Wunused-parameter\"", + "#pragma GCC diagnostic ignored \"-Wunused-label\"", + "#pragma GCC diagnostic ignored \"-Wunused-but-set-variable\"", + "#endif", + "#ifdef __cplusplus", + "extern \"C\" {", + "#endif" + ] + +def emitFileFooter : M Unit := +emitLns [ + "#ifdef __cplusplus", + "}", + "#endif" +] + +def throwUnknownVar {α : Type} (x : VarId) : M α := +throw ("unknown variable '" ++ toString x ++ "'") + +def getJPParams (j : JoinPointId) : M (Array Param) := +do ctx ← read; + match ctx.jpMap.find j with + | some ps => pure ps + | none => throw "unknown join point" + +def declareVar (x : VarId) (t : IRType) : M Unit := +do emit (toCType t); emit " "; emit x; emit "; " + +def declareParams (ps : Array Param) : M Unit := +ps.forM $ fun p => declareVar p.x p.ty + +partial def declareVars : FnBody → Bool → M Bool +| e@(FnBody.vdecl x t _ b), d => do + ctx ← read; + if isTailCallTo ctx.mainFn e then + pure d + else + declareVar x t *> declareVars b true +| FnBody.jdecl j xs _ b, d => declareParams xs *> declareVars b (d || xs.size > 0) +| e, d => if e.isTerminal then pure d else declareVars e.body d + +def emitTag (x : VarId) (xType : IRType) : M Unit := +do if xType.isObj then do + emit "lean_obj_tag("; emit x; emit ")" + else + emit x + +def isIf (alts : Array Alt) : Option (Nat × FnBody × FnBody) := +if alts.size != 2 then none +else match alts.get! 0 with + | Alt.ctor c b => some (c.cidx, b, (alts.get! 1).body) + | _ => none + +def emitIf (emitBody : FnBody → M Unit) (x : VarId) (xType : IRType) (tag : Nat) (t : FnBody) (e : FnBody) : M Unit := +do emit "if ("; emitTag x xType; emit " == "; emit tag; emitLn ")"; + emitBody t; + emitLn "else"; + emitBody e + +def emitCase (emitBody : FnBody → M Unit) (x : VarId) (xType : IRType) (alts : Array Alt) : M Unit := +match isIf alts with +| some (tag, t, e) => emitIf emitBody x xType tag t e +| _ => do + emit "switch ("; emitTag x xType; emitLn ") {"; + let alts := ensureHasDefault alts; + alts.forM $ fun alt => match alt with + | Alt.ctor c b => emit "case " *> emit c.cidx *> emitLn ":" *> emitBody b + | Alt.default b => emitLn "default: " *> emitBody b; + emitLn "}" + +def emitInc (x : VarId) (n : Nat) (checkRef : Bool) : M Unit := +do emit $ + if checkRef then (if n == 1 then "lean_inc" else "lean_inc_n") + else (if n == 1 then "lean_inc_ref" else "lean_inc_ref_n"); + emit "(" *> emit x; + when (n != 1) (emit ", " *> emit n); + emitLn ");" + +def emitDec (x : VarId) (n : Nat) (checkRef : Bool) : M Unit := +do emit (if checkRef then "lean_dec" else "lean_dec_ref"); + emit "("; emit x; + when (n != 1) (do emit ", "; emit n); + emitLn ");" + +def emitDel (x : VarId) : M Unit := +do emit "lean_free_object("; emit x; emitLn ");" + +def emitSetTag (x : VarId) (i : Nat) : M Unit := +do emit "lean_ctor_set_tag("; emit x; emit ", "; emit i; emitLn ");" + +def emitSet (x : VarId) (i : Nat) (y : Arg) : M Unit := +do emit "lean_ctor_set("; emit x; emit ", "; emit i; emit ", "; emitArg y; emitLn ");" + +def emitOffset (n : Nat) (offset : Nat) : M Unit := +if n > 0 then do + emit "sizeof(void*)*"; emit n; + when (offset > 0) (emit " + " *> emit offset) +else + emit offset + +def emitUSet (x : VarId) (n : Nat) (y : VarId) : M Unit := +do emit "lean_ctor_set_usize("; emit x; emit ", "; emit n; emit ", "; emit y; emitLn ");" + +def emitSSet (x : VarId) (n : Nat) (offset : Nat) (y : VarId) (t : IRType) : M Unit := +do match t with + | IRType.float => throw "floats are not supported yet" + | IRType.uint8 => emit "lean_ctor_set_uint8" + | IRType.uint16 => emit "lean_ctor_set_uint16" + | IRType.uint32 => emit "lean_ctor_set_uint32" + | IRType.uint64 => emit "lean_ctor_set_uint64" + | _ => throw "invalid instruction"; + emit "("; emit x; emit ", "; emitOffset n offset; emit ", "; emit y; emitLn ");" + +def emitJmp (j : JoinPointId) (xs : Array Arg) : M Unit := +do ps ← getJPParams j; + unless (xs.size == ps.size) (throw "invalid goto"); + xs.size.forM $ fun i => do { + let p := ps.get! i; + let x := xs.get! i; + emit p.x; emit " = "; emitArg x; emitLn ";" + }; + emit "goto "; emit j; emitLn ";" + +def emitLhs (z : VarId) : M Unit := +do emit z; emit " = " + +def emitArgs (ys : Array Arg) : M Unit := +ys.size.forM $ fun i => do + when (i > 0) (emit ", "); + emitArg (ys.get! i) + +def emitCtorScalarSize (usize : Nat) (ssize : Nat) : M Unit := +if usize == 0 then emit ssize +else if ssize == 0 then emit "sizeof(size_t)*" *> emit usize +else emit "sizeof(size_t)*" *> emit usize *> emit " + " *> emit ssize + +def emitAllocCtor (c : CtorInfo) : M Unit := +do emit "lean_alloc_ctor("; emit c.cidx; emit ", "; emit c.size; emit ", "; + emitCtorScalarSize c.usize c.ssize; emitLn ");" + +def emitCtorSetArgs (z : VarId) (ys : Array Arg) : M Unit := +ys.size.forM $ fun i => do + emit "lean_ctor_set("; emit z; emit ", "; emit i; emit ", "; emitArg (ys.get! i); emitLn ");" + +def emitCtor (z : VarId) (c : CtorInfo) (ys : Array Arg) : M Unit := +do emitLhs z; + if c.size == 0 && c.usize == 0 && c.ssize == 0 then do + emit "lean_box("; emit c.cidx; emitLn ");" + else do + emitAllocCtor c; emitCtorSetArgs z ys + +def emitReset (z : VarId) (n : Nat) (x : VarId) : M Unit := +do emit "if (lean_is_exclusive("; emit x; emitLn ")) {"; + n.forM $ fun i => do { + emit " lean_ctor_release("; emit x; emit ", "; emit i; emitLn ");" + }; + emit " "; emitLhs z; emit x; emitLn ";"; + emitLn "} else {"; + emit " lean_dec_ref("; emit x; emitLn ");"; + emit " "; emitLhs z; emitLn "lean_box(0);"; + emitLn "}" + +def emitReuse (z : VarId) (x : VarId) (c : CtorInfo) (updtHeader : Bool) (ys : Array Arg) : M Unit := +do emit "if (lean_is_scalar("; emit x; emitLn ")) {"; + emit " "; emitLhs z; emitAllocCtor c; + emitLn "} else {"; + emit " "; emitLhs z; emit x; emitLn ";"; + when updtHeader (do emit " lean_ctor_set_tag("; emit z; emit ", "; emit c.cidx; emitLn ");"); + emitLn "}"; + emitCtorSetArgs z ys + +def emitProj (z : VarId) (i : Nat) (x : VarId) : M Unit := +do emitLhs z; emit "lean_ctor_get("; emit x; emit ", "; emit i; emitLn ");" + +def emitUProj (z : VarId) (i : Nat) (x : VarId) : M Unit := +do emitLhs z; emit "lean_ctor_get_usize("; emit x; emit ", "; emit i; emitLn ");" + +def emitSProj (z : VarId) (t : IRType) (n offset : Nat) (x : VarId) : M Unit := +do emitLhs z; + match t with + | IRType.float => throw "floats are not supported yet" + | IRType.uint8 => emit "lean_ctor_get_uint8" + | IRType.uint16 => emit "lean_ctor_get_uint16" + | IRType.uint32 => emit "lean_ctor_get_uint32" + | IRType.uint64 => emit "lean_ctor_get_uint64" + | _ => throw "invalid instruction"; + emit "("; emit x; emit ", "; emitOffset n offset; emitLn ");" + +def toStringArgs (ys : Array Arg) : List String := +ys.toList.map argToCString + +def emitSimpleExternalCall (f : String) (ps : Array Param) (ys : Array Arg) : M Unit := +do emit f; emit "("; + -- We must remove irrelevant arguments to extern calls. + ys.size.foldM + (fun i (first : Bool) => + if (ps.get! i).ty.isIrrelevant then + pure first + else do + unless first (emit ", "); + emitArg (ys.get! i); + pure false) + true; + emitLn ");"; + pure () + +def emitExternCall (f : FunId) (ps : Array Param) (extData : ExternAttrData) (ys : Array Arg) : M Unit := +match getExternEntryFor extData `c with +| some (ExternEntry.standard _ extFn) => emitSimpleExternalCall extFn ps ys +| some (ExternEntry.inline _ pat) => do emit (expandExternPattern pat (toStringArgs ys)); emitLn ";" +| some (ExternEntry.foreign _ extFn) => emitSimpleExternalCall extFn ps ys +| _ => throw ("failed to emit extern application '" ++ toString f ++ "'") + +def emitFullApp (z : VarId) (f : FunId) (ys : Array Arg) : M Unit := +do emitLhs z; + decl ← getDecl f; + match decl with + | Decl.extern _ ps _ extData => emitExternCall f ps extData ys + | _ => do emitCName f; when (ys.size > 0) (do emit "("; emitArgs ys; emit ")"); emitLn ";" + +def emitPartialApp (z : VarId) (f : FunId) (ys : Array Arg) : M Unit := +do decl ← getDecl f; + let arity := decl.params.size; + emitLhs z; emit "lean_alloc_closure((void*)("; emitCName f; emit "), "; emit arity; emit ", "; emit ys.size; emitLn ");"; + ys.size.forM $ fun i => do { + let y := ys.get! i; + emit "lean_closure_set("; emit z; emit ", "; emit i; emit ", "; emitArg y; emitLn ");" + } + +def emitApp (z : VarId) (f : VarId) (ys : Array Arg) : M Unit := +if ys.size > closureMaxArgs then do + emit "{ lean_object* _aargs[] = {"; emitArgs ys; emitLn "};"; + emitLhs z; emit "lean_apply_m("; emit f; emit ", "; emit ys.size; emitLn ", _aargs); }" +else do + emitLhs z; emit "lean_apply_"; emit ys.size; emit "("; emit f; emit ", "; emitArgs ys; emitLn ");" + +def emitBoxFn (xType : IRType) : M Unit := +match xType with +| IRType.usize => emit "lean_box_usize" +| IRType.uint32 => emit "lean_box_uint32" +| IRType.uint64 => emit "lean_box_uint64" +| IRType.float => throw "floats are not supported yet" +| other => emit "lean_box" + +def emitBox (z : VarId) (x : VarId) (xType : IRType) : M Unit := +do emitLhs z; emitBoxFn xType; emit "("; emit x; emitLn ");" + +def emitUnbox (z : VarId) (t : IRType) (x : VarId) : M Unit := +do emitLhs z; + match t with + | IRType.usize => emit "lean_unbox_usize" + | IRType.uint32 => emit "lean_unbox_uint32" + | IRType.uint64 => emit "lean_unbox_uint64" + | IRType.float => throw "floats are not supported yet" + | other => emit "lean_unbox"; + emit "("; emit x; emitLn ");" + +def emitIsShared (z : VarId) (x : VarId) : M Unit := +do emitLhs z; emit "!lean_is_exclusive("; emit x; emitLn ");" + +def emitIsTaggedPtr (z : VarId) (x : VarId) : M Unit := +do emitLhs z; emit "!lean_is_scalar("; emit x; emitLn ");" + +def toHexDigit (c : Nat) : String := +String.singleton c.digitChar + +def quoteString (s : String) : String := +let q := "\""; +let q := s.foldl + (fun q c => q ++ + if c == '\n' then "\\n" + else if c == '\n' then "\\t" + else if c == '\\' then "\\\\" + else if c == '\"' then "\\\"" + else if c.toNat <= 31 then + "\\x" ++ toHexDigit (c.toNat / 16) ++ toHexDigit (c.toNat % 16) + -- TODO(Leo): we should use `\unnnn` for escaping unicode characters. + else String.singleton c) + q; +q ++ "\"" + +def emitNumLit (t : IRType) (v : Nat) : M Unit := +if t.isObj then do + if v < uint32Sz then + emit "lean_unsigned_to_nat(" *> emit v *> emit "u)" + else + emit "lean_cstr_to_nat(\"" *> emit v *> emit "\")" +else + emit v + +def emitLit (z : VarId) (t : IRType) (v : LitVal) : M Unit := +emitLhs z *> +match v with +| LitVal.num v => emitNumLit t v *> emitLn ";" +| LitVal.str v => do emit "lean_mk_string("; emit (quoteString v); emitLn ");" + +def emitVDecl (z : VarId) (t : IRType) (v : Expr) : M Unit := +match v with +| Expr.ctor c ys => emitCtor z c ys +| Expr.reset n x => emitReset z n x +| Expr.reuse x c u ys => emitReuse z x c u ys +| Expr.proj i x => emitProj z i x +| Expr.uproj i x => emitUProj z i x +| Expr.sproj n o x => emitSProj z t n o x +| Expr.fap c ys => emitFullApp z c ys +| Expr.pap c ys => emitPartialApp z c ys +| Expr.ap x ys => emitApp z x ys +| Expr.box t x => emitBox z x t +| Expr.unbox x => emitUnbox z t x +| Expr.isShared x => emitIsShared z x +| Expr.isTaggedPtr x => emitIsTaggedPtr z x +| Expr.lit v => emitLit z t v + +def isTailCall (x : VarId) (v : Expr) (b : FnBody) : M Bool := +do ctx ← read; + match v, b with + | Expr.fap f _, FnBody.ret (Arg.var y) => pure $ f == ctx.mainFn && x == y + | _, _ => pure false + +def paramEqArg (p : Param) (x : Arg) : Bool := +match x with +| Arg.var x => p.x == x +| _ => false + +/- +Given `[p_0, ..., p_{n-1}]`, `[y_0, ..., y_{n-1}]`, representing the assignments +``` +p_0 := y_0, +... +p_{n-1} := y_{n-1} +``` +Return true iff we have `(i, j)` where `j > i`, and `y_j == p_i`. +That is, we have +``` + p_i := y_i, + ... + p_j := p_i, -- p_i was overwritten above +``` +-/ +def overwriteParam (ps : Array Param) (ys : Array Arg) : Bool := +let n := ps.size; +n.any $ fun i => + let p := ps.get! i; + (i+1, n).anyI $ fun j => paramEqArg p (ys.get! j) + +def emitTailCall (v : Expr) : M Unit := +match v with +| Expr.fap _ ys => do + ctx ← read; + let ps := ctx.mainParams; + unless (ps.size == ys.size) (throw "invalid tail call"); + if overwriteParam ps ys then do { + emitLn "{"; + ps.size.forM $ fun i => do { + let p := ps.get! i; + let y := ys.get! i; + unless (paramEqArg p y) $ do { + emit (toCType p.ty); emit " _tmp_"; emit i; emit " = "; emitArg y; emitLn ";" + } + }; + ps.size.forM $ fun i => do { + let p := ps.get! i; + let y := ys.get! i; + unless (paramEqArg p y) (do emit p.x; emit " = _tmp_"; emit i; emitLn ";") + }; + emitLn "}" + } else do { + ys.size.forM $ fun i => do { + let p := ps.get! i; + let y := ys.get! i; + unless (paramEqArg p y) (do emit p.x; emit " = "; emitArg y; emitLn ";") + } + }; + emitLn "goto _start;" +| _ => throw "bug at emitTailCall" + +partial def emitBlock (emitBody : FnBody → M Unit) : FnBody → M Unit +| FnBody.jdecl j xs v b => emitBlock b +| d@(FnBody.vdecl x t v b) => + do ctx ← read; if isTailCallTo ctx.mainFn d then emitTailCall v else emitVDecl x t v *> emitBlock b +| FnBody.inc x n c p b => unless p (emitInc x n c) *> emitBlock b +| FnBody.dec x n c p b => unless p (emitDec x n c) *> emitBlock b +| FnBody.del x b => emitDel x *> emitBlock b +| FnBody.setTag x i b => emitSetTag x i *> emitBlock b +| FnBody.set x i y b => emitSet x i y *> emitBlock b +| FnBody.uset x i y b => emitUSet x i y *> emitBlock b +| FnBody.sset x i o y t b => emitSSet x i o y t *> emitBlock b +| FnBody.mdata _ b => emitBlock b +| FnBody.ret x => emit "return " *> emitArg x *> emitLn ";" +| FnBody.case _ x xType alts => emitCase emitBody x xType alts +| FnBody.jmp j xs => emitJmp j xs +| FnBody.unreachable => emitLn "lean_panic_unreachable();" + +partial def emitJPs (emitBody : FnBody → M Unit) : FnBody → M Unit +| FnBody.jdecl j xs v b => do emit j; emitLn ":"; emitBody v; emitJPs b +| e => unless e.isTerminal (emitJPs e.body) + +partial def emitFnBody : FnBody → M Unit +| b => do +emitLn "{"; +declared ← declareVars b false; +when declared (emitLn ""); +emitBlock emitFnBody b; +emitJPs emitFnBody b; +emitLn "}" + +def emitDeclAux (d : Decl) : M Unit := +do env ← getEnv; + let (vMap, jpMap) := mkVarJPMaps d; + adaptReader (fun (ctx : Context) => { jpMap := jpMap, .. ctx }) $ do + unless (hasInitAttr env d.name) $ + match d with + | Decl.fdecl f xs t b => do + baseName ← toCName f; + emit (toCType t); emit " "; + if xs.size > 0 then do { + emit baseName; + emit "("; + if xs.size > closureMaxArgs && isBoxedName d.name then + emit "lean_object** _args" + else + xs.size.forM $ fun i => do { + when (i > 0) (emit ", "); + let x := xs.get! i; + emit (toCType x.ty); emit " "; emit x.x + }; + emit ")" + } else do { + emit ("_init_" ++ baseName ++ "()") + }; + emitLn " {"; + when (xs.size > closureMaxArgs && isBoxedName d.name) $ + xs.size.forM $ fun i => do { + let x := xs.get! i; + emit "lean_object* "; emit x.x; emit " = _args["; emit i; emitLn "];" + }; + emitLn "_start:"; + adaptReader (fun (ctx : Context) => { mainFn := f, mainParams := xs, .. ctx }) (emitFnBody b); + emitLn "}" + | _ => pure () + +def emitDecl (d : Decl) : M Unit := +let d := d.normalizeIds; -- ensure we don't have gaps in the variable indices +catch + (emitDeclAux d) + (fun err => throw (err ++ "\ncompiling:\n" ++ toString d)) + +def emitFns : M Unit := +do env ← getEnv; + let decls := getDecls env; + decls.reverse.forM emitDecl + +def emitMarkPersistent (d : Decl) (n : Name) : M Unit := +when d.resultType.isObj $ do { + emit "lean_mark_persistent("; emitCName n; emitLn ");" +} + +def emitDeclInit (d : Decl) : M Unit := +do env ← getEnv; + let n := d.name; + if isIOUnitInitFn env n then do { + emit "res = "; emitCName n; emitLn "(lean_io_mk_world());"; + emitLn "if (lean_io_result_is_error(res)) return res;"; + emitLn "lean_dec_ref(res);" + } else when (d.params.size == 0) $ + match getInitFnNameFor env d.name with + | some initFn => do { + emit "res = "; emitCName initFn; emitLn "(lean_io_mk_world());"; + emitLn "if (lean_io_result_is_error(res)) return res;"; + emitCName n; emitLn " = lean_io_result_get_value(res);"; + emitMarkPersistent d n; + emitLn "lean_dec_ref(res);" + } + | _ => do { emitCName n; emit " = "; emitCInitName n; emitLn "();"; emitMarkPersistent d n } + +def emitInitFn : M Unit := +do env ← getEnv; + modName ← getModName; + env.imports.forM $ fun imp => emitLn ("lean_object* initialize_" ++ imp.module.mangle "" ++ "(lean_object*);"); + emitLns [ + "static bool _G_initialized = false;", + "lean_object* initialize_" ++ modName.mangle "" ++ "(lean_object* w) {", + "lean_object * res;", + "if (_G_initialized) return lean_mk_io_result(lean_box(0));", + "_G_initialized = true;" + ]; + env.imports.forM $ fun imp => emitLns [ + "res = initialize_" ++ imp.module.mangle "" ++ "(lean_io_mk_world());", + "if (lean_io_result_is_error(res)) return res;", + "lean_dec_ref(res);"]; + let decls := getDecls env; + decls.reverse.forM emitDeclInit; + emitLns ["return lean_mk_io_result(lean_box(0));", "}"] + +def main : M Unit := +do emitFileHeader; + emitFnDecls; + emitFns; + emitInitFn; + emitMainFnIfNeeded; + emitFileFooter + +end EmitC + +@[export lean_ir_emit_c] +def emitC (env : Environment) (modName : Name) : Except String String := +match (EmitC.main { env := env, modName := modName }).run "" with +| EStateM.Result.ok _ s => Except.ok s +| EStateM.Result.error err _ => Except.error err + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/EmitUtil.lean b/stage0/src/Init/Lean/Compiler/IR/EmitUtil.lean new file mode 100644 index 0000000000..857bf9c6f5 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/EmitUtil.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Conditional +import Init.Lean.Compiler.InitAttr +import Init.Lean.Compiler.IR.CompilerM + +/- Helper functions for backend code generators -/ + +namespace Lean +namespace IR +/- Return true iff `b` is of the form `let x := g ys; ret x` -/ +def isTailCallTo (g : Name) (b : FnBody) : Bool := +match b with +| FnBody.vdecl x _ (Expr.fap f _) (FnBody.ret (Arg.var y)) => x == y && f == g +| _ => false + +namespace UsesLeanNamespace + +abbrev M := ReaderT Environment (StateM NameSet) + +def leanNameSpacePrefix := `Lean + +partial def visitFnBody : FnBody → M Bool +| FnBody.vdecl _ _ v b => + let checkFn (f : FunId) : M Bool := + if leanNameSpacePrefix.isPrefixOf f then pure true + else do { + s ← get; + if s.contains f then + visitFnBody b + else do + modify (fun s => s.insert f); + env ← read; + match findEnvDecl env f with + | some (Decl.fdecl _ _ _ fbody) => visitFnBody fbody <||> visitFnBody b + | other => visitFnBody b + }; + match v with + | Expr.fap f _ => checkFn f + | Expr.pap f _ => checkFn f + | other => visitFnBody b +| FnBody.jdecl _ _ v b => visitFnBody v <||> visitFnBody b +| FnBody.case _ _ _ alts => alts.anyM $ fun alt => visitFnBody alt.body +| e => + if e.isTerminal then pure false + else visitFnBody e.body + +end UsesLeanNamespace + +def usesLeanNamespace (env : Environment) : Decl → Bool +| Decl.fdecl _ _ _ b => (UsesLeanNamespace.visitFnBody b env).run' {} +| _ => false + +namespace CollectUsedDecls + +abbrev M := ReaderT Environment (StateM NameSet) + +@[inline] def collect (f : FunId) : M Unit := +modify $ fun s => s.insert f + +partial def collectFnBody : FnBody → M Unit +| FnBody.vdecl _ _ v b => + match v with + | Expr.fap f _ => collect f *> collectFnBody b + | Expr.pap f _ => collect f *> collectFnBody b + | other => collectFnBody b +| FnBody.jdecl _ _ v b => collectFnBody v *> collectFnBody b +| FnBody.case _ _ _ alts => alts.forM $ fun alt => collectFnBody alt.body +| e => unless e.isTerminal $ collectFnBody e.body + +def collectInitDecl (fn : Name) : M Unit := +do env ← read; + match getInitFnNameFor env fn with + | some initFn => collect initFn + | _ => pure () + +def collectDecl : Decl → M NameSet +| Decl.fdecl fn _ _ b => collectInitDecl fn *> CollectUsedDecls.collectFnBody b *> get +| Decl.extern fn _ _ _ => collectInitDecl fn *> get + +end CollectUsedDecls + +def collectUsedDecls (env : Environment) (decl : Decl) (used : NameSet := {}) : NameSet := +(CollectUsedDecls.collectDecl decl env).run' used + +abbrev VarTypeMap := HashMap VarId IRType +abbrev JPParamsMap := HashMap JoinPointId (Array Param) + +namespace CollectMaps +abbrev Collector := (VarTypeMap × JPParamsMap) → (VarTypeMap × JPParamsMap) +@[inline] def collectVar (x : VarId) (t : IRType) : Collector +| (vs, js) => (vs.insert x t, js) +def collectParams (ps : Array Param) : Collector := +fun s => ps.foldl (fun s p => collectVar p.x p.ty s) s +@[inline] def collectJP (j : JoinPointId) (xs : Array Param) : Collector +| (vs, js) => (vs, js.insert j xs) + +/- `collectFnBody` assumes the variables in -/ +partial def collectFnBody : FnBody → Collector +| FnBody.vdecl x t _ b => collectVar x t ∘ collectFnBody b +| FnBody.jdecl j xs v b => collectJP j xs ∘ collectParams xs ∘ collectFnBody v ∘ collectFnBody b +| FnBody.case _ _ _ alts => fun s => alts.foldl (fun s alt => collectFnBody alt.body s) s +| e => if e.isTerminal then id else collectFnBody e.body + +def collectDecl : Decl → Collector +| Decl.fdecl _ xs _ b => collectParams xs ∘ collectFnBody b +| _ => id + +end CollectMaps + +/- Return a pair `(v, j)`, where `v` is a mapping from variable/parameter to type, + and `j` is a mapping from join point to parameters. + This function assumes `d` has normalized indexes (see `normids.lean`). -/ +def mkVarJPMaps (d : Decl) : VarTypeMap × JPParamsMap := +CollectMaps.collectDecl d ({}, {}) + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/ExpandResetReuse.lean b/stage0/src/Init/Lean/Compiler/IR/ExpandResetReuse.lean new file mode 100644 index 0000000000..d497e2867e --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/ExpandResetReuse.lean @@ -0,0 +1,294 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.State +import Init.Control.Reader +import Init.Data.Nat +import Init.Lean.Compiler.IR.CompilerM +import Init.Lean.Compiler.IR.NormIds +import Init.Lean.Compiler.IR.FreeVars + +namespace Lean +namespace IR +namespace ExpandResetReuse +/- Mapping from variable to projections -/ +abbrev ProjMap := HashMap VarId Expr +namespace CollectProjMap +abbrev Collector := ProjMap → ProjMap +@[inline] def collectVDecl (x : VarId) (v : Expr) : Collector := +fun m => match v with + | Expr.proj _ _ => m.insert x v + | Expr.sproj _ _ _ => m.insert x v + | Expr.uproj _ _ => m.insert x v + | _ => m + +partial def collectFnBody : FnBody → Collector +| FnBody.vdecl x _ v b => collectVDecl x v ∘ collectFnBody b +| FnBody.jdecl _ _ v b => collectFnBody v ∘ collectFnBody b +| FnBody.case _ _ _ alts => fun s => alts.foldl (fun s alt => collectFnBody alt.body s) s +| e => if e.isTerminal then id else collectFnBody e.body +end CollectProjMap + +/- Create a mapping from variables to projections. + This function assumes variable ids have been normalized -/ +def mkProjMap (d : Decl) : ProjMap := +match d with +| Decl.fdecl _ _ _ b => CollectProjMap.collectFnBody b {} +| _ => {} + +structure Context := +(projMap : ProjMap) + +/- Return true iff `x` is consumed in all branches of the current block. + Here consumption means the block contains a `dec x` or `reuse x ...`. -/ +partial def consumed (x : VarId) : FnBody → Bool +| FnBody.vdecl _ _ v b => + match v with + | Expr.reuse y _ _ _ => x == y || consumed b + | _ => consumed b +| FnBody.dec y _ _ _ b => x == y || consumed b +| FnBody.case _ _ _ alts => alts.all $ fun alt => consumed alt.body +| e => !e.isTerminal && consumed e.body + +abbrev Mask := Array (Option VarId) + +/- Auxiliary function for eraseProjIncFor -/ +partial def eraseProjIncForAux (y : VarId) : Array FnBody → Mask → Array FnBody → Array FnBody × Mask +| bs, mask, keep => + let done (_ : Unit) := (bs ++ keep.reverse, mask); + let keepInstr (b : FnBody) := eraseProjIncForAux bs.pop mask (keep.push b); + if bs.size < 2 then done () + else + let b := bs.back; + match b with + | (FnBody.vdecl _ _ (Expr.sproj _ _ _) _) => keepInstr b + | (FnBody.vdecl _ _ (Expr.uproj _ _) _) => keepInstr b + | (FnBody.inc z n c p _) => + if n == 0 then done () else + let b' := bs.get! (bs.size - 2); + match b' with + | (FnBody.vdecl w _ (Expr.proj i x) _) => + if w == z && y == x then + /- Found + ``` + let z := proj[i] y; + inc z n c + ``` + We keep `proj`, and `inc` when `n > 1` + -/ + let bs := bs.pop.pop; + let mask := mask.set! i (some z); + let keep := keep.push b'; + let keep := if n == 1 then keep else keep.push (FnBody.inc z (n-1) c p FnBody.nil); + eraseProjIncForAux bs mask keep + else done () + | other => done () + | other => done () + +/- Try to erase `inc` instructions on projections of `y` occurring in the tail of `bs`. + Return the updated `bs` and a bit mask specifying which `inc`s have been removed. -/ +def eraseProjIncFor (n : Nat) (y : VarId) (bs : Array FnBody) : Array FnBody × Mask := +eraseProjIncForAux y bs (mkArray n none) #[] + +/- Replace `reuse x ctor ...` with `ctor ...`, and remoce `dec x` -/ +partial def reuseToCtor (x : VarId) : FnBody → FnBody +| FnBody.dec y n c p b => + if x == y then b -- n must be 1 since `x := reset ...` + else FnBody.dec y n c p (reuseToCtor b) +| FnBody.vdecl z t v b => + match v with + | Expr.reuse y c u xs => + if x == y then FnBody.vdecl z t (Expr.ctor c xs) b + else FnBody.vdecl z t v (reuseToCtor b) + | _ => + FnBody.vdecl z t v (reuseToCtor b) +| FnBody.case tid y yType alts => + let alts := alts.map $ fun alt => alt.modifyBody reuseToCtor; + FnBody.case tid y yType alts +| e => + if e.isTerminal then e + else + let (instr, b) := e.split; + let b := reuseToCtor b; + instr.setBody b + +/- +replace +``` +x := reset y; b +``` +with +``` +inc z_1; ...; inc z_i; dec y; b' +``` +where `z_i`'s are the variables in `mask`, +and `b'` is `b` where we removed `dec x` and replaced `reuse x ctor_i ...` with `ctor_i ...`. +-/ +def mkSlowPath (x y : VarId) (mask : Mask) (b : FnBody) : FnBody := +let b := reuseToCtor x b; +let b := FnBody.dec y 1 true false b; +mask.foldl + (fun b m => match m with + | some z => FnBody.inc z 1 true false b + | none => b) + b + +abbrev M := ReaderT Context (StateM Nat) +def mkFresh : M VarId := +modifyGet $ fun n => ({ idx := n }, n + 1) + +def releaseUnreadFields (y : VarId) (mask : Mask) (b : FnBody) : M FnBody := +mask.size.foldM + (fun i b => + match mask.get! i with + | some _ => pure b -- code took ownership of this field + | none => do + fld ← mkFresh; + pure (FnBody.vdecl fld IRType.object (Expr.proj i y) (FnBody.dec fld 1 true false b))) + b + +def setFields (y : VarId) (zs : Array Arg) (b : FnBody) : FnBody := +zs.size.fold + (fun i b => FnBody.set y i (zs.get! i) b) + b + +/- Given `set x[i] := y`, return true iff `y := proj[i] x` -/ +def isSelfSet (ctx : Context) (x : VarId) (i : Nat) (y : Arg) : Bool := +match y with +| Arg.var y => + match ctx.projMap.find y with + | some (Expr.proj j w) => j == i && w == x + | _ => false +| _ => false + +/- Given `uset x[i] := y`, return true iff `y := uproj[i] x` -/ +def isSelfUSet (ctx : Context) (x : VarId) (i : Nat) (y : VarId) : Bool := +match ctx.projMap.find y with +| some (Expr.uproj j w) => j == i && w == x +| _ => false + +/- Given `sset x[n, i] := y`, return true iff `y := sproj[n, i] x` -/ +def isSelfSSet (ctx : Context) (x : VarId) (n : Nat) (i : Nat) (y : VarId) : Bool := +match ctx.projMap.find y with +| some (Expr.sproj m j w) => n == m && j == i && w == x +| _ => false + +/- Remove unnecessary `set/uset/sset` operations -/ +partial def removeSelfSet (ctx : Context) : FnBody → FnBody +| FnBody.set x i y b => + if isSelfSet ctx x i y then removeSelfSet b + else FnBody.set x i y (removeSelfSet b) +| FnBody.uset x i y b => + if isSelfUSet ctx x i y then removeSelfSet b + else FnBody.uset x i y (removeSelfSet b) +| FnBody.sset x n i y t b => + if isSelfSSet ctx x n i y then removeSelfSet b + else FnBody.sset x n i y t (removeSelfSet b) +| FnBody.case tid y yType alts => + let alts := alts.map $ fun alt => alt.modifyBody removeSelfSet; + FnBody.case tid y yType alts +| e => + if e.isTerminal then e + else + let (instr, b) := e.split; + let b := removeSelfSet b; + instr.setBody b + +partial def reuseToSet (ctx : Context) (x y : VarId) : FnBody → FnBody +| FnBody.dec z n c p b => + if x == z then FnBody.del y b + else FnBody.dec z n c p (reuseToSet b) +| FnBody.vdecl z t v b => + match v with + | Expr.reuse w c u zs => + if x == w then + let b := setFields y zs (b.replaceVar z y); + let b := if u then FnBody.setTag y c.cidx b else b; + removeSelfSet ctx b + else FnBody.vdecl z t v (reuseToSet b) + | _ => FnBody.vdecl z t v (reuseToSet b) +| FnBody.case tid y yType alts => + let alts := alts.map $ fun alt => alt.modifyBody reuseToSet; + FnBody.case tid y yType alts +| e => + if e.isTerminal then e + else + let (instr, b) := e.split; + let b := reuseToSet b; + instr.setBody b + +/- +replace +``` +x := reset y; b +``` +with +``` +let f_i_1 := proj[i_1] y; +... +let f_i_k := proj[i_k] y; +b' +``` +where `i_j`s are the field indexes +that the code did not touch immediately before the reset. +That is `mask[j] == none`. +`b'` is `b` where `y` `dec x` is replaced with `del y`, +and `z := reuse x ctor_i ws; F` is replaced with +`set x i ws[i]` operations, and we replace `z` with `x` in `F` +-/ +def mkFastPath (x y : VarId) (mask : Mask) (b : FnBody) : M FnBody := +do ctx ← read; + let b := reuseToSet ctx x y b; + releaseUnreadFields y mask b + +-- Expand `bs; x := reset[n] y; b` +partial def expand (mainFn : FnBody → Array FnBody → M FnBody) + (bs : Array FnBody) (x : VarId) (n : Nat) (y : VarId) (b : FnBody) : M FnBody := +do let bOld := FnBody.vdecl x IRType.object (Expr.reset n y) b; + let (bs, mask) := eraseProjIncFor n y bs; + /- Remark: we may be duplicting variable/JP indices. That is, `bSlow` and `bFast` may + have duplicate indices. We run `normalizeIds` to fix the ids after we have expand them. -/ + let bSlow := mkSlowPath x y mask b; + bFast ← mkFastPath x y mask b; + /- We only optimize recursively the fast. -/ + bFast ← mainFn bFast #[]; + c ← mkFresh; + let b := FnBody.vdecl c IRType.uint8 (Expr.isShared y) (mkIf c bSlow bFast); + pure $ reshape bs b + +partial def searchAndExpand : FnBody → Array FnBody → M FnBody +| d@(FnBody.vdecl x t (Expr.reset n y) b), bs => + if consumed x b then do + expand searchAndExpand bs x n y b + else + searchAndExpand b (push bs d) +| FnBody.jdecl j xs v b, bs => do + v ← searchAndExpand v #[]; + searchAndExpand b (push bs (FnBody.jdecl j xs v FnBody.nil)) +| FnBody.case tid x xType alts, bs => do + alts ← alts.mapM $ fun alt => alt.mmodifyBody $ fun b => searchAndExpand b #[]; + pure $ reshape bs (FnBody.case tid x xType alts) +| b, bs => + if b.isTerminal then pure $ reshape bs b + else searchAndExpand b.body (push bs b) + +def main (d : Decl) : Decl := +match d with +| (Decl.fdecl f xs t b) => + let m := mkProjMap d; + let nextIdx := d.maxIndex + 1; + let b := (searchAndExpand b #[] { projMap := m }).run' nextIdx; + Decl.fdecl f xs t b +| d => d + +end ExpandResetReuse + +/-- (Try to) expand `reset` and `reuse` instructions. -/ +def Decl.expandResetReuse (d : Decl) : Decl := +(ExpandResetReuse.main d).normalizeIds + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/Format.lean b/stage0/src/Init/Lean/Compiler/IR/Format.lean new file mode 100644 index 0000000000..fcc0ed2530 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/Format.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Format + +namespace Lean +namespace IR + +private def formatArg : Arg → Format +| Arg.var id => format id +| Arg.irrelevant => "◾" + +instance argHasFormat : HasFormat Arg := ⟨formatArg⟩ + +def formatArray {α : Type} [HasFormat α] (args : Array α) : Format := +args.foldl (fun r a => r ++ " " ++ format a) Format.nil + +private def formatLitVal : LitVal → Format +| LitVal.num v => format v +| LitVal.str v => format (repr v) + +instance litValHasFormat : HasFormat LitVal := ⟨formatLitVal⟩ + +private def formatCtorInfo : CtorInfo → Format +| { name := name, cidx := cidx, usize := usize, ssize := ssize, .. } => + let r := format "ctor_" ++ format cidx; + let r := if usize > 0 || ssize > 0 then r ++ "." ++ format usize ++ "." ++ format ssize else r; + let r := if name != Name.anonymous then r ++ "[" ++ format name ++ "]" else r; + r + +instance ctorInfoHasFormat : HasFormat CtorInfo := ⟨formatCtorInfo⟩ + +private def formatExpr : Expr → Format +| Expr.ctor i ys => format i ++ formatArray ys +| Expr.reset n x => "reset[" ++ format n ++ "] " ++ format x +| Expr.reuse x i u ys => "reuse" ++ (if u then "!" else "") ++ " " ++ format x ++ " in " ++ format i ++ formatArray ys +| Expr.proj i x => "proj[" ++ format i ++ "] " ++ format x +| Expr.uproj i x => "uproj[" ++ format i ++ "] " ++ format x +| Expr.sproj n o x => "sproj[" ++ format n ++ ", " ++ format o ++ "] " ++ format x +| Expr.fap c ys => format c ++ formatArray ys +| Expr.pap c ys => "pap " ++ format c ++ formatArray ys +| Expr.ap x ys => "app " ++ format x ++ formatArray ys +| Expr.box _ x => "box " ++ format x +| Expr.unbox x => "unbox " ++ format x +| Expr.lit v => format v +| Expr.isShared x => "isShared " ++ format x +| Expr.isTaggedPtr x => "isTaggedPtr " ++ format x + +instance exprHasFormat : HasFormat Expr := ⟨formatExpr⟩ +instance exprHasToString : HasToString Expr := ⟨fun e => Format.pretty (format e)⟩ + +private partial def formatIRType : IRType → Format +| IRType.float => "float" +| IRType.uint8 => "u8" +| IRType.uint16 => "u16" +| IRType.uint32 => "u32" +| IRType.uint64 => "u64" +| IRType.usize => "usize" +| IRType.irrelevant => "◾" +| IRType.object => "obj" +| IRType.tobject => "tobj" +| IRType.struct _ tys => "struct " ++ Format.bracket "{" (@Format.joinSep _ ⟨formatIRType⟩ tys.toList ", ") "}" +| IRType.union _ tys => "union " ++ Format.bracket "{" (@Format.joinSep _ ⟨formatIRType⟩ tys.toList ", ") "}" + +instance typeHasFormat : HasFormat IRType := ⟨formatIRType⟩ + +private def formatParam : Param → Format +| { x := name, borrow := b, ty := ty } => "(" ++ format name ++ " : " ++ (if b then "@& " else "") ++ format ty ++ ")" + +instance paramHasFormat : HasFormat Param := ⟨formatParam⟩ + +def formatAlt (fmt : FnBody → Format) (indent : Nat) : Alt → Format +| Alt.ctor i b => format i.name ++ " →" ++ Format.nest indent (Format.line ++ fmt b) +| Alt.default b => "default →" ++ Format.nest indent (Format.line ++ fmt b) + +def formatParams (ps : Array Param) : Format := +formatArray ps + +@[export lean_ir_format_fn_body_head] +def formatFnBodyHead : FnBody → Format +| FnBody.vdecl x ty e b => "let " ++ format x ++ " : " ++ format ty ++ " := " ++ format e +| FnBody.jdecl j xs v b => format j ++ formatParams xs ++ " := ..." +| FnBody.set x i y b => "set " ++ format x ++ "[" ++ format i ++ "] := " ++ format y +| FnBody.uset x i y b => "uset " ++ format x ++ "[" ++ format i ++ "] := " ++ format y +| FnBody.sset x i o y ty b => "sset " ++ format x ++ "[" ++ format i ++ ", " ++ format o ++ "] : " ++ format ty ++ " := " ++ format y +| FnBody.setTag x cidx b => "setTag " ++ format x ++ " := " ++ format cidx +| FnBody.inc x n c _ b => "inc" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x +| FnBody.dec x n c _ b => "dec" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x +| FnBody.del x b => "del " ++ format x +| FnBody.mdata d b => "mdata " ++ format d +| FnBody.case tid x xType cs => "case " ++ format x ++ " of ..." +| FnBody.jmp j ys => "jmp " ++ format j ++ formatArray ys +| FnBody.ret x => "ret " ++ format x +| FnBody.unreachable => "⊥" + +partial def formatFnBody (indent : Nat := 2) : FnBody → Format +| FnBody.vdecl x ty e b => "let " ++ format x ++ " : " ++ format ty ++ " := " ++ format e ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.jdecl j xs v b => format j ++ formatParams xs ++ " :=" ++ Format.nest indent (Format.line ++ formatFnBody v) ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.set x i y b => "set " ++ format x ++ "[" ++ format i ++ "] := " ++ format y ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.uset x i y b => "uset " ++ format x ++ "[" ++ format i ++ "] := " ++ format y ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.sset x i o y ty b => "sset " ++ format x ++ "[" ++ format i ++ ", " ++ format o ++ "] : " ++ format ty ++ " := " ++ format y ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.setTag x cidx b => "setTag " ++ format x ++ " := " ++ format cidx ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.inc x n c _ b => "inc" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.dec x n c _ b => "dec" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.del x b => "del " ++ format x ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.mdata d b => "mdata " ++ format d ++ ";" ++ Format.line ++ formatFnBody b +| FnBody.case tid x xType cs => "case " ++ format x ++ " : " ++ format xType ++ " of" ++ cs.foldl (fun r c => r ++ Format.line ++ formatAlt formatFnBody indent c) Format.nil +| FnBody.jmp j ys => "jmp " ++ format j ++ formatArray ys +| FnBody.ret x => "ret " ++ format x +| FnBody.unreachable => "⊥" + +instance fnBodyHasFormat : HasFormat FnBody := ⟨formatFnBody⟩ +instance fnBodyHasToString : HasToString FnBody := ⟨fun b => (format b).pretty⟩ + +def formatDecl (indent : Nat := 2) : Decl → Format +| Decl.fdecl f xs ty b => "def " ++ format f ++ formatParams xs ++ format " : " ++ format ty ++ " :=" ++ Format.nest indent (Format.line ++ formatFnBody indent b) +| Decl.extern f xs ty _ => "extern " ++ format f ++ formatParams xs ++ format " : " ++ format ty + +instance declHasFormat : HasFormat Decl := ⟨formatDecl⟩ + +@[export lean_ir_decl_to_string] +def declToString (d : Decl) : String := +(format d).pretty + +instance declHasToString : HasToString Decl := ⟨declToString⟩ + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/FreeVars.lean b/stage0/src/Init/Lean/Compiler/IR/FreeVars.lean new file mode 100644 index 0000000000..98c8894058 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/FreeVars.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.Basic + +namespace Lean +namespace IR + +namespace MaxIndex +/- Compute the maximum index `M` used in a declaration. + We `M` to initialize the fresh index generator used to create fresh + variable and join point names. + + Recall that we variable and join points share the same namespace in + our implementation. +-/ + +abbrev Collector := Index → Index + +@[inline] private def skip : Collector := id +@[inline] private def collect (x : Index) : Collector := fun y => if x > y then x else y +@[inline] private def collectVar (x : VarId) : Collector := collect x.idx +@[inline] private def collectJP (j : JoinPointId) : Collector := collect j.idx +@[inline] private def seq (k₁ k₂ : Collector) : Collector := k₂ ∘ k₁ +instance : HasAndthen Collector := ⟨seq⟩ + +private def collectArg : Arg → Collector +| Arg.var x => collectVar x +| irrelevant => skip + +@[specialize] private def collectArray {α : Type} (as : Array α) (f : α → Collector) : Collector := +fun m => as.foldl (fun m a => f a m) m + +private def collectArgs (as : Array Arg) : Collector := collectArray as collectArg +private def collectParam (p : Param) : Collector := collectVar p.x +private def collectParams (ps : Array Param) : Collector := collectArray ps collectParam + +private def collectExpr : Expr → Collector +| Expr.ctor _ ys => collectArgs ys +| Expr.reset _ x => collectVar x +| Expr.reuse x _ _ ys => collectVar x >> collectArgs ys +| Expr.proj _ x => collectVar x +| Expr.uproj _ x => collectVar x +| Expr.sproj _ _ x => collectVar x +| Expr.fap _ ys => collectArgs ys +| Expr.pap _ ys => collectArgs ys +| Expr.ap x ys => collectVar x >> collectArgs ys +| Expr.box _ x => collectVar x +| Expr.unbox x => collectVar x +| Expr.lit v => skip +| Expr.isShared x => collectVar x +| Expr.isTaggedPtr x => collectVar x + +private def collectAlts (f : FnBody → Collector) (alts : Array Alt) : Collector := +collectArray alts $ fun alt => f alt.body + +partial def collectFnBody : FnBody → Collector +| FnBody.vdecl x _ v b => collectVar x >> collectExpr v >> collectFnBody b +| FnBody.jdecl j ys v b => collectJP j >> collectFnBody v >> collectParams ys >> collectFnBody b +| FnBody.set x _ y b => collectVar x >> collectArg y >> collectFnBody b +| FnBody.uset x _ y b => collectVar x >> collectVar y >> collectFnBody b +| FnBody.sset x _ _ y _ b => collectVar x >> collectVar y >> collectFnBody b +| FnBody.setTag x _ b => collectVar x >> collectFnBody b +| FnBody.inc x _ _ _ b => collectVar x >> collectFnBody b +| FnBody.dec x _ _ _ b => collectVar x >> collectFnBody b +| FnBody.del x b => collectVar x >> collectFnBody b +| FnBody.mdata _ b => collectFnBody b +| FnBody.case _ x _ alts => collectVar x >> collectAlts collectFnBody alts +| FnBody.jmp j ys => collectJP j >> collectArgs ys +| FnBody.ret x => collectArg x +| FnBody.unreachable => skip + +partial def collectDecl : Decl → Collector +| Decl.fdecl _ xs _ b => collectParams xs >> collectFnBody b +| Decl.extern _ xs _ _ => collectParams xs + +end MaxIndex + +def FnBody.maxIndex (b : FnBody) : Index := +MaxIndex.collectFnBody b 0 + +def Decl.maxIndex (d : Decl) : Index := +MaxIndex.collectDecl d 0 + +namespace FreeIndices +/- We say a variable (join point) index (aka name) is free in a function body + if there isn't a `FnBody.vdecl` (`Fnbody.jdecl`) binding it. -/ + +abbrev Collector := IndexSet → IndexSet → IndexSet + +@[inline] private def skip : Collector := +fun bv fv => fv + +@[inline] private def collectIndex (x : Index) : Collector := +fun bv fv => if bv.contains x then fv else fv.insert x + +@[inline] private def collectVar (x : VarId) : Collector := +collectIndex x.idx + +@[inline] private def collectJP (x : JoinPointId) : Collector := +collectIndex x.idx + +@[inline] private def withIndex (x : Index) : Collector → Collector := +fun k bv fv => k (bv.insert x) fv + +@[inline] private def withVar (x : VarId) : Collector → Collector := +withIndex x.idx + +@[inline] private def withJP (x : JoinPointId) : Collector → Collector := +withIndex x.idx + +def insertParams (s : IndexSet) (ys : Array Param) : IndexSet := +ys.foldl (fun s p => s.insert p.x.idx) s + +@[inline] private def withParams (ys : Array Param) : Collector → Collector := +fun k bv fv => k (insertParams bv ys) fv + +@[inline] private def seq : Collector → Collector → Collector := +fun k₁ k₂ bv fv => k₂ bv (k₁ bv fv) + +instance : HasAndthen Collector := ⟨seq⟩ + +private def collectArg : Arg → Collector +| Arg.var x => collectVar x +| irrelevant => skip + +@[specialize] private def collectArray {α : Type} (as : Array α) (f : α → Collector) : Collector := +fun bv fv => as.foldl (fun fv a => f a bv fv) fv + +private def collectArgs (as : Array Arg) : Collector := +collectArray as collectArg + +private def collectExpr : Expr → Collector +| Expr.ctor _ ys => collectArgs ys +| Expr.reset _ x => collectVar x +| Expr.reuse x _ _ ys => collectVar x >> collectArgs ys +| Expr.proj _ x => collectVar x +| Expr.uproj _ x => collectVar x +| Expr.sproj _ _ x => collectVar x +| Expr.fap _ ys => collectArgs ys +| Expr.pap _ ys => collectArgs ys +| Expr.ap x ys => collectVar x >> collectArgs ys +| Expr.box _ x => collectVar x +| Expr.unbox x => collectVar x +| Expr.lit v => skip +| Expr.isShared x => collectVar x +| Expr.isTaggedPtr x => collectVar x + +private def collectAlts (f : FnBody → Collector) (alts : Array Alt) : Collector := +collectArray alts $ fun alt => f alt.body + +partial def collectFnBody : FnBody → Collector +| FnBody.vdecl x _ v b => collectExpr v >> withVar x (collectFnBody b) +| FnBody.jdecl j ys v b => withParams ys (collectFnBody v) >> withJP j (collectFnBody b) +| FnBody.set x _ y b => collectVar x >> collectArg y >> collectFnBody b +| FnBody.uset x _ y b => collectVar x >> collectVar y >> collectFnBody b +| FnBody.sset x _ _ y _ b => collectVar x >> collectVar y >> collectFnBody b +| FnBody.setTag x _ b => collectVar x >> collectFnBody b +| FnBody.inc x _ _ _ b => collectVar x >> collectFnBody b +| FnBody.dec x _ _ _ b => collectVar x >> collectFnBody b +| FnBody.del x b => collectVar x >> collectFnBody b +| FnBody.mdata _ b => collectFnBody b +| FnBody.case _ x _ alts => collectVar x >> collectAlts collectFnBody alts +| FnBody.jmp j ys => collectJP j >> collectArgs ys +| FnBody.ret x => collectArg x +| FnBody.unreachable => skip + +end FreeIndices + +def FnBody.collectFreeIndices (b : FnBody) (vs : IndexSet) : IndexSet := +FreeIndices.collectFnBody b {} vs + +def FnBody.freeIndices (b : FnBody) : IndexSet := +b.collectFreeIndices {} + +namespace HasIndex +/- In principle, we can check whether a function body `b` contains an index `i` using + `b.freeIndices.contains i`, but it is more efficient to avoid the construction + of the set of freeIndices and just search whether `i` occurs in `b` or not. +-/ +def visitVar (w : Index) (x : VarId) : Bool := w == x.idx +def visitJP (w : Index) (x : JoinPointId) : Bool := w == x.idx + +def visitArg (w : Index) : Arg → Bool +| Arg.var x => visitVar w x +| _ => false + +def visitArgs (w : Index) (xs : Array Arg) : Bool := +xs.any (visitArg w) + +def visitParams (w : Index) (ps : Array Param) : Bool := +ps.any (fun p => w == p.x.idx) + +def visitExpr (w : Index) : Expr → Bool +| Expr.ctor _ ys => visitArgs w ys +| Expr.reset _ x => visitVar w x +| Expr.reuse x _ _ ys => visitVar w x || visitArgs w ys +| Expr.proj _ x => visitVar w x +| Expr.uproj _ x => visitVar w x +| Expr.sproj _ _ x => visitVar w x +| Expr.fap _ ys => visitArgs w ys +| Expr.pap _ ys => visitArgs w ys +| Expr.ap x ys => visitVar w x || visitArgs w ys +| Expr.box _ x => visitVar w x +| Expr.unbox x => visitVar w x +| Expr.lit v => false +| Expr.isShared x => visitVar w x +| Expr.isTaggedPtr x => visitVar w x + +partial def visitFnBody (w : Index) : FnBody → Bool +| FnBody.vdecl x _ v b => visitExpr w v || visitFnBody b +| FnBody.jdecl j ys v b => visitFnBody v || visitFnBody b +| FnBody.set x _ y b => visitVar w x || visitArg w y || visitFnBody b +| FnBody.uset x _ y b => visitVar w x || visitVar w y || visitFnBody b +| FnBody.sset x _ _ y _ b => visitVar w x || visitVar w y || visitFnBody b +| FnBody.setTag x _ b => visitVar w x || visitFnBody b +| FnBody.inc x _ _ _ b => visitVar w x || visitFnBody b +| FnBody.dec x _ _ _ b => visitVar w x || visitFnBody b +| FnBody.del x b => visitVar w x || visitFnBody b +| FnBody.mdata _ b => visitFnBody b +| FnBody.jmp j ys => visitJP w j || visitArgs w ys +| FnBody.ret x => visitArg w x +| FnBody.case _ x _ alts => visitVar w x || alts.any (fun alt => visitFnBody alt.body) +| FnBody.unreachable => false + +end HasIndex + +def Arg.hasFreeVar (arg : Arg) (x : VarId) : Bool := HasIndex.visitArg x.idx arg +def Expr.hasFreeVar (e : Expr) (x : VarId) : Bool := HasIndex.visitExpr x.idx e +def FnBody.hasFreeVar (b : FnBody) (x : VarId) : Bool := HasIndex.visitFnBody x.idx b + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/LiveVars.lean b/stage0/src/Init/Lean/Compiler/IR/LiveVars.lean new file mode 100644 index 0000000000..86ccb21128 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/LiveVars.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.FreeVars +import Init.Control.Reader +import Init.Control.Conditional + +namespace Lean +namespace IR + +/- Remark: in the paper "Counting Immutable Beans" the concepts of + free and live variables coincide because the paper does *not* consider + join points. For example, consider the function body `B` + ``` + let x := ctor_0; + jmp block_1 x + ``` + in a context where we have the join point `block_1` defined as + ``` + block_1 (x : obj) : obj := + let z := ctor_0 x y; + ret z + `` + The variable `y` is live in the function body `B` since it occurs in + `block_1` which is "invoked" by `B`. +-/ + +namespace IsLive +/- + We use `State Context` instead of `ReaderT Context Id` because we remove + non local joint points from `Context` whenever we visit them instead of + maintaining a set of visited non local join points. + + Remark: we don't need to track local join points because we assume there is + no variable or join point shadowing in our IR. +-/ +abbrev M := StateM LocalContext + +@[inline] def visitVar (w : Index) (x : VarId) : M Bool := pure (HasIndex.visitVar w x) +@[inline] def visitJP (w : Index) (x : JoinPointId) : M Bool := pure (HasIndex.visitJP w x) +@[inline] def visitArg (w : Index) (a : Arg) : M Bool := pure (HasIndex.visitArg w a) +@[inline] def visitArgs (w : Index) (as : Array Arg) : M Bool := pure (HasIndex.visitArgs w as) +@[inline] def visitExpr (w : Index) (e : Expr) : M Bool := pure (HasIndex.visitExpr w e) + +partial def visitFnBody (w : Index) : FnBody → M Bool +| FnBody.vdecl x _ v b => visitExpr w v <||> visitFnBody b +| FnBody.jdecl j ys v b => visitFnBody v <||> visitFnBody b +| FnBody.set x _ y b => visitVar w x <||> visitArg w y <||> visitFnBody b +| FnBody.uset x _ y b => visitVar w x <||> visitVar w y <||> visitFnBody b +| FnBody.sset x _ _ y _ b => visitVar w x <||> visitVar w y <||> visitFnBody b +| FnBody.setTag x _ b => visitVar w x <||> visitFnBody b +| FnBody.inc x _ _ _ b => visitVar w x <||> visitFnBody b +| FnBody.dec x _ _ _ b => visitVar w x <||> visitFnBody b +| FnBody.del x b => visitVar w x <||> visitFnBody b +| FnBody.mdata _ b => visitFnBody b +| FnBody.jmp j ys => visitArgs w ys <||> do { + ctx ← get; + match ctx.getJPBody j with + | some b => + -- `j` is not a local join point since we assume we cannot shadow join point declarations. + -- Instead of marking the join points that we have already been visited, we permanently remove `j` from the context. + set (ctx.eraseJoinPointDecl j) *> visitFnBody b + | none => + -- `j` must be a local join point. So do nothing since we have already visite its body. + pure false + } +| FnBody.ret x => visitArg w x +| FnBody.case _ x _ alts => visitVar w x <||> alts.anyM (fun alt => visitFnBody alt.body) +| FnBody.unreachable => pure false + +end IsLive + +/- Return true if `x` is live in the function body `b` in the context `ctx`. + + Remark: the context only needs to contain all (free) join point declarations. + + Recall that we say that a join point `j` is free in `b` if `b` contains + `FnBody.jmp j ys` and `j` is not local. -/ +def FnBody.hasLiveVar (b : FnBody) (ctx : LocalContext) (x : VarId) : Bool := +(IsLive.visitFnBody x.idx b).run' ctx + +abbrev LiveVarSet := VarIdSet +abbrev JPLiveVarMap := RBMap JoinPointId LiveVarSet (fun j₁ j₂ => j₁.idx < j₂.idx) + +instance LiveVarSet.inhabited : Inhabited LiveVarSet := ⟨{}⟩ + +def mkLiveVarSet (x : VarId) : LiveVarSet := +RBTree.empty.insert x + +namespace LiveVars + +abbrev Collector := LiveVarSet → LiveVarSet + +@[inline] private def skip : Collector := fun s => s +@[inline] private def collectVar (x : VarId) : Collector := fun s => s.insert x +private def collectArg : Arg → Collector +| Arg.var x => collectVar x +| irrelevant => skip +@[specialize] private def collectArray {α : Type} (as : Array α) (f : α → Collector) : Collector := +fun s => as.foldl (fun s a => f a s) s +private def collectArgs (as : Array Arg) : Collector := +collectArray as collectArg +private def accumulate (s' : LiveVarSet) : Collector := +fun s => s'.fold (fun s x => s.insert x) s +private def collectJP (m : JPLiveVarMap) (j : JoinPointId) : Collector := +match m.find j with +| some xs => accumulate xs +| none => skip -- unreachable for well-formed code +private def bindVar (x : VarId) : Collector := +fun s => s.erase x +private def bindParams (ps : Array Param) : Collector := +fun s => ps.foldl (fun s p => s.erase p.x) s + +def collectExpr : Expr → Collector +| Expr.ctor _ ys => collectArgs ys +| Expr.reset _ x => collectVar x +| Expr.reuse x _ _ ys => collectVar x ∘ collectArgs ys +| Expr.proj _ x => collectVar x +| Expr.uproj _ x => collectVar x +| Expr.sproj _ _ x => collectVar x +| Expr.fap _ ys => collectArgs ys +| Expr.pap _ ys => collectArgs ys +| Expr.ap x ys => collectVar x ∘ collectArgs ys +| Expr.box _ x => collectVar x +| Expr.unbox x => collectVar x +| Expr.lit v => skip +| Expr.isShared x => collectVar x +| Expr.isTaggedPtr x => collectVar x + +partial def collectFnBody : FnBody → JPLiveVarMap → Collector +| FnBody.vdecl x _ v b, m => collectExpr v ∘ bindVar x ∘ collectFnBody b m +| FnBody.jdecl j ys v b, m => + let jLiveVars := (bindParams ys ∘ collectFnBody v m) {}; + let m := m.insert j jLiveVars; + collectFnBody b m +| FnBody.set x _ y b, m => collectVar x ∘ collectArg y ∘ collectFnBody b m +| FnBody.setTag x _ b, m => collectVar x ∘ collectFnBody b m +| FnBody.uset x _ y b, m => collectVar x ∘ collectVar y ∘ collectFnBody b m +| FnBody.sset x _ _ y _ b, m => collectVar x ∘ collectVar y ∘ collectFnBody b m +| FnBody.inc x _ _ _ b, m => collectVar x ∘ collectFnBody b m +| FnBody.dec x _ _ _ b, m => collectVar x ∘ collectFnBody b m +| FnBody.del x b, m => collectVar x ∘ collectFnBody b m +| FnBody.mdata _ b, m => collectFnBody b m +| FnBody.ret x, m => collectArg x +| FnBody.case _ x _ alts, m => collectVar x ∘ collectArray alts (fun alt => collectFnBody alt.body m) +| FnBody.unreachable, m => skip +| FnBody.jmp j xs, m => collectJP m j ∘ collectArgs xs + +def updateJPLiveVarMap (j : JoinPointId) (ys : Array Param) (v : FnBody) (m : JPLiveVarMap) : JPLiveVarMap := +let jLiveVars := (bindParams ys ∘ collectFnBody v m) {}; +m.insert j jLiveVars + +end LiveVars + +def updateLiveVars (e : Expr) (v : LiveVarSet) : LiveVarSet := +LiveVars.collectExpr e v + +def collectLiveVars (b : FnBody) (m : JPLiveVarMap) (v : LiveVarSet := {}) : LiveVarSet := +LiveVars.collectFnBody b m v + +export LiveVars (updateJPLiveVarMap) + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/NormIds.lean b/stage0/src/Init/Lean/Compiler/IR/NormIds.lean new file mode 100644 index 0000000000..b32d4be52e --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/NormIds.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Reader +import Init.Control.Conditional +import Init.Lean.Compiler.IR.Basic + +namespace Lean +namespace IR +namespace UniqueIds + +abbrev M := StateT IndexSet Id + +def checkId (id : Index) : M Bool := +modifyGet $ fun s => + if s.contains id then (false, s) + else (true, s.insert id) + +def checkParams (ps : Array Param) : M Bool := +ps.allM $ fun p => checkId p.x.idx + +partial def checkFnBody : FnBody → M Bool +| FnBody.vdecl x _ _ b => checkId x.idx <&&> checkFnBody b +| FnBody.jdecl j ys _ b => checkId j.idx <&&> checkParams ys <&&> checkFnBody b +| FnBody.case _ _ _ alts => alts.allM $ fun alt => checkFnBody alt.body +| b => if b.isTerminal then pure true else checkFnBody b.body + +partial def checkDecl : Decl → M Bool +| Decl.fdecl _ xs _ b => checkParams xs <&&> checkFnBody b +| Decl.extern _ xs _ _ => checkParams xs + +end UniqueIds + +/- Return true if variable, parameter and join point ids are unique -/ +def Decl.uniqueIds (d : Decl) : Bool := +(UniqueIds.checkDecl d).run' {} + +namespace NormalizeIds + +abbrev M := ReaderT IndexRenaming Id + +def normIndex (x : Index) : M Index := +fun m => match m.find x with +| some y => y +| none => x + +def normVar (x : VarId) : M VarId := +VarId.mk <$> normIndex x.idx + +def normJP (x : JoinPointId) : M JoinPointId := +JoinPointId.mk <$> normIndex x.idx + +def normArg : Arg → M Arg +| Arg.var x => Arg.var <$> normVar x +| other => pure other + +def normArgs (as : Array Arg) : M (Array Arg) := +fun m => as.map $ fun a => normArg a m + +def normExpr : Expr → M Expr +| Expr.ctor c ys, m => Expr.ctor c (normArgs ys m) +| Expr.reset n x, m => Expr.reset n (normVar x m) +| Expr.reuse x c u ys, m => Expr.reuse (normVar x m) c u (normArgs ys m) +| Expr.proj i x, m => Expr.proj i (normVar x m) +| Expr.uproj i x, m => Expr.uproj i (normVar x m) +| Expr.sproj n o x, m => Expr.sproj n o (normVar x m) +| Expr.fap c ys, m => Expr.fap c (normArgs ys m) +| Expr.pap c ys, m => Expr.pap c (normArgs ys m) +| Expr.ap x ys, m => Expr.ap (normVar x m) (normArgs ys m) +| Expr.box t x, m => Expr.box t (normVar x m) +| Expr.unbox x, m => Expr.unbox (normVar x m) +| Expr.isShared x, m => Expr.isShared (normVar x m) +| Expr.isTaggedPtr x, m => Expr.isTaggedPtr (normVar x m) +| e@(Expr.lit v), m => e + +abbrev N := ReaderT IndexRenaming (StateM Nat) + +@[inline] def withVar {α : Type} (x : VarId) (k : VarId → N α) : N α := +fun m => do + n ← getModify (fun n => n + 1); + k { idx := n } (m.insert x.idx n) + +@[inline] def withJP {α : Type} (x : JoinPointId) (k : JoinPointId → N α) : N α := +fun m => do + n ← getModify (fun n => n + 1); + k { idx := n } (m.insert x.idx n) + +@[inline] def withParams {α : Type} (ps : Array Param) (k : Array Param → N α) : N α := +fun m => do + m ← ps.foldlM (fun (m : IndexRenaming) p => do n ← getModify (fun n => n + 1); pure $ m.insert p.x.idx n) m; + let ps := ps.map $ fun p => { x := normVar p.x m, .. p }; + k ps m + +instance MtoN {α} : HasCoe (M α) (N α) := +⟨fun x m => pure $ x m⟩ + +partial def normFnBody : FnBody → N FnBody +| FnBody.vdecl x t v b => do v ← normExpr v; withVar x $ fun x => FnBody.vdecl x t v <$> normFnBody b +| FnBody.jdecl j ys v b => do + (ys, v) ← withParams ys $ fun ys => do { v ← normFnBody v; pure (ys, v) }; + withJP j $ fun j => FnBody.jdecl j ys v <$> normFnBody b +| FnBody.set x i y b => do x ← normVar x; y ← normArg y; FnBody.set x i y <$> normFnBody b +| FnBody.uset x i y b => do x ← normVar x; y ← normVar y; FnBody.uset x i y <$> normFnBody b +| FnBody.sset x i o y t b => do x ← normVar x; y ← normVar y; FnBody.sset x i o y t <$> normFnBody b +| FnBody.setTag x i b => do x ← normVar x; FnBody.setTag x i <$> normFnBody b +| FnBody.inc x n c p b => do x ← normVar x; FnBody.inc x n c p <$> normFnBody b +| FnBody.dec x n c p b => do x ← normVar x; FnBody.dec x n c p <$> normFnBody b +| FnBody.del x b => do x ← normVar x; FnBody.del x <$> normFnBody b +| FnBody.mdata d b => FnBody.mdata d <$> normFnBody b +| FnBody.case tid x xType alts => do + x ← normVar x; + alts ← alts.mapM $ fun alt => alt.mmodifyBody normFnBody; + pure $ FnBody.case tid x xType alts +| FnBody.jmp j ys => FnBody.jmp <$> normJP j <*> normArgs ys +| FnBody.ret x => FnBody.ret <$> normArg x +| FnBody.unreachable => pure FnBody.unreachable + +def normDecl : Decl → N Decl +| Decl.fdecl f xs t b => withParams xs $ fun xs => Decl.fdecl f xs t <$> normFnBody b +| other => pure other + +end NormalizeIds + +/- Create a declaration equivalent to `d` s.t. `d.normalizeIds.uniqueIds == true` -/ +def Decl.normalizeIds (d : Decl) : Decl := +(NormalizeIds.normDecl d {}).run' 1 + +/- Apply a function `f : VarId → VarId` to variable occurrences. + The following functions assume the IR code does not have variable shadowing. -/ +namespace MapVars + +@[inline] def mapArg (f : VarId → VarId) : Arg → Arg +| Arg.var x => Arg.var (f x) +| a => a + +@[specialize] def mapArgs (f : VarId → VarId) (as : Array Arg) : Array Arg := +as.map (mapArg f) + +@[specialize] def mapExpr (f : VarId → VarId) : Expr → Expr +| Expr.ctor c ys => Expr.ctor c (mapArgs f ys) +| Expr.reset n x => Expr.reset n (f x) +| Expr.reuse x c u ys => Expr.reuse (f x) c u (mapArgs f ys) +| Expr.proj i x => Expr.proj i (f x) +| Expr.uproj i x => Expr.uproj i (f x) +| Expr.sproj n o x => Expr.sproj n o (f x) +| Expr.fap c ys => Expr.fap c (mapArgs f ys) +| Expr.pap c ys => Expr.pap c (mapArgs f ys) +| Expr.ap x ys => Expr.ap (f x) (mapArgs f ys) +| Expr.box t x => Expr.box t (f x) +| Expr.unbox x => Expr.unbox (f x) +| Expr.isShared x => Expr.isShared (f x) +| Expr.isTaggedPtr x => Expr.isTaggedPtr (f x) +| e@(Expr.lit v) => e + +@[specialize] partial def mapFnBody (f : VarId → VarId) : FnBody → FnBody +| FnBody.vdecl x t v b => FnBody.vdecl x t (mapExpr f v) (mapFnBody b) +| FnBody.jdecl j ys v b => FnBody.jdecl j ys (mapFnBody v) (mapFnBody b) +| FnBody.set x i y b => FnBody.set (f x) i (mapArg f y) (mapFnBody b) +| FnBody.setTag x i b => FnBody.setTag (f x) i (mapFnBody b) +| FnBody.uset x i y b => FnBody.uset (f x) i (f y) (mapFnBody b) +| FnBody.sset x i o y t b => FnBody.sset (f x) i o (f y) t (mapFnBody b) +| FnBody.inc x n c p b => FnBody.inc (f x) n c p (mapFnBody b) +| FnBody.dec x n c p b => FnBody.dec (f x) n c p (mapFnBody b) +| FnBody.del x b => FnBody.del (f x) (mapFnBody b) +| FnBody.mdata d b => FnBody.mdata d (mapFnBody b) +| FnBody.case tid x xType alts => FnBody.case tid (f x) xType (alts.map (fun alt => alt.modifyBody mapFnBody)) +| FnBody.jmp j ys => FnBody.jmp j (mapArgs f ys) +| FnBody.ret x => FnBody.ret (mapArg f x) +| FnBody.unreachable => FnBody.unreachable + +end MapVars + +@[inline] def FnBody.mapVars (f : VarId → VarId) (b : FnBody) : FnBody := +MapVars.mapFnBody f b + +/- Replace `x` with `y` in `b`. This function assumes `b` does not shadow `x` -/ +def FnBody.replaceVar (x y : VarId) (b : FnBody) : FnBody := +b.mapVars $ fun z => if x == z then y else z + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/PushProj.lean b/stage0/src/Init/Lean/Compiler/IR/PushProj.lean new file mode 100644 index 0000000000..1b6bfb4f94 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/PushProj.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.FreeVars +import Init.Lean.Compiler.IR.NormIds + +namespace Lean +namespace IR + +partial def pushProjs : Array FnBody → Array Alt → Array IndexSet → Array FnBody → IndexSet → Array FnBody × Array Alt +| bs, alts, altsF, ctx, ctxF => + if bs.isEmpty then (ctx.reverse, alts) + else + let b := bs.back; + let bs := bs.pop; + let done (_ : Unit) := (bs.push b ++ ctx.reverse, alts); + let skip (_ : Unit) := pushProjs bs alts altsF (ctx.push b) (b.collectFreeIndices ctxF); + let push (x : VarId) (t : IRType) (v : Expr) := + if !ctxF.contains x.idx then + let alts := alts.mapIdx $ fun i alt => alt.modifyBody $ fun b' => + if (altsF.get! i).contains x.idx then b.setBody b' + else b'; + let altsF := altsF.map $ fun s => if s.contains x.idx then b.collectFreeIndices s else s; + pushProjs bs alts altsF ctx ctxF + else + skip (); + match b with + | FnBody.vdecl x t v _ => + match v with + | Expr.proj _ _ => push x t v + | Expr.uproj _ _ => push x t v + | Expr.sproj _ _ _ => push x t v + | Expr.isShared _ => skip () + | Expr.isTaggedPtr _ => skip () + | _ => done () + | _ => done () + +partial def FnBody.pushProj : FnBody → FnBody +| b => + let (bs, term) := b.flatten; + let bs := modifyJPs bs FnBody.pushProj; + match term with + | FnBody.case tid x xType alts => + let altsF := alts.map $ fun alt => alt.body.freeIndices; + let (bs, alts) := pushProjs bs alts altsF #[] (mkIndexSet x.idx); + let alts := alts.map $ fun alt => alt.modifyBody FnBody.pushProj; + let term := FnBody.case tid x xType alts; + reshape bs term + | other => reshape bs term + +/-- Push projections inside `case` branches. -/ +def Decl.pushProj : Decl → Decl +| Decl.fdecl f xs t b => (Decl.fdecl f xs t b.pushProj).normalizeIds +| other => other + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/RC.lean b/stage0/src/Init/Lean/Compiler/IR/RC.lean new file mode 100644 index 0000000000..8dee750e92 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/RC.lean @@ -0,0 +1,292 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Runtime +import Init.Lean.Compiler.IR.CompilerM +import Init.Lean.Compiler.IR.LiveVars + +namespace Lean +namespace IR +namespace ExplicitRC +/- Insert explicit RC instructions. So, it assumes the input code does not contain `inc` nor `dec` instructions. + This transformation is applied before lower level optimizations + that introduce the instructions `release` and `set` +-/ + +structure VarInfo := +(ref : Bool := true) -- true if the variable may be a reference (aka pointer) at runtime +(persistent : Bool := false) -- true if the variable is statically known to be marked a Persistent at runtime +(consume : Bool := false) -- true if the variable RC must be "consumed" + +abbrev VarMap := RBMap VarId VarInfo (fun x y => x.idx < y.idx) + +structure Context := +(env : Environment) +(decls : Array Decl) +(varMap : VarMap := {}) +(jpLiveVarMap : JPLiveVarMap := {}) -- map: join point => live variables +(localCtx : LocalContext := {}) -- we use it to store the join point declarations + +def getDecl (ctx : Context) (fid : FunId) : Decl := + match findEnvDecl' ctx.env fid ctx.decls with +| some decl => decl +| none => arbitrary _ -- unreachable if well-formed + +def getVarInfo (ctx : Context) (x : VarId) : VarInfo := +match ctx.varMap.find x with +| some info => info +| none => {} -- unreachable in well-formed code + +def getJPParams (ctx : Context) (j : JoinPointId) : Array Param := +match ctx.localCtx.getJPParams j with +| some ps => ps +| none => #[] -- unreachable in well-formed code + +def getJPLiveVars (ctx : Context) (j : JoinPointId) : LiveVarSet := +match ctx.jpLiveVarMap.find j with +| some s => s +| none => {} + +def mustConsume (ctx : Context) (x : VarId) : Bool := +let info := getVarInfo ctx x; +info.ref && info.consume + +@[inline] def addInc (ctx : Context) (x : VarId) (b : FnBody) (n := 1) : FnBody := +let info := getVarInfo ctx x; +if n == 0 then b else FnBody.inc x n true info.persistent b + +@[inline] def addDec (ctx : Context) (x : VarId) (b : FnBody) : FnBody := +let info := getVarInfo ctx x; +FnBody.dec x 1 true info.persistent b + +private def updateRefUsingCtorInfo (ctx : Context) (x : VarId) (c : CtorInfo) : Context := +if c.isRef then ctx +else let m := ctx.varMap; + { varMap := match m.find x with + | some info => m.insert x { ref := false, .. info } -- I really want a Lenses library + notation + | none => m, + .. ctx } + +private def addDecForAlt (ctx : Context) (caseLiveVars altLiveVars : LiveVarSet) (b : FnBody) : FnBody := +caseLiveVars.fold + (fun b x => if !altLiveVars.contains x && mustConsume ctx x then addDec ctx x b else b) + b + +/- `isFirstOcc xs x i = true` if `xs[i]` is the first occurrence of `xs[i]` in `xs` -/ +private def isFirstOcc (xs : Array Arg) (i : Nat) : Bool := +let x := xs.get! i; +i.all $ fun j => xs.get! j != x + +/- Return true if `x` also occurs in `ys` in a position that is not consumed. + That is, it is also passed as a borrow reference. -/ +@[specialize] +private def isBorrowParamAux (x : VarId) (ys : Array Arg) (consumeParamPred : Nat → Bool) : Bool := +ys.size.any $ fun i => + let y := ys.get! i; + match y with + | Arg.irrelevant => false + | Arg.var y => x == y && !consumeParamPred i + +private def isBorrowParam (x : VarId) (ys : Array Arg) (ps : Array Param) : Bool := +isBorrowParamAux x ys (fun i => not (ps.get! i).borrow) + +/- +Return `n`, the number of times `x` is consumed. +- `ys` is a sequence of instruction parameters where we search for `x`. +- `consumeParamPred i = true` if parameter `i` is consumed. +-/ +@[specialize] +private def getNumConsumptions (x : VarId) (ys : Array Arg) (consumeParamPred : Nat → Bool) : Nat := +ys.size.fold + (fun i n => + let y := ys.get! i; + match y with + | Arg.irrelevant => n + | Arg.var y => if x == y && consumeParamPred i then n+1 else n) + 0 + +@[specialize] +private def addIncBeforeAux (ctx : Context) (xs : Array Arg) (consumeParamPred : Nat → Bool) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody := +xs.size.fold + (fun i b => + let x := xs.get! i; + match x with + | Arg.irrelevant => b + | Arg.var x => + let info := getVarInfo ctx x; + if !info.ref || !isFirstOcc xs i then b + else + let numConsuptions := getNumConsumptions x xs consumeParamPred; -- number of times the argument is + let numIncs := + if !info.consume || -- `x` is not a variable that must be consumed by the current procedure + liveVarsAfter.contains x || -- `x` is live after executing instruction + isBorrowParamAux x xs consumeParamPred -- `x` is used in a position that is passed as a borrow reference + then numConsuptions + else numConsuptions - 1; + -- dbgTrace ("addInc " ++ toString x ++ " nconsumptions: " ++ toString numConsuptions ++ " incs: " ++ toString numIncs + -- ++ " consume: " ++ toString info.consume ++ " live: " ++ toString (liveVarsAfter.contains x) + -- ++ " borrowParam : " ++ toString (isBorrowParamAux x xs consumeParamPred)) $ fun _ => + addInc ctx x b numIncs) + b + +private def addIncBefore (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody := +addIncBeforeAux ctx xs (fun i => not (ps.get! i).borrow) b liveVarsAfter + +/- See `addIncBeforeAux`/`addIncBefore` for the procedure that inserts `inc` operations before an application. -/ +private def addDecAfterFullApp (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody := +xs.size.fold + (fun i b => + match xs.get! i with + | Arg.irrelevant => b + | Arg.var x => + /- We must add a `dec` if `x` must be consumed, it is alive after the application, + and it has been borrowed by the application. + Remark: `x` may occur multiple times in the application (e.g., `f x y x`). + This is why we check whether it is the first occurrence. -/ + if mustConsume ctx x && isFirstOcc xs i && isBorrowParam x xs ps && !bLiveVars.contains x then + addDec ctx x b + else b) + b + +private def addIncBeforeConsumeAll (ctx : Context) (xs : Array Arg) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody := +addIncBeforeAux ctx xs (fun i => true) b liveVarsAfter + +/- Add `dec` instructions for parameters that are references, are not alive in `b`, and are not borrow. + That is, we must make sure these parameters are consumed. -/ +private def addDecForDeadParams (ctx : Context) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody := +ps.foldl + (fun b p => if !p.borrow && p.ty.isObj && !bLiveVars.contains p.x then addDec ctx p.x b else b) + b + +private def isPersistent : Expr → Bool +| Expr.fap c xs => xs.isEmpty -- all global constants are persistent objects +| _ => false + +/- We do not need to consume the projection of a variable that is not consumed -/ +private def consumeExpr (m : VarMap) : Expr → Bool +| Expr.proj i x => match m.find x with + | some info => info.consume + | none => true +| other => true + +/- Return true iff `v` at runtime is a scalar value stored in a tagged pointer. + We do not need RC operations for this kind of value. -/ +private def isScalarBoxedInTaggedPtr (v : Expr) : Bool := +match v with +| Expr.ctor c ys => c.size == 0 && c.ssize == 0 && c.usize == 0 +| Expr.lit (LitVal.num n) => n ≤ maxSmallNat +| _ => false + +private def updateVarInfo (ctx : Context) (x : VarId) (t : IRType) (v : Expr) : Context := +{ varMap := ctx.varMap.insert x { + ref := t.isObj && !isScalarBoxedInTaggedPtr v, + persistent := isPersistent v, + consume := consumeExpr ctx.varMap v }, + .. ctx } + +private def addDecIfNeeded (ctx : Context) (x : VarId) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody := +if mustConsume ctx x && !bLiveVars.contains x then addDec ctx x b else b + +private def processVDecl (ctx : Context) (z : VarId) (t : IRType) (v : Expr) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody × LiveVarSet := +-- dbgTrace ("processVDecl " ++ toString z ++ " " ++ toString (format v)) $ fun _ => +let b := match v with + | (Expr.ctor _ ys) => addIncBeforeConsumeAll ctx ys (FnBody.vdecl z t v b) bLiveVars + | (Expr.reuse _ _ _ ys) => addIncBeforeConsumeAll ctx ys (FnBody.vdecl z t v b) bLiveVars + | (Expr.proj _ x) => + let b := addDecIfNeeded ctx x b bLiveVars; + let b := if (getVarInfo ctx x).consume then addInc ctx z b else b; + (FnBody.vdecl z t v b) + | (Expr.uproj _ x) => FnBody.vdecl z t v (addDecIfNeeded ctx x b bLiveVars) + | (Expr.sproj _ _ x) => FnBody.vdecl z t v (addDecIfNeeded ctx x b bLiveVars) + | (Expr.fap f ys) => + -- dbgTrace ("processVDecl " ++ toString v) $ fun _ => + let ps := (getDecl ctx f).params; + let b := addDecAfterFullApp ctx ys ps b bLiveVars; + let b := FnBody.vdecl z t v b; + addIncBefore ctx ys ps b bLiveVars + | (Expr.pap _ ys) => addIncBeforeConsumeAll ctx ys (FnBody.vdecl z t v b) bLiveVars + | (Expr.ap x ys) => + let ysx := ys.push (Arg.var x); -- TODO: avoid temporary array allocation + addIncBeforeConsumeAll ctx ysx (FnBody.vdecl z t v b) bLiveVars + | (Expr.unbox x) => FnBody.vdecl z t v (addDecIfNeeded ctx x b bLiveVars) + | other => FnBody.vdecl z t v b; -- Expr.reset, Expr.box, Expr.lit are handled here +let liveVars := updateLiveVars v bLiveVars; +let liveVars := liveVars.erase z; +(b, liveVars) + +def updateVarInfoWithParams (ctx : Context) (ps : Array Param) : Context := +let m := ps.foldl (fun (m : VarMap) p => m.insert p.x { ref := p.ty.isObj, consume := !p.borrow }) ctx.varMap; +{ varMap := m, .. ctx } + +partial def visitFnBody : FnBody → Context → (FnBody × LiveVarSet) +| FnBody.vdecl x t v b, ctx => + let ctx := updateVarInfo ctx x t v; + let (b, bLiveVars) := visitFnBody b ctx; + processVDecl ctx x t v b bLiveVars +| FnBody.jdecl j xs v b, ctx => + let (v, vLiveVars) := visitFnBody v (updateVarInfoWithParams ctx xs); + let v := addDecForDeadParams ctx xs v vLiveVars; + let ctx := { jpLiveVarMap := updateJPLiveVarMap j xs v ctx.jpLiveVarMap, .. ctx }; + let (b, bLiveVars) := visitFnBody b ctx; + (FnBody.jdecl j xs v b, bLiveVars) +| FnBody.uset x i y b, ctx => + let (b, s) := visitFnBody b ctx; + -- We don't need to insert `y` since we only need to track live variables that are references at runtime + let s := s.insert x; + (FnBody.uset x i y b, s) +| FnBody.sset x i o y t b, ctx => + let (b, s) := visitFnBody b ctx; + -- We don't need to insert `y` since we only need to track live variables that are references at runtime + let s := s.insert x; + (FnBody.sset x i o y t b, s) +| FnBody.mdata m b, ctx => + let (b, s) := visitFnBody b ctx; + (FnBody.mdata m b, s) +| b@(FnBody.case tid x xType alts), ctx => + let caseLiveVars := collectLiveVars b ctx.jpLiveVarMap; + let alts := alts.map $ fun alt => match alt with + | Alt.ctor c b => + let ctx := updateRefUsingCtorInfo ctx x c; + let (b, altLiveVars) := visitFnBody b ctx; + let b := addDecForAlt ctx caseLiveVars altLiveVars b; + Alt.ctor c b + | Alt.default b => + let (b, altLiveVars) := visitFnBody b ctx; + let b := addDecForAlt ctx caseLiveVars altLiveVars b; + Alt.default b; + (FnBody.case tid x xType alts, caseLiveVars) +| b@(FnBody.ret x), ctx => + match x with + | Arg.var x => + let info := getVarInfo ctx x; + if info.ref && !info.consume then (addInc ctx x b, mkLiveVarSet x) else (b, mkLiveVarSet x) + | _ => (b, {}) +| b@(FnBody.jmp j xs), ctx => + let jLiveVars := getJPLiveVars ctx j; + let ps := getJPParams ctx j; + let b := addIncBefore ctx xs ps b jLiveVars; + let bLiveVars := collectLiveVars b ctx.jpLiveVarMap; + (b, bLiveVars) +| FnBody.unreachable, _ => (FnBody.unreachable, {}) +| other, ctx => (other, {}) -- unreachable if well-formed + +partial def visitDecl (env : Environment) (decls : Array Decl) : Decl → Decl +| Decl.fdecl f xs t b => + let ctx : Context := { env := env, decls := decls }; + let ctx := updateVarInfoWithParams ctx xs; + let (b, bLiveVars) := visitFnBody b ctx; + let b := addDecForDeadParams ctx xs b bLiveVars; + Decl.fdecl f xs t b +| other => other + +end ExplicitRC + +def explicitRC (decls : Array Decl) : CompilerM (Array Decl) := +do env ← getEnv; + pure $ decls.map (ExplicitRC.visitDecl env decls) + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/ResetReuse.lean b/stage0/src/Init/Lean/Compiler/IR/ResetReuse.lean new file mode 100644 index 0000000000..f624ef92db --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/ResetReuse.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.State +import Init.Control.Reader +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.LiveVars +import Init.Lean.Compiler.IR.Format + +namespace Lean +namespace IR +namespace ResetReuse +/- Remark: the insertResetReuse transformation is applied before we have + inserted `inc/dec` instructions, and perfomed lower level optimizations + that introduce the instructions `release` and `set`. -/ + +/- Remark: the functions `S`, `D` and `R` defined here implement the + corresponding functions in the paper "Counting Immutable Beans" + + Here are the main differences: + - We use the State monad to manage the generation of fresh variable names. + - Support for join points, and `uset` and `sset` instructions for unboxed data. + - `D` uses the auxiliary function `Dmain`. + - `Dmain` returns a pair `(b, found)` to avoid quadratic behavior when checking + the last occurrence of the variable `x`. + - Because we have join points in the actual implementation, a variable may be live even if it + does not occur in a function body. See example at `livevars.lean`. +-/ + +private def mayReuse (c₁ c₂ : CtorInfo) : Bool := +c₁.size == c₂.size && c₁.usize == c₂.usize && c₁.ssize == c₂.ssize && +/- The following condition is a heuristic. + We don't want to reuse cells from different types even when they are compatible + because it produces counterintuitive behavior. -/ +c₁.name.getPrefix == c₂.name.getPrefix + +private partial def S (w : VarId) (c : CtorInfo) : FnBody → FnBody +| FnBody.vdecl x t v@(Expr.ctor c' ys) b => + if mayReuse c c' then + let updtCidx := c.cidx != c'.cidx; + FnBody.vdecl x t (Expr.reuse w c' updtCidx ys) b + else + FnBody.vdecl x t v (S b) +| FnBody.jdecl j ys v b => + let v' := S v; + if v == v' then FnBody.jdecl j ys v (S b) + else FnBody.jdecl j ys v' b +| FnBody.case tid x xType alts => FnBody.case tid x xType $ alts.map $ fun alt => alt.modifyBody S +| b => + if b.isTerminal then b + else let + (instr, b) := b.split; + instr.setBody (S b) + +/- We use `Context` to track join points in scope. -/ +abbrev M := ReaderT LocalContext (StateT Index Id) + +private def mkFresh : M VarId := +do idx ← getModify (fun n => n + 1); + pure { idx := idx } + +private def tryS (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody := +do w ← mkFresh; + let b' := S w c b; + if b == b' then pure b + else pure $ FnBody.vdecl w IRType.object (Expr.reset c.size x) b' + +private def Dfinalize (x : VarId) (c : CtorInfo) : FnBody × Bool → M FnBody +| (b, true) => pure b +| (b, false) => tryS x c b + +private def argsContainsVar (ys : Array Arg) (x : VarId) : Bool := +ys.any $ fun arg => match arg with + | Arg.var y => x == y + | _ => false + +private def isCtorUsing (b : FnBody) (x : VarId) : Bool := +match b with +| (FnBody.vdecl _ _ (Expr.ctor _ ys) _) => argsContainsVar ys x +| _ => false + +/- Given `Dmain b`, the resulting pair `(new_b, flag)` contains the new body `new_b`, + and `flag == true` if `x` is live in `b`. + + Note that, in the function `D` defined in the paper, for each `let x := e; F`, + `D` checks whether `x` is live in `F` or not. This is great for clarity but it + is expensive: `O(n^2)` where `n` is the size of the function body. -/ +private partial def Dmain (x : VarId) (c : CtorInfo) : FnBody → M (FnBody × Bool) +| e@(FnBody.case tid y yType alts) => do + ctx ← read; + if e.hasLiveVar ctx x then do + /- If `x` is live in `e`, we recursively process each branch. -/ + alts ← alts.mapM $ fun alt => alt.mmodifyBody (fun b => Dmain b >>= Dfinalize x c); + pure (FnBody.case tid y yType alts, true) + else pure (e, false) +| FnBody.jdecl j ys v b => do + (b, found) ← adaptReader (fun (ctx : LocalContext) => ctx.addJP j ys v) (Dmain b); + (v, _ /- found' -/) ← Dmain v; + /- If `found' == true`, then `Dmain b` must also have returned `(b, true)` since + we assume the IR does not have dead join points. So, if `x` is live in `j` (i.e., `v`), + then it must also live in `b` since `j` is reachable from `b` with a `jmp`. + On the other hand, `x` may be live in `b` but dead in `j` (i.e., `v`). -/ + pure (FnBody.jdecl j ys v b, found) +| e => do + ctx ← read; + if e.isTerminal then + pure (e, e.hasLiveVar ctx x) + else do + let (instr, b) := e.split; + if isCtorUsing instr x then + /- If the scrutinee `x` (the one that is providing memory) is being + stored in a constructor, then reuse will probably not be able to reuse memory at runtime. + It may work only if the new cell is consumed, but we ignore this case. -/ + pure (e, true) + else do + (b, found) ← Dmain b; + /- Remark: it is fine to use `hasFreeVar` instead of `hasLiveVar` + since `instr` is not a `FnBody.jmp` (it is not a terminal) nor it is a `FnBody.jdecl`. -/ + if found || !instr.hasFreeVar x then + pure (instr.setBody b, found) + else do + b ← tryS x c b; + pure (instr.setBody b, true) + +private def D (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody := +Dmain x c b >>= Dfinalize x c + +partial def R : FnBody → M FnBody +| FnBody.case tid x xType alts => do + alts ← alts.mapM $ fun alt => do { + alt ← alt.mmodifyBody R; + match alt with + | Alt.ctor c b => + if c.isScalar then pure alt + else Alt.ctor c <$> D x c b + | _ => pure alt + }; + pure $ FnBody.case tid x xType alts +| FnBody.jdecl j ys v b => do + v ← R v; + b ← adaptReader (fun (ctx : LocalContext) => ctx.addJP j ys v) (R b); + pure $ FnBody.jdecl j ys v b +| e => do + if e.isTerminal then pure e + else do + let (instr, b) := e.split; + b ← R b; + pure (instr.setBody b) + +end ResetReuse + +open ResetReuse + +def Decl.insertResetReuse : Decl → Decl +| d@(Decl.fdecl f xs t b) => + let nextIndex := d.maxIndex + 1; + let b := (R b {}).run' nextIndex; + Decl.fdecl f xs t b +| other => other + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/SimpCase.lean b/stage0/src/Init/Lean/Compiler/IR/SimpCase.lean new file mode 100644 index 0000000000..bf7b018b5f --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/SimpCase.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.Format + +namespace Lean +namespace IR + +def ensureHasDefault (alts : Array Alt) : Array Alt := +if alts.any Alt.isDefault then alts +else if alts.size < 2 then alts +else + let last := alts.back; + let alts := alts.pop; + alts.push (Alt.default last.body) + +private def getOccsOf (alts : Array Alt) (i : Nat) : Nat := +let aBody := (alts.get! i).body; +alts.iterateFrom 1 (i + 1) $ fun _ a' n => + if a'.body == aBody then n+1 else n + +private def maxOccs (alts : Array Alt) : Alt × Nat := +alts.iterateFrom (alts.get! 0, getOccsOf alts 0) 1 $ fun i a p => + let noccs := getOccsOf alts i.val; + if noccs > p.2 then (alts.get i, noccs) else p + +private def addDefault (alts : Array Alt) : Array Alt := +if alts.size <= 1 || alts.any Alt.isDefault then alts +else + let (max, noccs) := maxOccs alts; + if noccs == 1 then alts + else + let alts := alts.filter $ (fun alt => alt.body != max.body); + alts.push (Alt.default max.body) + +private def mkSimpCase (tid : Name) (x : VarId) (xType : IRType) (alts : Array Alt) : FnBody := +let alts := alts.filter (fun alt => alt.body != FnBody.unreachable); +let alts := addDefault alts; +if alts.size == 0 then + FnBody.unreachable +else if alts.size == 1 then + (alts.get! 0).body +else + FnBody.case tid x xType alts + +partial def FnBody.simpCase : FnBody → FnBody +| b => + let (bs, term) := b.flatten; + let bs := modifyJPs bs FnBody.simpCase; + match term with + | FnBody.case tid x xType alts => + let alts := alts.map $ fun alt => alt.modifyBody FnBody.simpCase; + reshape bs (mkSimpCase tid x xType alts) + | other => reshape bs term + +/-- Simplify `case` + - Remove unreachable branches. + - Remove `case` if there is only one branch. + - Merge most common branches using `Alt.default`. -/ +def Decl.simpCase : Decl → Decl +| Decl.fdecl f xs t b => Decl.fdecl f xs t b.simpCase +| other => other + +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/IR/UnboxResult.lean b/stage0/src/Init/Lean/Compiler/IR/UnboxResult.lean new file mode 100644 index 0000000000..63054ebae2 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/IR/UnboxResult.lean @@ -0,0 +1,33 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Format +import Init.Lean.Compiler.IR.Basic +import Init.Lean.Compiler.IR.CtorLayout + +namespace Lean +namespace IR +namespace UnboxResult + +def mkUnboxAttr : IO TagAttribute := +registerTagAttribute `unbox "compiler tries to unbox result values if their types are tagged with `[unbox]`" $ fun env declName => + match env.find declName with + | none => Except.error "unknown declaration" + | some cinfo => match cinfo with + | ConstantInfo.inductInfo v => + if v.isRec then Except.error "recursive inductive datatypes are not supported" + else Except.ok () + | _ => Except.error "constant must be an inductive type" + +@[init mkUnboxAttr] +constant unboxAttr : TagAttribute := arbitrary _ + +def hasUnboxAttr (env : Environment) (n : Name) : Bool := +unboxAttr.hasTag env n + +end UnboxResult +end IR +end Lean diff --git a/stage0/src/Init/Lean/Compiler/ImplementedByAttr.lean b/stage0/src/Init/Lean/Compiler/ImplementedByAttr.lean new file mode 100644 index 0000000000..89d18292a7 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/ImplementedByAttr.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes + +namespace Lean +namespace Compiler + +def mkImplementedByAttr : IO (ParametricAttribute Name) := +registerParametricAttribute `implementedBy "name of the Lean (probably unsafe) function that implements opaque constant" $ fun env declName stx => + match env.find declName with + | none => Except.error "unknown declaration" + | some decl => + match attrParamSyntaxToIdentifier stx with + | some fnName => + match env.find fnName with + | none => Except.error ("unknown function '" ++ toString fnName ++ "'") + | some fnDecl => + if decl.type == fnDecl.type then Except.ok fnName + else Except.error ("invalid function '" ++ toString fnName ++ "' type mismatch") + | _ => Except.error "expected identifier" + +@[init mkImplementedByAttr] +constant implementedByAttr : ParametricAttribute Name := arbitrary _ + +@[export lean_get_implemented_by] +def getImplementedBy (env : Environment) (n : Name) : Option Name := +implementedByAttr.getParam env n + +end Compiler +end Lean diff --git a/stage0/src/Init/Lean/Compiler/InitAttr.lean b/stage0/src/Init/Lean/Compiler/InitAttr.lean new file mode 100644 index 0000000000..c1e5f31ac0 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/InitAttr.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment +import Init.Lean.Attributes + +namespace Lean + +private def getIOTypeArg : Expr → Option Expr +| Expr.app (Expr.const `IO _ _) arg _ => some arg +| _ => none + +private def isUnitType : Expr → Bool +| Expr.const `Unit _ _ => true +| _ => false + +private def isIOUnit (type : Expr) : Bool := +match getIOTypeArg type with +| some type => isUnitType type +| _ => false + +def mkInitAttr : IO (ParametricAttribute Name) := +registerParametricAttribute `init "initialization procedure for global references" $ fun env declName stx => + match env.find declName with + | none => Except.error "unknown declaration" + | some decl => + match attrParamSyntaxToIdentifier stx with + | some initFnName => + match env.find initFnName with + | none => Except.error ("unknown initialization function '" ++ toString initFnName ++ "'") + | some initDecl => + match getIOTypeArg initDecl.type with + | none => Except.error ("initialization function '" ++ toString initFnName ++ "' must have type of the form `IO `") + | some initTypeArg => + if decl.type == initTypeArg then Except.ok initFnName + else Except.error ("initialization function '" ++ toString initFnName ++ "' type mismatch") + | _ => match stx with + | Syntax.missing => + if isIOUnit decl.type then Except.ok Name.anonymous + else Except.error "initialization function must have type `IO Unit`" + | _ => Except.error "unexpected kind of argument" + +@[init mkInitAttr] +constant initAttr : ParametricAttribute Name := arbitrary _ + +def isIOUnitInitFn (env : Environment) (fn : Name) : Bool := +match initAttr.getParam env fn with +| some Name.anonymous => true +| _ => false + +@[export lean_get_init_fn_name_for] +def getInitFnNameFor (env : Environment) (fn : Name) : Option Name := +match initAttr.getParam env fn with +| some Name.anonymous => none +| some n => some n +| _ => none + +def hasInitAttr (env : Environment) (fn : Name) : Bool := +(getInitFnNameFor env fn).isSome + +def setInitAttr (env : Environment) (declName : Name) (initFnName : Name := Name.anonymous) : Except String Environment := +initAttr.setParam env declName initFnName + +end Lean diff --git a/stage0/src/Init/Lean/Compiler/InlineAttrs.lean b/stage0/src/Init/Lean/Compiler/InlineAttrs.lean new file mode 100644 index 0000000000..dff9d02b41 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/InlineAttrs.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes +import Init.Lean.Compiler.Util + +namespace Lean +namespace Compiler + +inductive InlineAttributeKind +| inline | noinline | macroInline | inlineIfReduce + +namespace InlineAttributeKind + +instance : Inhabited InlineAttributeKind := ⟨InlineAttributeKind.inline⟩ + +protected def beq : InlineAttributeKind → InlineAttributeKind → Bool +| inline, inline => true +| noinline, noinline => true +| macroInline, macroInline => true +| inlineIfReduce, inlineIfReduce => true +| _, _ => false + +instance : HasBeq InlineAttributeKind := ⟨InlineAttributeKind.beq⟩ + +end InlineAttributeKind + +def mkInlineAttrs : IO (EnumAttributes InlineAttributeKind) := +registerEnumAttributes `inlineAttrs + [(`inline, "mark definition to always be inlined", InlineAttributeKind.inline), + (`inlineIfReduce, "mark definition to be inlined when resultant term after reduction is not a `cases_on` application", InlineAttributeKind.inlineIfReduce), + (`noinline, "mark definition to never be inlined", InlineAttributeKind.noinline), + (`macroInline, "mark definition to always be inlined before ANF conversion", InlineAttributeKind.macroInline)] + (fun env declName _ => checkIsDefinition env declName) + +@[init mkInlineAttrs] +constant inlineAttrs : EnumAttributes InlineAttributeKind := arbitrary _ + +private partial def hasInlineAttrAux (env : Environment) (kind : InlineAttributeKind) : Name → Bool +| n => + /- We never inline auxiliary declarations created by eager lambda lifting -/ + if isEagerLambdaLiftingName n then false + else match inlineAttrs.getValue env n with + | some k => kind == k + | none => if n.isInternal then hasInlineAttrAux n.getPrefix else false + +@[export lean_has_inline_attribute] +def hasInlineAttribute (env : Environment) (n : Name) : Bool := +hasInlineAttrAux env InlineAttributeKind.inline n + +@[export lean_has_inline_if_reduce_attribute] +def hasInlineIfReduceAttribute (env : Environment) (n : Name) : Bool := +hasInlineAttrAux env InlineAttributeKind.inlineIfReduce n + +@[export lean_has_noinline_attribute] +def hasNoInlineAttribute (env : Environment) (n : Name) : Bool := +hasInlineAttrAux env InlineAttributeKind.noinline n + +@[export lean_has_macro_inline_attribute] +def hasMacroInlineAttribute (env : Environment) (n : Name) : Bool := +hasInlineAttrAux env InlineAttributeKind.macroInline n + +end Compiler +end Lean diff --git a/stage0/src/Init/Lean/Compiler/NameMangling.lean b/stage0/src/Init/Lean/Compiler/NameMangling.lean new file mode 100644 index 0000000000..9ad9877a3a --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/NameMangling.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Lean.Name +namespace Lean + +private def String.mangleAux : Nat → String.Iterator → String → String +| 0, it, r => r +| i+1, it, r => + let c := it.curr; + if c.isAlpha || c.isDigit then + String.mangleAux i it.next (r.push c) + else if c = '_' then + String.mangleAux i it.next (r ++ "__") + else if c.toNat < 255 then + let n := c.toNat; + let r := r ++ "_x"; + let r := r.push $ Nat.digitChar (n / 16); + let r := r.push $ Nat.digitChar (n % 16); + String.mangleAux i it.next r + else + let n := c.toNat; + let r := r ++ "_u"; + let r := r.push $ Nat.digitChar (n / 4096); + let n := n % 4096; + let r := r.push $ Nat.digitChar (n / 256); + let n := n % 256; + let r := r.push $ Nat.digitChar (n / 16); + let r := r.push $ Nat.digitChar (n % 16); + String.mangleAux i it.next r + +def String.mangle (s : String) : String := +String.mangleAux s.length s.mkIterator "" + +private def Name.mangleAux : Name → String +| Name.anonymous => "" +| Name.str p s _ => + let m := String.mangle s; + match p with + | Name.anonymous => m + | _ => Name.mangleAux p ++ "_" ++ m +| Name.num p n _ => Name.mangleAux p ++ "_" ++ toString n ++ "_" + +@[export lean_name_mangle] +def Name.mangle (n : Name) (pre : String := "l_") : String := +pre ++ Name.mangleAux n + +end Lean diff --git a/stage0/src/Init/Lean/Compiler/NeverExtractAttr.lean b/stage0/src/Init/Lean/Compiler/NeverExtractAttr.lean new file mode 100644 index 0000000000..2aabdd9f4f --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/NeverExtractAttr.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment +import Init.Lean.Attributes + +namespace Lean + +def mkNeverExtractAttr : IO TagAttribute := +registerTagAttribute `neverExtract "instruct the compiler that function applications using the tagged declaration should not be extracted when they are closed terms, nor common subexpression should be performed. This is useful for declarations that have implicit effects." + +@[init mkNeverExtractAttr] +constant neverExtractAttr : TagAttribute := arbitrary _ + +private partial def hasNeverExtractAttributeAux (env : Environment) : Name → Bool +| n => + neverExtractAttr.hasTag env n + || + (n.isInternal && hasNeverExtractAttributeAux n.getPrefix) + +@[export lean_has_never_extract_attribute] +def hasNeverExtractAttribute (env : Environment) (n : Name) : Bool := +hasNeverExtractAttributeAux env n + +end Lean diff --git a/stage0/src/Init/Lean/Compiler/Specialize.lean b/stage0/src/Init/Lean/Compiler/Specialize.lean new file mode 100644 index 0000000000..1000bf87e6 --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/Specialize.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes +import Init.Lean.Compiler.Util + +namespace Lean +namespace Compiler + +inductive SpecializeAttributeKind +| specialize | nospecialize + +namespace SpecializeAttributeKind + +instance : Inhabited SpecializeAttributeKind := ⟨SpecializeAttributeKind.specialize⟩ + +protected def beq : SpecializeAttributeKind → SpecializeAttributeKind → Bool +| specialize, specialize => true +| nospecialize, nospecialize => true +| _, _ => false + +instance : HasBeq SpecializeAttributeKind := ⟨SpecializeAttributeKind.beq⟩ + +end SpecializeAttributeKind + +def mkSpecializeAttrs : IO (EnumAttributes SpecializeAttributeKind) := +registerEnumAttributes `specializeAttrs + [(`specialize, "mark definition to always be inlined", SpecializeAttributeKind.specialize), + (`nospecialize, "mark definition to never be inlined", SpecializeAttributeKind.nospecialize) ] + /- TODO: fix the following hack. + We need to use the following hack because the equation compiler generates auxiliary + definitions that are compiled before we even finish the elaboration of the current command. + So, if the current command is a `@[specialize] def foo ...`, we must set the attribute `[specialize]` + before we start elaboration, otherwise when we compile the auxiliary definitions we will not be + able to test whether `@[specialize]` has been set or not. + In the new equation compiler we should pass all attributes and allow it to apply them to auxiliary definitions. + In the current implementation, we workaround this issue by using functions such as `hasSpecializeAttrAux`. + -/ + (fun env declName _ => Except.ok ()) + AttributeApplicationTime.beforeElaboration + +@[init mkSpecializeAttrs] +constant specializeAttrs : EnumAttributes SpecializeAttributeKind := arbitrary _ + +private partial def hasSpecializeAttrAux (env : Environment) (kind : SpecializeAttributeKind) : Name → Bool +| n => match specializeAttrs.getValue env n with + | some k => kind == k + | none => if n.isInternal then hasSpecializeAttrAux n.getPrefix else false + +@[export lean_has_specialize_attribute] +def hasSpecializeAttribute (env : Environment) (n : Name) : Bool := +hasSpecializeAttrAux env SpecializeAttributeKind.specialize n + +@[export lean_has_nospecialize_attribute] +def hasNospecializeAttribute (env : Environment) (n : Name) : Bool := +hasSpecializeAttrAux env SpecializeAttributeKind.nospecialize n + +inductive SpecArgKind +| fixed +| fixedNeutral -- computationally neutral +| fixedHO -- higher order +| fixedInst -- type class instance +| other + +structure SpecInfo := +(mutualDecls : List Name) (argKinds : SpecArgKind) + +structure SpecState := +(specInfo : SMap Name SpecInfo := {}) +(cache : SMap Expr Name := {}) + +inductive SpecEntry +| info (name : Name) (info : SpecInfo) +| cache (key : Expr) (fn : Name) + +namespace SpecState + +instance : Inhabited SpecState := ⟨{}⟩ + +def addEntry (s : SpecState) (e : SpecEntry) : SpecState := +match e with +| SpecEntry.info name info => { specInfo := s.specInfo.insert name info, .. s } +| SpecEntry.cache key fn => { cache := s.cache.insert key fn, .. s } + +def switch : SpecState → SpecState +| ⟨m₁, m₂⟩ => ⟨m₁.switch, m₂.switch⟩ + +end SpecState + +def mkSpecExtension : IO (SimplePersistentEnvExtension SpecEntry SpecState) := +registerSimplePersistentEnvExtension { + name := `specialize, + addEntryFn := SpecState.addEntry, + addImportedFn := fun es => (mkStateFromImportedEntries SpecState.addEntry {} es).switch +} + +@[init mkSpecExtension] +constant specExtension : SimplePersistentEnvExtension SpecEntry SpecState := arbitrary _ + +@[export lean_add_specialization_info] +def addSpecializationInfo (env : Environment) (fn : Name) (info : SpecInfo) : Environment := +specExtension.addEntry env (SpecEntry.info fn info) + +@[export lean_get_specialization_info] +def getSpecializationInfo (env : Environment) (fn : Name) : Option SpecInfo := +(specExtension.getState env).specInfo.find fn + +@[export lean_cache_specialization] +def cacheSpecialization (env : Environment) (e : Expr) (fn : Name) : Environment := +specExtension.addEntry env (SpecEntry.cache e fn) + +@[export lean_get_cached_specialization] +def getCachedSpecialization (env : Environment) (e : Expr) : Option Name := +(specExtension.getState env).cache.find e + +end Compiler +end Lean diff --git a/stage0/src/Init/Lean/Compiler/Util.lean b/stage0/src/Init/Lean/Compiler/Util.lean new file mode 100644 index 0000000000..490a8d85ad --- /dev/null +++ b/stage0/src/Init/Lean/Compiler/Util.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment + +namespace Lean +namespace Compiler + +def neutralExpr : Expr := mkConst `_neutral +def unreachableExpr : Expr := mkConst `_unreachable +def objectType : Expr := mkConst `_obj +def voidType : Expr := mkConst `_void +def mkLcProof (pred : Expr) := mkApp (mkConst `lcProof []) pred + +namespace atMostOnce + +structure AtMostOnceData := +(found result : Bool) + +def Visitor := AtMostOnceData → AtMostOnceData + +@[inline] def seq (f g : Visitor) : Visitor := +fun d => match f d with +| ⟨found, false⟩ => ⟨found, false⟩ +| other => g other + +instance : HasAndthen Visitor := +⟨seq⟩ + +@[inline] def skip : Visitor := id + +@[inline] def visitFVar (x y : Name) : Visitor +| d@{result := false, ..} => d +| {found := false, result := true} => {found := x == y, result := true} +| {found := true, result := true} => {found := true, result := x != y} + +def visit (x : Name) : Expr → Visitor +| Expr.fvar y _ => visitFVar y x +| Expr.app f a _ => visit a >> visit f +| Expr.lam _ d b _ => visit d >> visit b +| Expr.forallE _ d b _ => visit d >> visit b +| Expr.letE _ t v b _ => visit t >> visit v >> visit b +| Expr.mdata _ e _ => visit e +| Expr.proj _ _ e _ => visit e +| _ => skip + +end atMostOnce + +/-- Return true iff the free variable with id `x` occurs at most once in `e` -/ +@[export lean_at_most_once] +def atMostOnce (e : Expr) (x : Name) : Bool := +let {result := result, ..} := atMostOnce.visit x e {found := false, result := true}; +result + +/- Helper functions for creating auxiliary names used in compiler passes. -/ + +@[export lean_mk_eager_lambda_lifting_name] +def mkEagerLambdaLiftingName (n : Name) (idx : Nat) : Name := +mkNameStr n ("_elambda_" ++ toString idx) + +@[export lean_is_eager_lambda_lifting_name] +def isEagerLambdaLiftingName : Name → Bool +| Name.str p s _ => "_elambda".isPrefixOf s || isEagerLambdaLiftingName p +| Name.num p _ _ => isEagerLambdaLiftingName p +| _ => false + +/-- Return the name of new definitions in the a given declaration. + Here we consider only declarations we generate code for. + We use this definition to implement `add_and_compile`. -/ +@[export lean_get_decl_names_for_code_gen] +private def getDeclNamesForCodeGen : Declaration → List Name +| Declaration.defnDecl { name := n, .. } => [n] +| Declaration.mutualDefnDecl defs => defs.map $ fun d => d.name +| _ => [] + +def checkIsDefinition (env : Environment) (n : Name) : Except String Unit := +match env.find n with +| (some (ConstantInfo.defnInfo _)) => Except.ok () +| none => Except.error "unknow declaration" +| _ => Except.error "declaration is not a definition" + +end Compiler +end Lean diff --git a/stage0/src/Init/Lean/Declaration.lean b/stage0/src/Init/Lean/Declaration.lean new file mode 100644 index 0000000000..e702c5993d --- /dev/null +++ b/stage0/src/Init/Lean/Declaration.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Expr + +namespace Lean +/-- +Reducibility hints are used in the convertibility checker. +When trying to solve a constraint such a + + (f ...) =?= (g ...) + +where f and g are definitions, the checker has to decide which one will be unfolded. + If f (g) is opaque, then g (f) is unfolded if it is also not marked as opaque, + Else if f (g) is abbrev, then f (g) is unfolded if g (f) is also not marked as abbrev, + Else if f and g are regular, then we unfold the one with the biggest definitional height. + Otherwise both are unfolded. + +The arguments of the `regular` Constructor are: the definitional height and the flag `selfOpt`. + +The definitional height is by default computed by the kernel. It only takes into account +other regular definitions used in a definition. When creating declarations using meta-programming, +we can specify the definitional depth manually. + +Remark: the hint only affects performance. None of the hints prevent the kernel from unfolding a +declaration during Type checking. + +Remark: the ReducibilityHints are not related to the attributes: reducible/irrelevance/semireducible. +These attributes are used by the Elaborator. The ReducibilityHints are used by the kernel (and Elaborator). +Moreover, the ReducibilityHints cannot be changed after a declaration is added to the kernel. -/ +inductive ReducibilityHints +| opaque : ReducibilityHints +| «abbrev» : ReducibilityHints +| regular : UInt32 → ReducibilityHints + +namespace ReducibilityHints + +instance : Inhabited ReducibilityHints := ⟨opaque⟩ + +def lt : ReducibilityHints → ReducibilityHints → Bool +| «abbrev», «abbrev» => false +| «abbrev», _ => true +| regular d₁, regular d₂ => d₁ < d₂ +| regular _, opaque => true +| _, _ => false + +end ReducibilityHints + +/-- Base structure for `AxiomVal`, `DefinitionVal`, `TheoremVal`, `InductiveVal`, `ConstructorVal`, `RecursorVal` and `QuotVal`. -/ +structure ConstantVal := +(name : Name) (lparams : List Name) (type : Expr) + +structure AxiomVal extends ConstantVal := +(isUnsafe : Bool) + +structure DefinitionVal extends ConstantVal := +(value : Expr) (hints : ReducibilityHints) (isUnsafe : Bool) + +structure TheoremVal extends ConstantVal := +(value : Task Expr) + +/- Value for an opaque constant declaration `constant x : t := e` -/ +structure OpaqueVal extends ConstantVal := +(value : Expr) + +structure Constructor := +(name : Name) (type : Expr) + +structure inductiveType := +(name : Name) (type : Expr) (ctors : List Constructor) + +/-- Declaration object that can be sent to the kernel. -/ +inductive Declaration +| axiomDecl (val : AxiomVal) +| defnDecl (val : DefinitionVal) +| thmDecl (val : TheoremVal) +| opaqueDecl (val : OpaqueVal) +| quotDecl +| mutualDefnDecl (defns : List DefinitionVal) -- All definitions must be marked as `unsafe` +| inductDecl (lparams : List Name) (nparams : Nat) (types : List inductiveType) (isUnsafe : Bool) + +/-- The kernel compiles (mutual) inductive declarations (see `inductiveDecls`) into a set of + - `Declaration.inductDecl` (for each inductive datatype in the mutual Declaration), + - `Declaration.ctorDecl` (for each Constructor in the mutual Declaration), + - `Declaration.recDecl` (automatically generated recursors). + + This data is used to implement iota-reduction efficiently and compile nested inductive + declarations. + + A series of checks are performed by the kernel to check whether a `inductiveDecls` + is valid or not. -/ +structure InductiveVal extends ConstantVal := +(nparams : Nat) -- Number of parameters +(nindices : Nat) -- Number of indices +(all : List Name) -- List of all (including this one) inductive datatypes in the mutual declaration containing this one +(ctors : List Name) -- List of all constructors for this inductive datatype +(isRec : Bool) -- `true` Iff it is recursive +(isUnsafe : Bool) +(isReflexive : Bool) + +namespace InductiveVal +def nctors (v : InductiveVal) : Nat := v.ctors.length +end InductiveVal + +structure ConstructorVal extends ConstantVal := +(induct : Name) -- Inductive Type this Constructor is a member of +(cidx : Nat) -- Constructor index (i.e., Position in the inductive declaration) +(nparams : Nat) -- Number of parameters in inductive datatype `induct` +(nfields : Nat) -- Number of fields (i.e., arity - nparams) +(isUnsafe : Bool) + +/-- Information for reducing a recursor -/ +structure RecursorRule := +(ctor : Name) -- Reduction rule for this Constructor +(nfields : Nat) -- Number of fields (i.e., without counting inductive datatype parameters) +(rhs : Expr) -- Right hand side of the reduction rule + +structure RecursorVal extends ConstantVal := +(all : List Name) -- List of all inductive datatypes in the mutual declaration that generated this recursor +(nparams : Nat) -- Number of parameters +(nindices : Nat) -- Number of indices +(nmotives : Nat) -- Number of motives +(nminors : Nat) -- Number of minor premises +(rules : List RecursorRule) -- A reduction for each Constructor +(k : Bool) -- It supports K-like reduction +(isUnsafe : Bool) + +namespace RecursorVal +def getMajorIdx (v : RecursorVal) : Nat := +v.nparams + v.nmotives + v.nminors + v.nindices + +def getInduct (v : RecursorVal) : Name := +v.name.getPrefix + +end RecursorVal + +inductive QuotKind +| type -- `Quot` +| ctor -- `Quot.mk` +| lift -- `Quot.lift` +| ind -- `Quot.ind` + +structure QuotVal extends ConstantVal := +(kind : QuotKind) + +/-- Information associated with constant declarations. -/ +inductive ConstantInfo +| axiomInfo (val : AxiomVal) +| defnInfo (val : DefinitionVal) +| thmInfo (val : TheoremVal) +| opaqueInfo (val : OpaqueVal) +| quotInfo (val : QuotVal) +| inductInfo (val : InductiveVal) +| ctorInfo (val : ConstructorVal) +| recInfo (val : RecursorVal) + +namespace ConstantInfo + +def toConstantVal : ConstantInfo → ConstantVal +| defnInfo {toConstantVal := d, ..} => d +| axiomInfo {toConstantVal := d, ..} => d +| thmInfo {toConstantVal := d, ..} => d +| opaqueInfo {toConstantVal := d, ..} => d +| quotInfo {toConstantVal := d, ..} => d +| inductInfo {toConstantVal := d, ..} => d +| ctorInfo {toConstantVal := d, ..} => d +| recInfo {toConstantVal := d, ..} => d + +def name (d : ConstantInfo) : Name := +d.toConstantVal.name + +def lparams (d : ConstantInfo) : List Name := +d.toConstantVal.lparams + +def type (d : ConstantInfo) : Expr := +d.toConstantVal.type + +def value? : ConstantInfo → Option Expr +| defnInfo {value := r, ..} => some r +| thmInfo {value := r, ..} => some r.get +| _ => none + +def hasValue : ConstantInfo → Bool +| defnInfo {value := r, ..} => true +| thmInfo {value := r, ..} => true +| _ => false + +def value! : ConstantInfo → Expr +| defnInfo {value := r, ..} => r +| thmInfo {value := r, ..} => r.get +| _ => panic! "declaration with value expected" + +def hints : ConstantInfo → ReducibilityHints +| defnInfo {hints := r, ..} => r +| _ => ReducibilityHints.opaque + +def isCtor : ConstantInfo → Bool +| ctorInfo _ => true +| _ => false + +@[extern "lean_instantiate_type_lparams"] +constant instantiateTypeLevelParams (c : ConstantInfo) (ls : List Level) : Expr := arbitrary _ + +@[extern "lean_instantiate_value_lparams"] +constant instantiateValueLevelParams (c : ConstantInfo) (ls : List Level) : Expr := arbitrary _ + +end ConstantInfo +end Lean diff --git a/stage0/src/Init/Lean/Elaborator.lean b/stage0/src/Init/Lean/Elaborator.lean new file mode 100644 index 0000000000..07efb46012 --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Elaborator.Basic +import Init.Lean.Elaborator.ElabStrategyAttrs +import Init.Lean.Elaborator.Command +import Init.Lean.Elaborator.PreTerm +import Init.Lean.Elaborator.Term diff --git a/stage0/src/Init/Lean/Elaborator/Alias.lean b/stage0/src/Init/Lean/Elaborator/Alias.lean new file mode 100644 index 0000000000..5da1a86973 --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator/Alias.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment + +namespace Lean + +/- We use aliases to implement the `export (+)` command. -/ + +abbrev AliasState := SMap Name (List Name) +abbrev AliasEntry := Name × Name + +def addAliasEntry (s : AliasState) (e : AliasEntry) : AliasState := +match s.find e.1 with +| none => s.insert e.1 [e.2] +| some es => if es.elem e.2 then s else s.insert e.1 (e.2 :: es) + +def mkAliasExtension : IO (SimplePersistentEnvExtension AliasEntry AliasState) := +registerSimplePersistentEnvExtension { + name := `aliasesExt, + addEntryFn := addAliasEntry, + addImportedFn := fun es => (mkStateFromImportedEntries addAliasEntry {} es).switch +} + +@[init mkAliasExtension] +constant aliasExtension : SimplePersistentEnvExtension AliasEntry AliasState := arbitrary _ + +/- Add alias `a` for `e` -/ +def addAlias (env : Environment) (a : Name) (e : Name) : Environment := +aliasExtension.addEntry env (a, e) + +def getAliases (env : Environment) (a : Name) : List Name := +match (aliasExtension.getState env).find a with +| none => [] +| some es => es + +end Lean diff --git a/stage0/src/Init/Lean/Elaborator/Basic.lean b/stage0/src/Init/Lean/Elaborator/Basic.lean new file mode 100644 index 0000000000..375aa4276c --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator/Basic.lean @@ -0,0 +1,507 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Control.Reader +import Init.Lean.MetavarContext +import Init.Lean.NameGenerator +import Init.Lean.Scopes +import Init.Lean.Parser.Module + +namespace Lean + +inductive OpenDecl +| simple (ns : Name) (except : List Name) +| explicit (id : Name) (declName : Name) + +namespace OpenDecl +instance : Inhabited OpenDecl := ⟨simple Name.anonymous []⟩ + +instance : HasToString OpenDecl := +⟨fun decl => match decl with + | explicit id decl => toString id ++ " → " ++ toString decl + | simple ns ex => toString ns ++ (if ex == [] then "" else " hiding " ++ toString ex)⟩ + +end OpenDecl + +structure ElabContext := +(fileName : String) +(fileMap : FileMap) + +structure ElabScope := +(cmd : String) +(header : Name) +(options : Options := {}) +(ns : Name := Name.anonymous) -- current namespace +(openDecls : List OpenDecl := []) +(univs : List Name := []) +(lctx : LocalContext := {}) +(nextInstIdx : Nat := 1) +(inPattern : Bool := false) + +namespace ElabScope + +instance : Inhabited ElabScope := ⟨{ cmd := "", header := arbitrary _ }⟩ + +end ElabScope + +structure ElabState := +(env : Environment) +(messages : MessageLog := {}) +(cmdPos : String.Pos := 0) +(ngen : NameGenerator := {}) +(mctx : MetavarContext := {}) +(scopes : List ElabScope := [{ cmd := "root", header := Name.anonymous }]) + +inductive ElabException +| io : IO.Error → ElabException +| msg : Message → ElabException +| kernel : KernelException → ElabException +| other : String → ElabException +/- ElabException.silent is used when we log an error in `messages`, and then + want to interrupt the elaborator execution. We use it to make sure the + top-level handler does not record it again in `messages`. See `logErrorAndThrow` -/ +| silent : ElabException + +namespace ElabException + +instance : Inhabited ElabException := ⟨other "error"⟩ + +end ElabException + +abbrev Elab := ReaderT ElabContext (EStateM ElabException ElabState) + +instance str2ElabException : HasCoe String ElabException := ⟨ElabException.other⟩ + +abbrev TermElab := SyntaxNode Expr → Option Expr → Elab (Syntax Expr) +abbrev CommandElab := SyntaxNode → Elab Unit + +abbrev TermElabTable : Type := SMap SyntaxNodeKind TermElab +abbrev CommandElabTable : Type := SMap SyntaxNodeKind CommandElab +def mkBuiltinTermElabTable : IO (IO.Ref TermElabTable) := IO.mkRef {} +def mkBuiltinCommandElabTable : IO (IO.Ref CommandElabTable) := IO.mkRef {} +@[init mkBuiltinTermElabTable] +constant builtinTermElabTable : IO.Ref TermElabTable := arbitrary _ +@[init mkBuiltinCommandElabTable] +constant builtinCommandElabTable : IO.Ref CommandElabTable := arbitrary _ + +def addBuiltinTermElab (k : SyntaxNodeKind) (declName : Name) (elab : TermElab) : IO Unit := +do m ← builtinTermElabTable.get; + when (m.contains k) $ + throw (IO.userError ("invalid builtin term elaborator, elaborator for '" ++ toString k ++ "' has already been defined")); + builtinTermElabTable.modify $ fun m => m.insert k elab + +def addBuiltinCommandElab (k : SyntaxNodeKind) (declName : Name) (elab : CommandElab) : IO Unit := +do m ← builtinCommandElabTable.get; + when (m.contains k) $ + throw (IO.userError ("invalid builtin command elaborator, elaborator for '" ++ toString k ++ "' has already been defined")); + builtinCommandElabTable.modify $ fun m => m.insert k elab + +def checkSyntaxNodeKind (k : Name) : IO Name := +do b ← Parser.isValidSyntaxNodeKind k; + if b then pure k + else throw (IO.userError "failed") + +def checkSyntaxNodeKindAtNamespaces (k : Name) : List Name → IO Name +| [] => throw (IO.userError "failed") +| n::ns => checkSyntaxNodeKind (n ++ k) <|> checkSyntaxNodeKindAtNamespaces ns + +def syntaxNodeKindOfAttrParam (env : Environment) (parserNamespace : Name) (arg : Syntax) : IO SyntaxNodeKind := +match attrParamSyntaxToIdentifier arg with +| some k => + checkSyntaxNodeKind k + <|> + checkSyntaxNodeKindAtNamespaces k env.getNamespaces + <|> + checkSyntaxNodeKind (parserNamespace ++ k) + <|> + throw (IO.userError ("invalid syntax node kind '" ++ toString k ++ "'")) +| none => throw (IO.userError ("syntax node kind is missing")) + +def declareBuiltinElab (env : Environment) (addFn : Name) (kind : SyntaxNodeKind) (declName : Name) : IO Environment := +let name := `_regBuiltinTermElab ++ declName; +let type := mkApp (mkConst `IO) (mkConst `Unit); +let val := mkCAppN addFn #[toExpr kind, toExpr declName, mkConst declName]; +let decl := Declaration.defnDecl { name := name, lparams := [], type := type, value := val, hints := ReducibilityHints.opaque, isUnsafe := false }; +match env.addAndCompile {} decl with +-- TODO: pretty print error +| Except.error _ => throw (IO.userError ("failed to emit registration code for builtin term elaborator '" ++ toString declName ++ "'")) +| Except.ok env => IO.ofExcept (setInitAttr env name) + +def declareBuiltinTermElab (env : Environment) (kind : SyntaxNodeKind) (declName : Name) : IO Environment := +declareBuiltinElab env `Lean.addBuiltinTermElab kind declName + +def declareBuiltinCommandElab (env : Environment) (kind : SyntaxNodeKind) (declName : Name) : IO Environment := +declareBuiltinElab env `Lean.addBuiltinCommandElab kind declName + +@[init] def registerBuiltinTermElabAttr : IO Unit := +registerAttribute { + name := `builtinTermElab, + descr := "Builtin term elaborator", + add := fun env declName arg persistent => do { + unless persistent $ throw (IO.userError ("invalid attribute 'builtinTermElab', must be persistent")); + kind ← syntaxNodeKindOfAttrParam env `Lean.Parser.Term arg; + match env.find declName with + | none => throw "unknown declaration" + | some decl => + match decl.type with + | Expr.const `Lean.TermElab _ _ => declareBuiltinTermElab env kind declName + | _ => throw (IO.userError ("unexpected term elaborator type at '" ++ toString declName ++ "' `TermElab` expected")) + }, + applicationTime := AttributeApplicationTime.afterCompilation +} + +@[init] def registerBuiltinCommandElabAttr : IO Unit := +registerAttribute { + name := `builtinCommandElab, + descr := "Builtin command elaborator", + add := fun env declName arg persistent => do { + unless persistent $ throw (IO.userError ("invalid attribute 'builtinCommandElab', must be persistent")); + kind ← syntaxNodeKindOfAttrParam env `Lean.Parser.Command arg; + match env.find declName with + | none => throw "unknown declaration" + | some decl => + match decl.type with + | Expr.const `Lean.CommandElab _ _ => declareBuiltinCommandElab env kind declName + | _ => throw (IO.userError ("unexpected command elaborator type at '" ++ toString declName ++ "' `CommandElab` expected")) + }, + applicationTime := AttributeApplicationTime.afterCompilation +} + +structure ElabAttributeEntry := +(kind : SyntaxNodeKind) +(declName : Name) + +structure ElabAttribute (σ : Type) := +(attr : AttributeImpl) +(ext : PersistentEnvExtension ElabAttributeEntry σ) +(kind : String) + +namespace ElabAttribute + +instance {σ} [Inhabited σ] : Inhabited (ElabAttribute σ) := ⟨{ attr := arbitrary _, ext := arbitrary _, kind := "" }⟩ + +end ElabAttribute + +/- +This is just the basic skeleton for the `[termElab]` attribute and environment extension. +The state is initialized using `builtinTermElabTable`. + +The current implementation just uses the bultin elaborators. +-/ +def mkElabAttribute {σ} [Inhabited σ] (attrName : Name) (kind : String) (builtinTable : IO.Ref σ) : IO (ElabAttribute σ) := +do ext : PersistentEnvExtension ElabAttributeEntry σ ← registerPersistentEnvExtension { + name := attrName, + addImportedFn := fun es => do + table ← builtinTable.get; + -- TODO: populate table with `es` + pure table, + addEntryFn := fun (s : σ) _ => s, -- TODO + exportEntriesFn := fun _ => #[], -- TODO + statsFn := fun _ => fmt (kind ++ " elaborator attribute") -- TODO + }; + let attrImpl : AttributeImpl := { + name := attrName, + descr := kind ++ " elaborator", + add := fun env decl args persistent => pure env -- TODO + }; + pure { ext := ext, attr := attrImpl, kind := kind } + +abbrev TermElabAttribute := ElabAttribute TermElabTable +def mkTermElabAttribute : IO TermElabAttribute := +mkElabAttribute `elabTerm "term" builtinTermElabTable +@[init mkTermElabAttribute] +constant termElabAttribute : TermElabAttribute := arbitrary _ + +abbrev CommandElabAttribute := ElabAttribute CommandElabTable +def mkCommandElabAttribute : IO CommandElabAttribute := +mkElabAttribute `commandTerm "command" builtinCommandElabTable +@[init mkCommandElabAttribute] +constant commandElabAttribute : CommandElabAttribute := arbitrary _ + +namespace Elab +def logMessage (msg : Message) : Elab Unit := +modify $ fun s => { messages := s.messages.add msg, .. s } + +def getPosition (pos : Option String.Pos := none) : Elab Position := +do ctx ← read; + s ← get; + pure $ ctx.fileMap.toPosition (pos.getD s.cmdPos) + +def mkMessage (msg : String) (pos : Option String.Pos := none) : Elab Message := +do ctx ← read; + s ← get; + let pos := ctx.fileMap.toPosition (pos.getD s.cmdPos); + pure { fileName := ctx.fileName, pos := pos, data := msg } + +def logErrorAt (pos : String.Pos) (errorMsg : String) : Elab Unit := +mkMessage errorMsg pos >>= logMessage + +def logErrorUsingCmdPos (errorMsg : String) : Elab Unit := +do s ← get; + logErrorAt s.cmdPos errorMsg + +def getPos {α} (stx : Syntax α) : Elab String.Pos := +match stx.getPos with +| some p => pure p +| none => do s ← get; pure s.cmdPos + +def logError {α} (stx : Syntax α) (errorMsg : String) : Elab Unit := +do pos ← getPos stx; + logErrorAt pos errorMsg + +def logElabException (e : ElabException) : Elab Unit := +let log (msg : Message) : Elab Unit := + modify $ fun s => { messages := s.messages.add msg, .. s }; +match e with +| ElabException.silent => pure () -- do nothing since message was already logged +| ElabException.msg m => log m +| ElabException.io e => mkMessage (toString e) >>= log +| ElabException.other e => mkMessage e >>= log +| ElabException.kernel e => + match e with + | KernelException.other msg => mkMessage msg >>= log + | _ => mkMessage "kernel exception" >>= log -- TODO(pretty print them) + +def logErrorAndThrow {α β : Type} (stx : Syntax β) (errorMsg : String) : Elab α := +do logError stx errorMsg; + throw ElabException.silent + +def logUnknownDecl {α} (stx : Syntax α) (declName : Name) : Elab Unit := +logError stx ("unknown declaration '" ++ toString declName ++ "'") + +def getEnv : Elab Environment := +do s ← get; pure s.env + +def setEnv (env : Environment) : Elab Unit := +modify $ fun s => { env := env, .. s } + +def elabCommand (stx : Syntax) : Elab Unit := +stx.ifNode + (fun n => do + s ← get; + let tables := commandElabAttribute.ext.getState s.env; + let k := n.getKind; + match tables.find k with + | some elab => elab n + | none => logError stx ("command '" ++ toString k ++ "' has not been implemented")) + (fun _ => logErrorUsingCmdPos ("unexpected command")) + +structure FrontendState := +(elabState : ElabState) +(parserState : Parser.ModuleParserState) + +abbrev Frontend := ReaderT Parser.ParserContextCore (EStateM ElabException FrontendState) + +def getElabContext : Frontend ElabContext := +do c ← read; + pure { fileName := c.fileName, fileMap := c.fileMap } + +@[specialize] def runElab {α} (x : Elab α) : Frontend α := +do c ← getElabContext; + monadLift $ EStateM.adaptState + (fun (s : FrontendState) => (s.elabState, s.parserState)) + (fun es ps => { elabState := es, parserState := ps }) + (x c) + +def elabCommandAtFrontend (stx : Syntax) : Frontend Unit := +runElab (elabCommand stx) + +def updateCmdPos : Frontend Unit := +modify $ fun s => { elabState := { cmdPos := s.parserState.pos, .. s.elabState }, .. s } + +def processCommand : Frontend Bool := +do updateCmdPos; + s ← get; + let es := s.elabState; + let ps := s.parserState; + c ← read; + match Parser.parseCommand es.env c ps es.messages with + | (cmd, ps, messages) => do + set { elabState := { messages := messages, .. es }, parserState := ps }; + if Parser.isEOI cmd || Parser.isExitCommand cmd then do + pure true -- Done + else do + catch (elabCommandAtFrontend cmd) $ fun e => runElab (logElabException e); + pure false + +partial def processCommandsAux : Unit → Frontend Unit +| () => do + done ← processCommand; + if done then pure () + else processCommandsAux () + +def processCommands : Frontend Unit := +processCommandsAux () + +def headerToImports (header : Syntax) : List Import := +let header := header.asNode; +let imports := if (header.getArg 0).isNone then [{Import . module := `Init.Default}] else []; +imports ++ (header.getArg 1).getArgs.toList.map (fun stx => + -- `stx` is of the form `(Module.import "import" "runtime"? id) + let runtime := !(stx.getArg 1).isNone; + let id := stx.getIdAt 2; + { module := normalizeModuleName id, runtimeOnly := runtime }) + +def processHeader (header : Syntax) (messages : MessageLog) (ctx : Parser.ParserContextCore) (trustLevel : UInt32 := 0) : IO (Environment × MessageLog) := +catch + (do env ← importModules (headerToImports header) trustLevel; + pure (env, messages)) + (fun e => do + env ← mkEmptyEnvironment; + let spos := header.getPos.getD 0; + let pos := ctx.fileMap.toPosition spos; + pure (env, messages.add { fileName := ctx.fileName, data := toString e, pos := pos })) + +@[export lean_parse_imports] +def parseImports (input : String) (fileName : Option String := none) : IO (List Import × Position × MessageLog) := +do env ← mkEmptyEnvironment; + let fileName := fileName.getD ""; + let ctx := Parser.mkParserContextCore env input fileName; + match Parser.parseHeader env ctx with + | (header, parserState, messages) => do + pure (headerToImports header, ctx.fileMap.toPosition parserState.pos, messages) + +@[export lean_print_deps] +def printDeps (deps : List Import) : IO Unit := +deps.forM $ fun dep => do + fname ← findOLean dep.module; + IO.println fname + +def testFrontend (input : String) (fileName : Option String := none) : IO (Environment × MessageLog) := +do env ← mkEmptyEnvironment; + let fileName := fileName.getD ""; + let ctx := Parser.mkParserContextCore env input fileName; + match Parser.parseHeader env ctx with + | (header, parserState, messages) => do + (env, messages) ← processHeader header messages ctx; + let elabState := { ElabState . env := env, messages := messages }; + match (processCommands ctx).run { elabState := elabState, parserState := parserState } with + | EStateM.Result.ok _ s => pure (s.elabState.env, s.elabState.messages) + | EStateM.Result.error _ s => pure (s.elabState.env, s.elabState.messages) + +instance {α} : Inhabited (Elab α) := +⟨fun _ => arbitrary _⟩ + +def mkFreshName : Elab Name := +modifyGet $ fun s => (s.ngen.curr, { ngen := s.ngen.next, .. s }) + +def getScope : Elab ElabScope := +do s ← get; pure s.scopes.head! + +def getOpenDecls : Elab (List OpenDecl) := +ElabScope.openDecls <$> getScope + +def getUniverses : Elab (List Name) := +ElabScope.univs <$> getScope + +def getNamespace : Elab Name := +do s ← get; + match s.scopes with + | [] => pure Name.anonymous + | (sc::_) => pure sc.ns + +@[specialize] def modifyScope (f : ElabScope → ElabScope) : Elab Unit := +modify $ fun s => + { scopes := match s.scopes with + | h::t => f h :: t + | [] => [], -- unreachable + .. s } + +@[specialize] def modifyGetScope {α} [Inhabited α] (f : ElabScope → α × ElabScope) : Elab α := +modifyGet $ fun s => + match s with + | { scopes := h::t, .. } => + let (a, h) := f h; + (a, { scopes := h :: t, .. s }) + | _ => (arbitrary _, s) + +def localContext : Elab LocalContext := +do scope ← getScope; pure scope.lctx + +def mkLocalDecl (userName : Name) (type : Expr) (bi : BinderInfo := BinderInfo.default) : Elab Expr := +do idx ← mkFreshName; + modifyScope $ fun scope => { lctx := scope.lctx.mkLocalDecl idx userName type bi, .. scope }; + pure (mkFVar idx) + +def mkLambda (xs : Array Expr) (b : Expr) : Elab Expr := +do lctx ← localContext; pure $ lctx.mkLambda xs b + +def mkForall (xs : Array Expr) (b : Expr) : Elab Expr := +do lctx ← localContext; pure $ lctx.mkForall xs b + +def anonymousInstNamePrefix := `_inst + +def mkAnonymousInstName : Elab Name := +do scope ← getScope; + let n := anonymousInstNamePrefix.appendIndexAfter scope.nextInstIdx; + modifyScope $ fun scope => { nextInstIdx := scope.nextInstIdx + 1, .. scope }; + pure n + +def rootNamespace := `_root_ + +def removeRoot (n : Name) : Name := +n.replacePrefix rootNamespace Name.anonymous + +def resolveNamespaceUsingScopes (env : Environment) (n : Name) : List ElabScope → Option Name +| [] => none +| { ns := ns, .. } :: scopes => if isNamespace env (ns ++ n) then some (ns ++ n) else resolveNamespaceUsingScopes scopes + +def resolveNamespaceUsingOpenDecls (env : Environment) (n : Name) : List OpenDecl → Option Name +| [] => none +| OpenDecl.simple ns [] :: ds => if isNamespace env (ns ++ n) then some (ns ++ n) else resolveNamespaceUsingOpenDecls ds +| _ :: ds => resolveNamespaceUsingOpenDecls ds + +/- +Given a name `n` try to find namespace it refers to. The resolution procedure works as follows +1- If `n` is the extact name of an existing namespace, then return `n` +2- If `n` is in the scope of `namespace` commands declaring namespace headers `h_1`, ..., `h_n`, + then return `h_1 ++ ... ++ h_i ++ n` if it is the name of an existing namespace. We search "backwards". +3- Finally, for each command `open N`, return `N ++ n` if it is the name of an existing namespace. + We search "backwards" again. That is, we try the most recent `open` command first. + We only consider simple `open` commands. +-/ +def resolveNamespace (n : Name) : Elab Name := +do s ← get; + if isNamespace s.env n then pure n + else match resolveNamespaceUsingScopes s.env n s.scopes with + | some n => pure n + | none => do + openDecls ← getOpenDecls; + match resolveNamespaceUsingOpenDecls s.env n openDecls with + | some n => pure n + | none => throw (ElabException.other ("unknown namespace '" ++ toString n ++ "'")) + +@[inline] def withNewScope {α} (x : Elab α) : Elab α := +do modify $ fun s => { scopes := s.scopes.head! :: s.scopes, .. s }; + a ← x; + modify $ fun s => { scopes := s.scopes.tail!, .. s}; + pure a + +@[inline] def withInPattern {α} (x : Elab α) : Elab α := +withNewScope $ do + modifyScope $ fun scope => { inPattern := true, .. scope }; + x + +def inPattern : Elab Bool := +do scope ← getScope; pure $ scope.inPattern + +/- Remark: in an ideal world where performance doesn't matter, we would define `Elab` as + ``` + ExceptT ElabException (StateT ElabException IO) + ``` + and we would not need unsafe features for implementing `runIO`. + We say `Elab` is "morally" built on top of `IO`. -/ +unsafe def runIOUnsafe {α : Type} (x : IO α) : Elab α := +match unsafeIO x with +| Except.ok a => pure a +| Except.error e => throw (ElabException.io e) + +@[implementedBy runIOUnsafe] +constant runIO {α : Type} (x : IO α) : Elab α := arbitrary _ + +end Elab + +end Lean diff --git a/stage0/src/Init/Lean/Elaborator/Command.lean b/stage0/src/Init/Lean/Elaborator/Command.lean new file mode 100644 index 0000000000..645ca27b99 --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator/Command.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Elaborator.Alias +import Init.Lean.Elaborator.Basic +import Init.Lean.Elaborator.ResolveName +import Init.Lean.Elaborator.Term + +namespace Lean +namespace Elab + +private def addScopes (cmd : String) (updateNamespace : Bool) : Name → List ElabScope → List ElabScope +| Name.anonymous, scopes => scopes +| Name.str p h _, scopes => + let scopes := addScopes p scopes; + let ns := scopes.head!.ns; + let ns := if updateNamespace then mkNameStr ns h else ns; + { cmd := cmd, header := h, ns := ns } :: scopes +| _, _ => [] -- unreachable + +@[builtinCommandElab «namespace»] def elabNamespace : CommandElab := +fun n => do + let header := n.getIdAt 1; + modify $ fun s => { scopes := addScopes "namespace" true header s.scopes, .. s }; + ns ← getNamespace; + modify $ fun s => { env := registerNamespace s.env ns, .. s } + +@[builtinCommandElab «section»] def elabSection : CommandElab := +fun n => do + let header := (n.getArg 1).getOptionalIdent; + ns ← getNamespace; + modify $ fun s => + match header with + | some header => { scopes := addScopes "section" false header s.scopes, .. s } + | none => { scopes := { cmd := "section", header := Name.anonymous, ns := ns } :: s.scopes, .. s } + +private def getNumEndScopes : Option Name → Nat +| none => 1 +| some n => n.getNumParts + +private def checkAnonymousScope : List ElabScope → Bool +| { header := Name.anonymous, .. } :: _ => true +| _ => false + +private def checkEndHeader : Name → List ElabScope → Bool +| Name.anonymous, _ => true +| Name.str p s _, { header := h, .. } :: scopes => h.eqStr s && checkEndHeader p scopes +| _, _ => false + +@[builtinCommandElab «end»] def elabEnd : CommandElab := +fun n => do + s ← get; + let header := (n.getArg 1).getOptionalIdent; + let num := getNumEndScopes header; + let scopes := s.scopes; + if num < scopes.length then + modify $ fun s => { scopes := s.scopes.drop num, .. s } + else do { + -- we keep "root" scope + modify $ fun s => { scopes := s.scopes.drop (s.scopes.length - 1), .. s }; + throw "invalid 'end', insufficient scopes" + }; + match header with + | none => unless (checkAnonymousScope scopes) $ throw "invalid 'end', name is missing" + | some header => unless (checkEndHeader header scopes) $ throw "invalid 'end', name mismatch" + +@[builtinCommandElab «export»] def elabExport : CommandElab := +fun n => do + -- `n` is of the form (Command.export "export" "(" (null *) ")") + let ns := n.getIdAt 1; + ns ← resolveNamespace ns; + currNs ← getNamespace; + when (ns == currNs) $ throw "invalid 'export', self export"; + env ← getEnv; + let ids := (n.getArg 3).getArgs; + aliases ← ids.foldlM (fun (aliases : List (Name × Name)) (idStx : Syntax) => do { + let id := idStx.getId; + let declName := ns ++ id; + if env.contains declName then + pure $ (currNs ++ id, declName) :: aliases + else do + logUnknownDecl idStx declName; + pure aliases + }) + []; + modify $ fun s => { env := aliases.foldl (fun env p => addAlias env p.1 p.2) s.env, .. s } + +def addOpenDecl (d : OpenDecl) : Elab Unit := +modifyScope $ fun scope => { openDecls := d :: scope.openDecls, .. scope } + +def elabOpenSimple (n : SyntaxNode) : Elab Unit := +let nss := n.getArg 0; +nss.mforArgs $ fun ns => do + ns ← resolveNamespace ns.getId; + addOpenDecl (OpenDecl.simple ns []) + +def elabOpenOnly (n : SyntaxNode) : Elab Unit := +do let ns := n.getIdAt 0; + ns ← resolveNamespace ns; + let ids := n.getArg 2; + ids.mforArgs $ fun idStx => do + let id := idStx.getId; + let declName := ns ++ id; + env ← getEnv; + if env.contains declName then + addOpenDecl (OpenDecl.explicit id declName) + else + logUnknownDecl idStx declName + +def elabOpenHiding (n : SyntaxNode) : Elab Unit := +do let ns := n.getIdAt 0; + ns ← resolveNamespace ns; + let idsStx := n.getArg 2; + env ← getEnv; + ids : List Name ← idsStx.mfoldArgs (fun idStx ids => do + let id := idStx.getId; + let declName := ns ++ id; + if env.contains declName then + pure (id::ids) + else do + logUnknownDecl idStx declName; + pure ids) + []; + addOpenDecl (OpenDecl.simple ns ids) + +def elabOpenRenaming (n : SyntaxNode) : Elab Unit := +do let ns := n.getIdAt 0; + ns ← resolveNamespace ns; + let rs := (n.getArg 2); + rs.mforSepArgs $ fun stx => do + let fromId := stx.getIdAt 0; + let toId := stx.getIdAt 2; + let declName := ns ++ fromId; + env ← getEnv; + if env.contains declName then + addOpenDecl (OpenDecl.explicit toId declName) + else + logUnknownDecl stx declName + +@[builtinCommandElab «open»] def elabOpen : CommandElab := +fun n => do + let body := (n.getArg 1).asNode; + let k := body.getKind; + if k == `Lean.Parser.Command.openSimple then + elabOpenSimple body + else if k == `Lean.Parser.Command.openOnly then + elabOpenOnly body + else if k == `Lean.Parser.Command.openHiding then + elabOpenHiding body + else + elabOpenRenaming body + +def addUniverse (idStx : Syntax) : Elab Unit := +do let id := idStx.getId; + univs ← getUniverses; + if univs.elem id then + logError idStx ("a universe named '" ++ toString id ++ "' has already been declared in this Scope") + else + modifyScope $ fun scope => { univs := id :: scope.univs, .. scope } + +@[builtinCommandElab «universe»] def elabUniverse : CommandElab := +fun n => do + addUniverse (n.getArg 1) + +@[builtinCommandElab «universes»] def elabUniverses : CommandElab := +fun n => do + let idsStx := n.getArg 1; + idsStx.mforArgs addUniverse + +@[builtinCommandElab «init_quot»] def elabInitQuot : CommandElab := +fun _ => do + env ← getEnv; + match env.addDecl Declaration.quotDecl with + | Except.ok env => setEnv env + | Except.error ex => logElabException (ElabException.kernel ex) + +@[builtinCommandElab «variable»] def elabVariable : CommandElab := +fun n => do + runIO (IO.println n.val); + pure () + +@[builtinCommandElab «resolve_name»] def elabResolveName : CommandElab := +fun n => do + let id := n.getIdAt 1; + resolvedIds ← resolveName id; + pos ← getPosition; + runIO (IO.println (toString pos ++ " " ++ toString resolvedIds)); + pure () + +@[builtinCommandElab «preterm»] def elabPreTerm : CommandElab := +fun n => do + let s := n.getArg 1; + runIO (IO.println s); + pre ← toPreTerm (s.lift Expr); + runIO (IO.println pre.dbgToString); + pure () + +@[builtinCommandElab «elab»] def elabElab : CommandElab := +fun n => do + let s := n.getArg 1; + r ← elabTerm (s.lift Expr); + match r with + | Syntax.other e => runIO (IO.println e.dbgToString) + | other => do + runIO (IO.println other); + throw "failed to elaborate syntax" + +/- We just ignore Lean3 notation declaration commands. -/ +@[builtinCommandElab «mixfix»] def elabMixfix : CommandElab := fun _ => pure () +@[builtinCommandElab «reserve»] def elabReserve : CommandElab := fun _ => pure () +@[builtinCommandElab «notation»] def elabNotation : CommandElab := fun _ => pure () + +end Elab +end Lean diff --git a/stage0/src/Init/Lean/Elaborator/ElabStrategyAttrs.lean b/stage0/src/Init/Lean/Elaborator/ElabStrategyAttrs.lean new file mode 100644 index 0000000000..12709cf1d9 --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator/ElabStrategyAttrs.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes + +namespace Lean +/- +Elaborator strategies available in the Lean3 elaborator. +We want to support a more general approach, but we need to provide +the strategy selection attributes while we rely on the Lean3 elaborator. +-/ +inductive ElaboratorStrategy +| simple | withExpectedType | asEliminator + +instance ElaboratorStrategy.inhabited : Inhabited ElaboratorStrategy := +⟨ElaboratorStrategy.withExpectedType⟩ + +def mkElaboratorStrategyAttrs : IO (EnumAttributes ElaboratorStrategy) := +registerEnumAttributes `elaboratorStrategy + [(`elabWithExpectedType, "instructs elaborator that the arguments of the function application (f ...) should be elaborated using information about the expected type", ElaboratorStrategy.withExpectedType), + (`elabSimple, "instructs elaborator that the arguments of the function application (f ...) should be elaborated from left to right, and without propagating information from the expected type to its arguments", ElaboratorStrategy.simple), + (`elabAsEliminator, "instructs elaborator that the arguments of the function application (f ...) should be elaborated as f were an eliminator", ElaboratorStrategy.asEliminator)] + +@[init mkElaboratorStrategyAttrs] +constant elaboratorStrategyAttrs : EnumAttributes ElaboratorStrategy := arbitrary _ + +@[export lean_get_elaborator_strategy] +def getElaboratorStrategy (env : Environment) (n : Name) : Option ElaboratorStrategy := +elaboratorStrategyAttrs.getValue env n + +end Lean diff --git a/stage0/src/Init/Lean/Elaborator/PreTerm.lean b/stage0/src/Init/Lean/Elaborator/PreTerm.lean new file mode 100644 index 0000000000..30740b66a3 --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator/PreTerm.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Elaborator.Basic + +namespace Lean + +abbrev PreTerm := Expr + +@[extern "lean_old_elaborate"] +constant oldElaborateAux : Environment → Options → MetavarContext → LocalContext → PreTerm → Except (Option Position × Format) (Environment × MetavarContext × Expr) := arbitrary _ + +abbrev PreTermElab := SyntaxNode Expr → Elab PreTerm + +abbrev PreTermElabTable : Type := HashMap SyntaxNodeKind PreTermElab + +def mkBuiltinPreTermElabTable : IO (IO.Ref PreTermElabTable) := IO.mkRef {} + +@[init mkBuiltinPreTermElabTable] +constant builtinPreTermElabTable : IO.Ref PreTermElabTable := arbitrary _ + +def addBuiltinPreTermElab (k : SyntaxNodeKind) (declName : Name) (elab : PreTermElab) : IO Unit := +do m ← builtinPreTermElabTable.get; + when (m.contains k) $ + throw (IO.userError ("invalid builtin term elaborator, elaborator for '" ++ toString k ++ "' has already been defined")); + builtinPreTermElabTable.modify $ fun m => m.insert k elab + +def declareBuiltinPreTermElab (env : Environment) (kind : SyntaxNodeKind) (declName : Name) : IO Environment := +declareBuiltinElab env `Lean.addBuiltinPreTermElab kind declName + +@[init] def registerBuiltinPreTermElabAttr : IO Unit := +registerAttribute { + name := `builtinPreTermElab, + descr := "Builtin preterm conversion elaborator, we use it to interface with the Lean3 elaborator", + add := fun env declName arg persistent => do { + unless persistent $ throw (IO.userError ("invalid attribute 'builtinPreTermElab', must be persistent")); + kind ← syntaxNodeKindOfAttrParam env `Lean.Parser.Term arg; + match env.find declName with + | none => throw "unknown declaration" + | some decl => + match decl.type with + | Expr.const `Lean.PreTermElab _ _ => declareBuiltinPreTermElab env kind declName + | _ => throw (IO.userError ("unexpected preterm elaborator type at '" ++ toString declName ++ "' `PreTermElab` expected")) + }, + applicationTime := AttributeApplicationTime.afterCompilation +} + +def Expr.mkAnnotation (ann : Name) (e : Expr) := +mkMData (MData.empty.setName `annotation ann) e + +def mkAsIs (e : Expr) : PreTerm := +e.mkAnnotation `as_is + +def mkAsPattern (id : Name) (e : PreTerm) : PreTerm := +(mkApp (mkFVar id) e).mkAnnotation `as_pattern + +def mkPreTypeAscription (p : PreTerm) (expectedType : Expr) : PreTerm := +mkApp (mkApp (mkConst `typedExpr []) expectedType) p + +def mkPreTypeAscriptionIfSome (p : PreTerm) (expectedType : Option Expr) : PreTerm := +match expectedType with +| none => p +| some expectedType => mkPreTypeAscription p expectedType + +namespace Elab + +partial def toLevel : Syntax Expr → Elab Level +| stx => do + match stx.getKind with + | `Lean.Parser.Level.paren => toLevel $ stx.getArg 1 + | `Lean.Parser.Level.max => do + let args := (stx.getArg 1).getArgs; + first ← toLevel (args.get! 0); + args.foldlFromM (fun r arg => mkLevelMax r <$> toLevel arg) first 1 + | `Lean.Parser.Level.imax => do + let args := (stx.getArg 1).getArgs; + first ← toLevel (args.get! 0); + args.foldlFromM (fun r arg => mkLevelIMax r <$> toLevel arg) first 1 + | `Lean.Parser.Level.hole => pure $ mkLevelMVar Name.anonymous + | `Lean.Parser.Level.num => pure $ (stx.getArg 0).toNat.toLevel + | `Lean.Parser.Level.ident => do + let id := stx.getIdAt 0; + univs ← getUniverses; + if univs.elem id then pure $ mkLevelParam id + else do + logError stx ("unknown universe variable '" ++ toString id ++ "'"); + pure $ mkLevelMVar Name.anonymous + | `Lean.Parser.Level.addLit => do + level ← toLevel $ stx.getArg 0; + let k := (stx.getArg 2).toNat; + pure $ level.addOffset k + | other => throw "unexpected universe level syntax" + +private def setPos (stx : Syntax Expr) (p : PreTerm) : Elab PreTerm := +if stx.isOfKind `Lean.Parser.Term.app then pure p +else do + cfg ← read; + match stx.getPos with + | none => pure p + | some pos => + let pos := cfg.fileMap.toPosition pos; + pure $ mkMData ((MData.empty.setNat `column pos.column).setNat `row pos.line) p + +def toPreTerm (stx : Syntax Expr) : Elab PreTerm := +stx.ifNode + (fun n => do + s ← get; + table ← runIO builtinPreTermElabTable.get; + let k := n.getKind; + match table.find k with + | some fn => fn n >>= setPos stx + | none => logErrorAndThrow stx ("`toPreTerm` failed, no support for syntax '" ++ toString k ++ "'")) + (fun _ => throw "`toPreTerm` failed, unexpected syntax") + +private def mkHoleFor (stx : Syntax Expr) : Elab PreTerm := +setPos stx (mkMVar Name.anonymous) + +@[builtinPreTermElab «type»] def convertType : PreTermElab := +fun _ => pure $ mkSort levelOne + +@[builtinPreTermElab «sort»] def convertSort : PreTermElab := +fun _ => pure $ mkSort levelZero + +@[builtinPreTermElab «prop»] def convertProp : PreTermElab := +fun _ => pure $ mkSort levelZero + +@[builtinPreTermElab «sortApp»] def convertSortApp : PreTermElab := +fun n => do + let sort := n.getArg 0; + level ← toLevel $ n.getArg 1; + if sort.isOfKind `Lean.Parser.Term.type then + pure $ mkSort $ mkLevelSucc level + else + pure $ mkSort level + +-- This file will be deleted in the future +private def mkLocalAux (decl : LocalDecl) : PreTerm := +panic! "to be deleted" + +private def processBinder (b : Syntax Expr) : Elab (Array PreTerm) := +match b.getKind with +| `Lean.Parser.Term.simpleBinder => do + let args := (b.getArg 0).getArgs; + args.mapM $ fun arg => do + let id := arg.getId; + hole ← mkHoleFor arg; + -- decl ← mkLocalDecl id hole; -- HACK: this file will be deleted + -- pure (mkLocal decl) + mkLocalDecl id hole +| `Lean.Parser.Term.explicitBinder => + let ids := (b.getArg 1).getArgs; + let optType := b.getArg 2; + let optDef := b.getArg 3; + ids.mapM $ fun idStx => do + let id := idStx.getId; + type ← if optType.getNumArgs == 0 then mkHoleFor idStx else toPreTerm (optType.getArg 1); + type ← if optDef.getNumArgs == 0 then pure type else + let defInfo := optDef.getArg 0; + match defInfo.getKind with + | `Lean.Parser.Term.binderDefault => do + defVal ← toPreTerm (defInfo.getArg 1); + pure $ mkApp (mkApp (mkConst `optParam []) type) defVal + | `Lean.Parser.Term.binderTactic => logErrorAndThrow optDef "old elaborator does not support tactics in parameters" + | _ => throw "unknown binder default value annotation"; + -- decl ← mkLocalDecl id type; -- HACK: this file will be deleted + -- pure (mkLocal decl) + mkLocalDecl id type +| `Lean.Parser.Term.implicitBinder => do runIO (IO.println $ ">> implict " ++ (toString b)); pure #[] +| `Lean.Parser.Term.instBinder => do runIO (IO.println $ ">> inst " ++ (toString b)); pure #[] +| _ => throw "unknown binder kind" + +private def processBinders (bs : Array (Syntax Expr)) : Elab (Array PreTerm) := +bs.foldlM (fun r s => do xs ← processBinder s; pure (r ++ xs)) #[] + +@[builtinPreTermElab «forall»] def convertForall : PreTermElab := +fun n => do + let binders := n.getArg 1; + let body := n.getArg 3; + withNewScope $ do + xs ← processBinders binders.getArgs; + body ← toPreTerm body; + mkForall xs body + +@[builtinPreTermElab «hole»] def convertHole : PreTermElab := +fun _ => pure $ mkMVar Name.anonymous + +@[builtinPreTermElab «sorry»] def convertSorry : PreTermElab := +fun _ => pure $ mkApp (mkConst `sorryAx []) (mkMVar Name.anonymous) + +@[builtinPreTermElab «id»] def convertId : PreTermElab := +fun n => do + let id := n.getIdAt 0; + -- TODO add support for `explicitUniv` and `namedPattern` + lctx ← localContext; + match lctx.findFromUserName id with + | some decl => pure $ mkLocalAux decl + | none => + -- TODO global name resolution + logErrorAndThrow n.val ("unknown identifier '" ++ toString id ++ "'") + +def oldElaborate (stx : Syntax Expr) (expectedType : Option Expr := none) : Elab Expr := +do p ← toPreTerm stx; + scope ← getScope; + s ← get; + match oldElaborateAux s.env scope.options s.mctx scope.lctx (mkPreTypeAscriptionIfSome p expectedType) with + | Except.error (some pos, fmt) => do + ctx ← read; + logMessage { fileName := ctx.fileName, pos := pos, data := MessageData.ofFormat fmt }; + throw ElabException.silent + | Except.error (none, fmt) => logErrorAndThrow stx (fmt.pretty scope.options) + | Except.ok (env, mctx, e) => do + modify $ fun s => { env := env, mctx := mctx, .. s }; + pure e + +end Elab +end Lean diff --git a/stage0/src/Init/Lean/Elaborator/ResolveName.lean b/stage0/src/Init/Lean/Elaborator/ResolveName.lean new file mode 100644 index 0000000000..428c8d659c --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator/ResolveName.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Modifiers +import Init.Lean.Elaborator.Alias +import Init.Lean.Elaborator.Basic + +namespace Lean +namespace Elab + +/- Check whether `ns ++ id` is a valid namepace name and/or there are aliases names `ns ++ id`. -/ +private def resolveQualifiedName (env : Environment) (ns : Name) (id : Name) : List Name := +let resolvedId := ns ++ id; +let resolvedIds := getAliases env resolvedId; +if env.contains resolvedId && (!id.isAtomic || !isProtected env resolvedId) then resolvedId :: resolvedIds +else resolvedIds + +/- Check surrounding namespaces -/ +private def resolveUsingNamespace (env : Environment) (id : Name) : Name → List Name +| ns@(Name.str p _ _) => + match resolveQualifiedName env ns id with + | [] => resolveUsingNamespace p + | resolvedIds => resolvedIds +| _ => [] + +/- Check exact name -/ +private def resolveExact (env : Environment) (id : Name) : Option Name := +if id.isAtomic then none +else + let resolvedId := id.replacePrefix rootNamespace Name.anonymous; + if env.contains resolvedId then some resolvedId else none + +/- Check open namespaces -/ +private def resolveOpenDecls (env : Environment) (id : Name) : List OpenDecl → List Name → List Name +| [], resolvedIds => resolvedIds +| OpenDecl.simple ns exs :: openDecls, resolvedIds => + if exs.elem id then resolveOpenDecls openDecls resolvedIds + else + let newResolvedIds := resolveQualifiedName env ns id; + resolveOpenDecls openDecls (newResolvedIds ++ resolvedIds) +| OpenDecl.explicit openedId resolvedId :: openDecls, resolvedIds => + let resolvedIds := if id == openedId then resolvedId :: resolvedIds else resolvedIds; + resolveOpenDecls openDecls resolvedIds + +private def resolveNameAux (env : Environment) (ns : Name) (openDecls : List OpenDecl) : Name → Nat → List (Nat × Name) +| id@(Name.str p _ _), projSize => + match resolveUsingNamespace env id ns with + | resolvedIds@(_ :: _) => resolvedIds.eraseDups.map $ fun id => (projSize, id) + | [] => + match resolveExact env id with + | some newId => [(projSize, newId)] + | none => + let resolvedIds := if env.contains id then [id] else []; + let resolvedIds := resolveOpenDecls env id openDecls resolvedIds; + let resolvedIds := getAliases env id ++ resolvedIds; + match resolvedIds with + | resolvedIds@(_ :: _) => resolvedIds.eraseDups.map $ fun id => (projSize, id) + | [] => resolveNameAux p (projSize + 1) +| _, _ => [] + +def resolveName (id : Name) : Elab (List (Nat × Name)) := +do env ← getEnv; + ns ← getNamespace; + openDecls ← getOpenDecls; + pure $ resolveNameAux env ns openDecls id 0 + +private partial def preresolveNamesAux {α} (env : Environment) (ns : Name) (openDecls : List OpenDecl) : Syntax α → Syntax α +| Syntax.node k args => Syntax.node k (args.map preresolveNamesAux) +| Syntax.ident info rawVal val _ => Syntax.ident info rawVal val (resolveNameAux env ns openDecls val 0) +| stx => stx + +def preresolveNames {α} (stx : Syntax α) : Elab (Syntax α) := +do env ← getEnv; + ns ← getNamespace; + openDecls ← getOpenDecls; + pure $ preresolveNamesAux env ns openDecls stx + +end Elab +end Lean diff --git a/stage0/src/Init/Lean/Elaborator/Term.lean b/stage0/src/Init/Lean/Elaborator/Term.lean new file mode 100644 index 0000000000..305dddac03 --- /dev/null +++ b/stage0/src/Init/Lean/Elaborator/Term.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Elaborator.Alias +import Init.Lean.Elaborator.Basic +import Init.Lean.Elaborator.PreTerm + +namespace Lean +namespace Elab + +partial def elabTermAux : Syntax Expr → Option Expr → Bool → Elab (Syntax Expr) +| stx, expectedType, expanding => stx.ifNode + (fun n => do + s ← get; + let tables := termElabAttribute.ext.getState s.env; + let k := n.getKind; + match tables.find k with + | some elab => do + newStx ← elab n expectedType; + match newStx with + | Syntax.other _ => pure newStx + | _ => elabTermAux newStx expectedType expanding + | none => do + -- recursively expand syntax + let k := n.getKind; + args ← n.getArgs.mapM $ fun arg => elabTermAux arg none true; + let newStx := Syntax.node k args; + -- if it was already expanding just return new node, otherwise invoke old elaborator + if expanding then + pure newStx + else + Syntax.other <$> oldElaborate newStx expectedType) + (fun _ => + if expanding then pure stx + else match stx with + | Syntax.other e => pure stx + | _ => throw "term elaborator failed, unexpected syntax") + +def elabTerm (stx : Syntax Expr) (expectedType : Option Expr := none) : Elab (Syntax Expr) := +elabTermAux stx expectedType false + +open Lean.Parser + +@[builtinTermElab «listLit»] def elabListLit : TermElab := +fun stx _ => do + let openBkt := stx.getArg 0; + let args := stx.getArg 1; + let closeBkt := stx.getArg 2; + let consId := mkIdentFrom openBkt `List.cons; + let nilId := mkIdentFrom closeBkt `List.nil; + pure $ args.foldSepArgs (fun arg r => mkAppStx consId [arg, r]) nilId + +def mkExplicitBinder {α} (n : Syntax α) (type : Syntax α) : Syntax α := +mkNode `Lean.Parser.Term.explicitBinder [mkAtom "(", mkNullNode [n], mkNullNode [mkAtom ":", type], mkNullNode [], mkAtom ")"] + +@[builtinTermElab arrow] def elabArrow : TermElab := +fun stx _ => do + n ← mkFreshName; + let id := mkIdentFrom stx.val n; + let dom := stx.getArg 0; + let rng := stx.getArg 2; + pure $ mkNode `Lean.Parser.Term.forall [mkAtom "forall", mkNullNode [mkExplicitBinder id dom], mkAtom ",", rng] + +end Elab +end Lean diff --git a/stage0/src/Init/Lean/Environment.lean b/stage0/src/Init/Lean/Environment.lean new file mode 100644 index 0000000000..8cbf0d64eb --- /dev/null +++ b/stage0/src/Init/Lean/Environment.lean @@ -0,0 +1,592 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.System.IO +import Init.Util +import Init.Data.ByteArray +import Init.Lean.Declaration +import Init.Lean.SMap +import Init.Lean.Path +import Init.Lean.LocalContext + +namespace Lean +/- Opaque environment extension state. It is essentially the Lean version of a C `void *` + TODO: mark opaque -/ +def EnvExtensionState : Type := NonScalar + +instance EnvExtensionState.inhabited : Inhabited EnvExtensionState := inferInstanceAs (Inhabited NonScalar) + +/- TODO: mark opaque. -/ +def ModuleIdx := Nat + +instance ModuleIdx.inhabited : Inhabited ModuleIdx := inferInstanceAs (Inhabited Nat) + +abbrev ConstMap := SMap Name ConstantInfo + +structure Import := +(module : Name) +(runtimeOnly : Bool := false) + +instance : HasToString Import := +⟨fun imp => toString imp.module ++ if imp.runtimeOnly then " (runtime)" else ""⟩ + +/- Environment fields that are not used often. -/ +structure EnvironmentHeader := +(trustLevel : UInt32 := 0) +(quotInit : Bool := false) +(mainModule : Name := arbitrary _) +(imports : Array Import := #[]) + +/- TODO: mark opaque. -/ +structure Environment := +(const2ModIdx : HashMap Name ModuleIdx) +(constants : ConstMap) +(extensions : Array EnvExtensionState) +(header : EnvironmentHeader := {}) + +namespace Environment + +instance : Inhabited Environment := +⟨{ const2ModIdx := {}, constants := {}, extensions := #[] }⟩ + +def addAux (env : Environment) (cinfo : ConstantInfo) : Environment := +{ constants := env.constants.insert cinfo.name cinfo, .. env } + +@[export lean_environment_find] +def find (env : Environment) (n : Name) : Option ConstantInfo := +/- It is safe to use `find'` because we never overwrite imported declarations. -/ +env.constants.find' n + +def contains (env : Environment) (n : Name) : Bool := +env.constants.contains n + +def imports (env : Environment) : Array Import := +env.header.imports + +@[export lean_environment_set_main_module] +def setMainModule (env : Environment) (m : Name) : Environment := +{ header := { mainModule := m, .. env.header }, .. env } + +@[export lean_environment_main_module] +def mainModule (env : Environment) : Name := +env.header.mainModule + +@[export lean_environment_mark_quot_init] +private def markQuotInit (env : Environment) : Environment := +{ header := { quotInit := true, .. env.header } , .. env } + +@[export lean_environment_quot_init] +private def isQuotInit (env : Environment) : Bool := +env.header.quotInit + +@[export lean_environment_trust_level] +private def getTrustLevel (env : Environment) : UInt32 := +env.header.trustLevel + +def getModuleIdxFor (env : Environment) (c : Name) : Option ModuleIdx := +env.const2ModIdx.find c + +def isConstructor (env : Environment) (c : Name) : Bool := +match env.find c with +| ConstantInfo.ctorInfo _ => true +| _ => false + +end Environment + +inductive KernelException +| unknownConstant (env : Environment) (name : Name) +| alreadyDeclared (env : Environment) (name : Name) +| declTypeMismatch (env : Environment) (decl : Declaration) (givenType : Expr) +| declHasMVars (env : Environment) (name : Name) (expr : Expr) +| declHasFVars (env : Environment) (name : Name) (expr : Expr) +| funExpected (env : Environment) (lctx : LocalContext) (expr : Expr) +| typeExpected (env : Environment) (lctx : LocalContext) (expr : Expr) +| letTypeMismatch (env : Environment) (lctx : LocalContext) (name : Name) (givenType : Expr) (expectedType : Expr) +| exprTypeMismatch (env : Environment) (lctx : LocalContext) (expr : Expr) (expectedType : Expr) +| appTypeMismatch (env : Environment) (lctx : LocalContext) (app : Expr) (funType : Expr) (argType : Expr) +| invalidProj (env : Environment) (lctx : LocalContext) (proj : Expr) +| other (msg : String) + +namespace Environment + +/- Type check given declaration and add it to the environment -/ +@[extern "lean_add_decl"] +constant addDecl (env : Environment) (decl : @& Declaration) : Except KernelException Environment := arbitrary _ + +/- Compile the given declaration, it assumes the declaration has already been added to the environment using `addDecl`. -/ +@[extern "lean_compile_decl"] +constant compileDecl (env : Environment) (opt : @& Options) (decl : @& Declaration) : Except KernelException Environment := arbitrary _ + +def addAndCompile (env : Environment) (opt : Options) (decl : Declaration) : Except KernelException Environment := +do env ← addDecl env decl; + compileDecl env opt decl + +end Environment + +/- "Raw" environment extension. + TODO: mark opaque. -/ +structure EnvExtension (σ : Type) := +(idx : Nat) +(mkInitial : IO σ) +(stateInh : σ) + +namespace EnvExtension +unsafe def setStateUnsafe {σ : Type} (ext : EnvExtension σ) (env : Environment) (s : σ) : Environment := +{ extensions := env.extensions.set! ext.idx (unsafeCast s), .. env } + +@[implementedBy setStateUnsafe] +constant setState {σ : Type} (ext : EnvExtension σ) (env : Environment) (s : σ) : Environment := arbitrary _ + +unsafe def getStateUnsafe {σ : Type} (ext : EnvExtension σ) (env : Environment) : σ := +let s : EnvExtensionState := env.extensions.get! ext.idx; +@unsafeCast _ _ ⟨ext.stateInh⟩ s + +@[implementedBy getStateUnsafe] +constant getState {σ : Type} (ext : EnvExtension σ) (env : Environment) : σ := ext.stateInh + +@[inline] unsafe def modifyStateUnsafe {σ : Type} (ext : EnvExtension σ) (env : Environment) (f : σ → σ) : Environment := +{ extensions := env.extensions.modify ext.idx $ fun s => + let s : σ := (@unsafeCast _ _ ⟨ext.stateInh⟩ s); + let s : σ := f s; + unsafeCast s, + .. env } + +@[implementedBy modifyStateUnsafe] +constant modifyState {σ : Type} (ext : EnvExtension σ) (env : Environment) (f : σ → σ) : Environment := arbitrary _ + +end EnvExtension + +private def mkEnvExtensionsRef : IO (IO.Ref (Array (EnvExtension EnvExtensionState))) := +IO.mkRef #[] + +@[init mkEnvExtensionsRef] +private constant envExtensionsRef : IO.Ref (Array (EnvExtension EnvExtensionState)) := arbitrary _ + +instance EnvExtension.Inhabited (σ : Type) [Inhabited σ] : Inhabited (EnvExtension σ) := +⟨{ idx := 0, stateInh := arbitrary _, mkInitial := arbitrary _ }⟩ + +unsafe def registerEnvExtensionUnsafe {σ : Type} [Inhabited σ] (mkInitial : IO σ) : IO (EnvExtension σ) := +do initializing ← IO.initializing; + unless initializing $ throw (IO.userError ("failed to register environment, extensions can only be registered during initialization")); + exts ← envExtensionsRef.get; + let idx := exts.size; + let ext : EnvExtension σ := { + idx := idx, + mkInitial := mkInitial, + stateInh := arbitrary _ + }; + envExtensionsRef.modify (fun exts => exts.push (unsafeCast ext)); + pure ext + +/- Environment extensions can only be registered during initialization. + Reasons: + 1- Our implementation assumes the number of extensions does not change after an environment object is created. + 2- We do not use any synchronization primitive to access `envExtensionsRef`. -/ +@[implementedBy registerEnvExtensionUnsafe] +constant registerEnvExtension {σ : Type} [Inhabited σ] (mkInitial : IO σ) : IO (EnvExtension σ) := arbitrary _ + +private def mkInitialExtensionStates : IO (Array EnvExtensionState) := +do exts ← envExtensionsRef.get; exts.mapM $ fun ext => ext.mkInitial + +@[export lean_mk_empty_environment] +def mkEmptyEnvironment (trustLevel : UInt32 := 0) : IO Environment := +do initializing ← IO.initializing; + when initializing $ throw (IO.userError "environment objects cannot be created during initialization"); + exts ← mkInitialExtensionStates; + pure { const2ModIdx := {}, + constants := {}, + header := { trustLevel := trustLevel }, + extensions := exts } + +structure PersistentEnvExtensionState (α : Type) (σ : Type) := +(importedEntries : Array (Array α)) -- entries per imported module +(state : σ) + +/- An environment extension with support for storing/retrieving entries from a .olean file. + - α is the entry type. + - σ is the actual state. + + TODO: mark opaque. -/ +structure PersistentEnvExtension (α : Type) (σ : Type) extends EnvExtension (PersistentEnvExtensionState α σ) := +(name : Name) +(addImportedFn : Array (Array α) → IO σ) +(addEntryFn : σ → α → σ) +(exportEntriesFn : σ → Array α) +(statsFn : σ → Format) + +/- Opaque persistent environment extension entry. It is essentially a C `void *` + TODO: mark opaque -/ +def EnvExtensionEntry := NonScalar + +instance EnvExtensionEntry.inhabited : Inhabited EnvExtensionEntry := inferInstanceAs (Inhabited NonScalar) + +instance PersistentEnvExtensionState.inhabited {α σ} [Inhabited σ] : Inhabited (PersistentEnvExtensionState α σ) := +⟨{importedEntries := #[], state := arbitrary _ }⟩ + +instance PersistentEnvExtension.inhabited {α σ} [Inhabited σ] : Inhabited (PersistentEnvExtension α σ) := +⟨{ toEnvExtension := { idx := 0, stateInh := arbitrary _, mkInitial := arbitrary _ }, + name := arbitrary _, + addImportedFn := fun _ => arbitrary _, + addEntryFn := fun s _ => s, + exportEntriesFn := fun _ => #[], + statsFn := fun _ => Format.nil }⟩ + +namespace PersistentEnvExtension + +def getModuleEntries {α σ : Type} (ext : PersistentEnvExtension α σ) (env : Environment) (m : ModuleIdx) : Array α := +(ext.toEnvExtension.getState env).importedEntries.get! m + +def addEntry {α σ : Type} (ext : PersistentEnvExtension α σ) (env : Environment) (a : α) : Environment := +ext.toEnvExtension.modifyState env $ fun s => + let state := ext.addEntryFn s.state a; + { state := state, .. s } + +def getState {α σ : Type} (ext : PersistentEnvExtension α σ) (env : Environment) : σ := +(ext.toEnvExtension.getState env).state + +def setState {α σ : Type} (ext : PersistentEnvExtension α σ) (env : Environment) (s : σ) : Environment := +ext.toEnvExtension.modifyState env $ fun ps => { state := s, .. ps } + +def modifyState {α σ : Type} (ext : PersistentEnvExtension α σ) (env : Environment) (f : σ → σ) : Environment := +ext.toEnvExtension.modifyState env $ fun ps => { state := f (ps.state), .. ps } + +end PersistentEnvExtension + +private def mkPersistentEnvExtensionsRef : IO (IO.Ref (Array (PersistentEnvExtension EnvExtensionEntry EnvExtensionState))) := +IO.mkRef #[] + +@[init mkPersistentEnvExtensionsRef] +private constant persistentEnvExtensionsRef : IO.Ref (Array (PersistentEnvExtension EnvExtensionEntry EnvExtensionState)) := arbitrary _ + +structure PersistentEnvExtensionDescr (α σ : Type) := +(name : Name) +(addImportedFn : Array (Array α) → IO σ) +(addEntryFn : σ → α → σ) +(exportEntriesFn : σ → Array α) +(statsFn : σ → Format := fun _ => Format.nil) + +unsafe def registerPersistentEnvExtensionUnsafe {α σ : Type} [Inhabited σ] (descr : PersistentEnvExtensionDescr α σ) : IO (PersistentEnvExtension α σ) := +do pExts ← persistentEnvExtensionsRef.get; + when (pExts.any (fun ext => ext.name == descr.name)) $ throw (IO.userError ("invalid environment extension, '" ++ toString descr.name ++ "' has already been used")); + ext ← registerEnvExtension (do + state ← descr.addImportedFn #[]; + let s : PersistentEnvExtensionState α σ := { + importedEntries := #[], + state := state + }; + pure s); + let pExt : PersistentEnvExtension α σ := { + toEnvExtension := ext, + name := descr.name, + addImportedFn := descr.addImportedFn, + addEntryFn := descr.addEntryFn, + exportEntriesFn := descr.exportEntriesFn, + statsFn := descr.statsFn + }; + persistentEnvExtensionsRef.modify (fun pExts => pExts.push (unsafeCast pExt)); + pure pExt + +@[implementedBy registerPersistentEnvExtensionUnsafe] +constant registerPersistentEnvExtension {α σ : Type} [Inhabited σ] (descr : PersistentEnvExtensionDescr α σ) : IO (PersistentEnvExtension α σ) := arbitrary _ + +/- Simple PersistentEnvExtension that implements exportEntriesFn using a list of entries. -/ + +def SimplePersistentEnvExtension (α σ : Type) := PersistentEnvExtension α (List α × σ) + +@[specialize] def mkStateFromImportedEntries {α σ : Type} (addEntryFn : σ → α → σ) (initState : σ) (as : Array (Array α)) : σ := +as.foldl (fun r es => es.foldl (fun r e => addEntryFn r e) r) initState + +structure SimplePersistentEnvExtensionDescr (α σ : Type) := +(name : Name) +(addEntryFn : σ → α → σ) +(addImportedFn : Array (Array α) → σ) +(toArrayFn : List α → Array α := fun es => es.toArray) + +def registerSimplePersistentEnvExtension {α σ : Type} [Inhabited σ] (descr : SimplePersistentEnvExtensionDescr α σ) : IO (SimplePersistentEnvExtension α σ) := +registerPersistentEnvExtension { + name := descr.name, + addImportedFn := fun as => pure ([], descr.addImportedFn as), + addEntryFn := fun s e => match s with + | (entries, s) => (e::entries, descr.addEntryFn s e), + exportEntriesFn := fun s => descr.toArrayFn s.1.reverse, + statsFn := fun s => format "number of local entries: " ++ format s.1.length +} + +namespace SimplePersistentEnvExtension + +instance {α σ : Type} [Inhabited σ] : Inhabited (SimplePersistentEnvExtension α σ) := +inferInstanceAs (Inhabited (PersistentEnvExtension α (List α × σ))) + +def getEntries {α σ : Type} (ext : SimplePersistentEnvExtension α σ) (env : Environment) : List α := +(PersistentEnvExtension.getState ext env).1 + +def getState {α σ : Type} (ext : SimplePersistentEnvExtension α σ) (env : Environment) : σ := +(PersistentEnvExtension.getState ext env).2 + +def setState {α σ : Type} (ext : SimplePersistentEnvExtension α σ) (env : Environment) (s : σ) : Environment := +PersistentEnvExtension.modifyState ext env (fun ⟨entries, _⟩ => (entries, s)) + +def modifyState {α σ : Type} (ext : SimplePersistentEnvExtension α σ) (env : Environment) (f : σ → σ) : Environment := +PersistentEnvExtension.modifyState ext env (fun ⟨entries, s⟩ => (entries, f s)) + +end SimplePersistentEnvExtension + +/-- Environment extension for tagging declarations. + Declarations must only be tagged in the module where they were declared. -/ +def TagDeclarationExtension := SimplePersistentEnvExtension Name NameSet + +def mkTagDeclarationExtension (name : Name) : IO TagDeclarationExtension := +registerSimplePersistentEnvExtension { + name := name, + addImportedFn := fun as => {}, + addEntryFn := fun s n => s.insert n, + toArrayFn := fun es => es.toArray.qsort Name.quickLt +} + +namespace TagDeclarationExtension + +instance : Inhabited TagDeclarationExtension := +inferInstanceAs (Inhabited (SimplePersistentEnvExtension Name NameSet)) + +def tag (ext : TagDeclarationExtension) (env : Environment) (n : Name) : Environment := +ext.addEntry env n + +def isTagged (ext : TagDeclarationExtension) (env : Environment) (n : Name) : Bool := +match env.getModuleIdxFor n with +| some modIdx => (ext.getModuleEntries env modIdx).binSearchContains n Name.quickLt +| none => (ext.getState env).contains n + +end TagDeclarationExtension + +/- API for creating extensions in C++. + This API will eventually be deleted. -/ +def CPPExtensionState := NonScalar + +instance CPPExtensionState.inhabited : Inhabited CPPExtensionState := inferInstanceAs (Inhabited NonScalar) + +section +/- It is not safe to use "extract closed term" optimization in the following code because of `unsafeIO`. + If `compiler.extract_closed` is set to true, then the compiler will cache the result of + `exts ← envExtensionsRef.get` during initialization which is incorrect. -/ +set_option compiler.extract_closed false +@[export lean_register_extension] +unsafe def registerCPPExtension (initial : CPPExtensionState) : Option Nat := +(unsafeIO (do ext ← registerEnvExtension (pure initial); pure ext.idx)).toOption + +@[export lean_set_extension] +unsafe def setCPPExtensionState (env : Environment) (idx : Nat) (s : CPPExtensionState) : Option Environment := +(unsafeIO (do exts ← envExtensionsRef.get; pure $ (exts.get! idx).setState env s)).toOption + +@[export lean_get_extension] +unsafe def getCPPExtensionState (env : Environment) (idx : Nat) : Option CPPExtensionState := +(unsafeIO (do exts ← envExtensionsRef.get; pure $ (exts.get! idx).getState env)).toOption +end + +/- Legacy support for Modification objects -/ + +/- Opaque modification object. It is essentially a C `void *`. + In Lean 3, a .olean file is essentially a collection of modification objects. + This type represents the modification objects implemented in C++. + We will eventually delete this type as soon as we port the remaining Lean 3 + legacy code. + + TODO: mark opaque -/ +def Modification := NonScalar + +instance Modification.inhabited : Inhabited Modification := inferInstanceAs (Inhabited NonScalar) + +def regModListExtension : IO (EnvExtension (List Modification)) := +registerEnvExtension (pure []) + +@[init regModListExtension] +constant modListExtension : EnvExtension (List Modification) := arbitrary _ + +/- The C++ code uses this function to store the given modification object into the environment. -/ +@[export lean_environment_add_modification] +def addModification (env : Environment) (mod : Modification) : Environment := +modListExtension.modifyState env $ fun mods => mod :: mods + +/- mkModuleData invokes this function to convert a list of modification objects into + a serialized byte array. -/ +@[extern 2 "lean_serialize_modifications"] +constant serializeModifications : List Modification → IO ByteArray := arbitrary _ + +@[extern 3 "lean_perform_serialized_modifications"] +constant performModifications : Environment → ByteArray → IO Environment := arbitrary _ + +/- Content of a .olean file. + We use `compact.cpp` to generate the image of this object in disk. -/ +structure ModuleData := +(imports : Array Import) +(constants : Array ConstantInfo) +(entries : Array (Name × Array EnvExtensionEntry)) +(serialized : ByteArray) -- Legacy support: serialized modification objects + +instance ModuleData.inhabited : Inhabited ModuleData := +⟨{imports := arbitrary _, constants := arbitrary _, entries := arbitrary _, serialized := arbitrary _}⟩ + +@[extern 3 "lean_save_module_data"] +constant saveModuleData (fname : @& String) (m : ModuleData) : IO Unit := arbitrary _ +@[extern 2 "lean_read_module_data"] +constant readModuleData (fname : @& String) : IO ModuleData := arbitrary _ + +def mkModuleData (env : Environment) : IO ModuleData := +do pExts ← persistentEnvExtensionsRef.get; + let entries : Array (Name × Array EnvExtensionEntry) := pExts.size.fold + (fun i result => + let state := (pExts.get! i).getState env; + let exportEntriesFn := (pExts.get! i).exportEntriesFn; + let extName := (pExts.get! i).name; + result.push (extName, exportEntriesFn state)) + #[]; + bytes ← serializeModifications (modListExtension.getState env); + pure { + imports := env.header.imports, + constants := env.constants.foldStage2 (fun cs _ c => cs.push c) #[], + entries := entries, + serialized := bytes + } + +@[export lean_write_module] +def writeModule (env : Environment) (fname : String) : IO Unit := +do modData ← mkModuleData env; saveModuleData fname modData + +partial def importModulesAux : List Import → (NameSet × Array ModuleData) → IO (NameSet × Array ModuleData) +| [], r => pure r +| i::is, (s, mods) => + if i.runtimeOnly || s.contains i.module then + importModulesAux is (s, mods) + else do + let s := s.insert i.module; + mFile ← findOLean i.module; + mod ← readModuleData mFile; + (s, mods) ← importModulesAux mod.imports.toList (s, mods); + let mods := mods.push mod; + importModulesAux is (s, mods) + +private partial def getEntriesFor (mod : ModuleData) (extId : Name) : Nat → Array EnvExtensionState +| i => + if i < mod.entries.size then + let curr := mod.entries.get! i; + if curr.1 == extId then curr.2 else getEntriesFor (i+1) + else + #[] + +private def setImportedEntries (env : Environment) (mods : Array ModuleData) : IO Environment := +do pExtDescrs ← persistentEnvExtensionsRef.get; + pure $ mods.iterate env $ fun _ mod env => + pExtDescrs.iterate env $ fun _ extDescr env => + let entries := getEntriesFor mod extDescr.name 0; + extDescr.toEnvExtension.modifyState env $ fun s => + { importedEntries := s.importedEntries.push entries, + .. s } + +private def finalizePersistentExtensions (env : Environment) : IO Environment := +do pExtDescrs ← persistentEnvExtensionsRef.get; + pExtDescrs.iterateM env $ fun _ extDescr env => do + let s := extDescr.toEnvExtension.getState env; + newState ← extDescr.addImportedFn s.importedEntries; + pure $ extDescr.toEnvExtension.setState env { state := newState, .. s } + +@[export lean_import_modules] +def importModules (imports : List Import) (trustLevel : UInt32 := 0) : IO Environment := +do (_, mods) ← importModulesAux imports ({}, #[]); + let const2ModIdx := mods.iterate {} $ fun (modIdx) (mod : ModuleData) (m : HashMap Name ModuleIdx) => + mod.constants.iterate m $ fun _ cinfo m => + m.insert cinfo.name modIdx.val; + constants ← mods.iterateM SMap.empty $ fun _ (mod : ModuleData) (cs : ConstMap) => + mod.constants.iterateM cs $ fun _ cinfo cs => do { + when (cs.contains cinfo.name) $ throw (IO.userError ("import failed, environment already contains '" ++ toString cinfo.name ++ "'")); + pure $ cs.insert cinfo.name cinfo + }; + let constants := constants.switch; + exts ← mkInitialExtensionStates; + let env : Environment := { + const2ModIdx := const2ModIdx, + constants := constants, + extensions := exts, + header := { + quotInit := !imports.isEmpty, -- We assume `core.lean` initializes quotient module + trustLevel := trustLevel, + imports := imports.toArray + } + }; + env ← setImportedEntries env mods; + env ← finalizePersistentExtensions env; + env ← mods.iterateM env $ fun _ mod env => performModifications env mod.serialized; + pure env + +def regNamespacesExtension : IO (SimplePersistentEnvExtension Name NameSet) := +registerSimplePersistentEnvExtension { + name := `namespaces, + addImportedFn := fun as => mkStateFromImportedEntries NameSet.insert {} as, + addEntryFn := fun s n => s.insert n +} + +@[init regNamespacesExtension] +constant namespacesExt : SimplePersistentEnvExtension Name NameSet := arbitrary _ + +def registerNamespace (env : Environment) (n : Name) : Environment := +if (namespacesExt.getState env).contains n then env else namespacesExt.addEntry env n + +def isNamespace (env : Environment) (n : Name) : Bool := +(namespacesExt.getState env).contains n + +def getNamespaceSet (env : Environment) : NameSet := +namespacesExt.getState env + +namespace Environment + +private def isNamespaceName : Name → Bool +| Name.str Name.anonymous _ _ => true +| Name.str p _ _ => isNamespaceName p +| _ => false + +private def registerNamePrefixes : Environment → Name → Environment +| env, Name.str p _ _ => if isNamespaceName p then registerNamePrefixes (registerNamespace env p) p else env +| env, _ => env + +@[export lean_environment_add] +def add (env : Environment) (cinfo : ConstantInfo) : Environment := +let env := registerNamePrefixes env cinfo.name; +env.addAux cinfo + +@[export lean_display_stats] +def displayStats (env : Environment) : IO Unit := +do pExtDescrs ← persistentEnvExtensionsRef.get; + let numModules := ((pExtDescrs.get! 0).toEnvExtension.getState env).importedEntries.size; + IO.println ("direct imports: " ++ toString env.header.imports); + IO.println ("number of imported modules: " ++ toString numModules); + IO.println ("number of consts: " ++ toString env.constants.size); + IO.println ("number of imported consts: " ++ toString env.constants.stageSizes.1); + IO.println ("number of local consts: " ++ toString env.constants.stageSizes.2); + IO.println ("number of buckets for imported consts: " ++ toString env.constants.numBuckets); + IO.println ("trust level: " ++ toString env.header.trustLevel); + IO.println ("number of extensions: " ++ toString env.extensions.size); + pExtDescrs.forM $ fun extDescr => do { + IO.println ("extension '" ++ toString extDescr.name ++ "'"); + let s := extDescr.toEnvExtension.getState env; + let fmt := extDescr.statsFn s.state; + unless fmt.isNil (IO.println (" " ++ toString (Format.nest 2 (extDescr.statsFn s.state)))); + IO.println (" number of imported entries: " ++ toString (s.importedEntries.foldl (fun sum es => sum + es.size) 0)); + pure () + }; + pure () + +end Environment + +/- Helper functions for accessing environment -/ + +@[inline] +def matchConst {α : Type} (env : Environment) (e : Expr) (failK : Unit → α) (k : ConstantInfo → List Level → α) : α := +match e with +| Expr.const n lvls _ => + match env.find n with + | some cinfo => k cinfo lvls + | _ => failK () +| _ => failK () + +end Lean diff --git a/stage0/src/Init/Lean/EqnCompiler.lean b/stage0/src/Init/Lean/EqnCompiler.lean new file mode 100644 index 0000000000..6667e4f829 --- /dev/null +++ b/stage0/src/Init/Lean/EqnCompiler.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.EqnCompiler.MatchPattern diff --git a/stage0/src/Init/Lean/EqnCompiler/MatchPattern.lean b/stage0/src/Init/Lean/EqnCompiler/MatchPattern.lean new file mode 100644 index 0000000000..c89ffd702d --- /dev/null +++ b/stage0/src/Init/Lean/EqnCompiler/MatchPattern.lean @@ -0,0 +1,23 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes + +namespace Lean +namespace EqnCompiler + +def mkMatchPatternAttr : IO TagAttribute := +registerTagAttribute `matchPattern "mark that a definition can be used in a pattern (remark: the dependent pattern matching compiler will unfold the definition)" + +@[init mkMatchPatternAttr] +constant matchPatternAttr : TagAttribute := arbitrary _ + +@[export lean_has_match_pattern_attribute] +def hasMatchPatternAttribute (env : Environment) (n : Name) : Bool := +matchPatternAttr.hasTag env n + +end EqnCompiler +end Lean diff --git a/stage0/src/Init/Lean/Expr.lean b/stage0/src/Init/Lean/Expr.lean new file mode 100644 index 0000000000..2ed39a8803 --- /dev/null +++ b/stage0/src/Init/Lean/Expr.lean @@ -0,0 +1,775 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Level +import Init.Lean.KVMap +import Init.Data.HashMap +import Init.Data.HashSet +import Init.Data.PersistentHashMap +import Init.Data.PersistentHashSet + +namespace Lean + +inductive Literal +| natVal (val : Nat) +| strVal (val : String) + +instance Literal.inhabited : Inhabited Literal := ⟨Literal.natVal 0⟩ + +def Literal.hash : Literal → USize +| Literal.natVal v => hash v +| Literal.strVal v => hash v + +instance Literal.hashable : Hashable Literal := ⟨Literal.hash⟩ + +def Literal.beq : Literal → Literal → Bool +| Literal.natVal v₁, Literal.natVal v₂ => v₁ == v₂ +| Literal.strVal v₁, Literal.strVal v₂ => v₁ == v₂ +| _, _ => false + +instance Literal.hasBeq : HasBeq Literal := ⟨Literal.beq⟩ + +inductive BinderInfo +| default | implicit | strictImplicit | instImplicit | auxDecl + +def BinderInfo.hash : BinderInfo → USize +| BinderInfo.default => 947 +| BinderInfo.implicit => 1019 +| BinderInfo.strictImplicit => 1087 +| BinderInfo.instImplicit => 1153 +| BinderInfo.auxDecl => 1229 + +instance BinderInfo.hashable : Hashable BinderInfo := ⟨BinderInfo.hash⟩ + +def BinderInfo.isInstImplicit : BinderInfo → Bool +| BinderInfo.instImplicit => true +| _ => false + +def BinderInfo.isAuxDecl : BinderInfo → Bool +| BinderInfo.auxDecl => true +| _ => false + +protected def BinderInfo.beq : BinderInfo → BinderInfo → Bool +| BinderInfo.default, BinderInfo.default => true +| BinderInfo.implicit, BinderInfo.implicit => true +| BinderInfo.strictImplicit, BinderInfo.strictImplicit => true +| BinderInfo.instImplicit, BinderInfo.instImplicit => true +| BinderInfo.auxDecl, BinderInfo.auxDecl => true +| _, _ => false + +instance BinderInfo.hasBeq : HasBeq BinderInfo := ⟨BinderInfo.beq⟩ + +abbrev MData := KVMap +abbrev MData.empty : MData := {KVMap .} +instance MVData.hasEmptc : HasEmptyc MData := ⟨MData.empty⟩ + +/-- + Cached hash code, cached results, and other data for `Expr`. + hash : 32-bits + hasFVar : 1-bit + hasExprMVar : 1-bit + hasLevelMVar : 1-bit + hasLevelParam : 1-bit + nonDepLet : 1-bit + binderInfo : 3-bits + looseBVarRange : 24-bits -/ +def Expr.Data := UInt64 + +instance Expr.Data.inhabited : Inhabited Expr.Data := +inferInstanceAs (Inhabited UInt64) + +def Expr.Data.hash (c : Expr.Data) : USize := +c.toUInt32.toUSize + +instance Expr.Data.hasBeq : HasBeq Expr.Data := +⟨fun (a b : UInt64) => a == b⟩ + +def Expr.Data.looseBVarRange (c : Expr.Data) : UInt32 := +(c.shiftRight 40).toUInt32 + +def Expr.Data.hasFVar (c : Expr.Data) : Bool := +((c.shiftRight 32).land 1) == 1 + +def Expr.Data.hasExprMVar (c : Expr.Data) : Bool := +((c.shiftRight 33).land 1) == 1 + +def Expr.Data.hasLevelMVar (c : Expr.Data) : Bool := +((c.shiftRight 34).land 1) == 1 + +def Expr.Data.hasLevelParam (c : Expr.Data) : Bool := +((c.shiftRight 35).land 1) == 1 + +def Expr.Data.nonDepLet (c : Expr.Data) : Bool := +((c.shiftRight 36).land 1) == 1 + +@[extern c inline "(uint8_t)((#1 << 24) >> 61)"] +def Expr.Data.binderInfo (c : Expr.Data) : BinderInfo := +let bi := (c.shiftLeft 24).shiftRight 61; +if bi == 0 then BinderInfo.default +else if bi == 1 then BinderInfo.implicit +else if bi == 2 then BinderInfo.strictImplicit +else if bi == 3 then BinderInfo.instImplicit +else BinderInfo.auxDecl + +@[extern c inline "(uint64_t)#1"] +def BinderInfo.toUInt64 : BinderInfo → UInt64 +| BinderInfo.default => 0 +| BinderInfo.implicit => 1 +| BinderInfo.strictImplicit => 2 +| BinderInfo.instImplicit => 3 +| BinderInfo.auxDecl => 4 + +@[inline] private def Expr.mkDataCore + (h : USize) (looseBVarRange : Nat) + (hasFVar hasExprMVar hasLevelMVar hasLevelParam nonDepLet : Bool) (bi : BinderInfo) + : Expr.Data := +if looseBVarRange > Nat.pow 2 24 - 1 then panic! "bound variable index is too big" +else + let r : UInt64 := + h.toUInt32.toUInt64 + + hasFVar.toUInt64.shiftLeft 32 + + hasExprMVar.toUInt64.shiftLeft 33 + + hasLevelMVar.toUInt64.shiftLeft 34 + + hasLevelParam.toUInt64.shiftLeft 35 + + nonDepLet.toUInt64.shiftLeft 36 + + bi.toUInt64.shiftLeft 37 + + looseBVarRange.toUInt64.shiftLeft 40; + r + +def Expr.mkData (h : USize) (looseBVarRange : Nat := 0) (hasFVar hasExprMVar hasLevelMVar hasLevelParam : Bool := false) : Expr.Data := +Expr.mkDataCore h looseBVarRange hasFVar hasExprMVar hasLevelMVar hasLevelParam false BinderInfo.default + +def Expr.mkDataForBinder (h : USize) (looseBVarRange : Nat) (hasFVar hasExprMVar hasLevelMVar hasLevelParam : Bool) (bi : BinderInfo) : Expr.Data := +Expr.mkDataCore h looseBVarRange hasFVar hasExprMVar hasLevelMVar hasLevelParam false bi + +def Expr.mkDataForLet (h : USize) (looseBVarRange : Nat) (hasFVar hasExprMVar hasLevelMVar hasLevelParam nonDepLet : Bool) : Expr.Data := +Expr.mkDataCore h looseBVarRange hasFVar hasExprMVar hasLevelMVar hasLevelParam nonDepLet BinderInfo.default + +open Expr + +/- We use the `E` suffix (short for `Expr`) to avoid collision with keywords. + We considered using «...», but it is too inconvenient to use. -/ +inductive Expr +| bvar : Nat → Data → Expr -- bound variables +| fvar : Name → Data → Expr -- free variables +| mvar : Name → Data → Expr -- meta variables +| sort : Level → Data → Expr -- Sort +| const : Name → List Level → Data → Expr -- constants +| app : Expr → Expr → Data → Expr -- application +| lam : Name → Expr → Expr → Data → Expr -- lambda abstraction +| forallE : Name → Expr → Expr → Data → Expr -- (dependent) arrow +| letE : Name → Expr → Expr → Expr → Data → Expr -- let expressions +| lit : Literal → Data → Expr -- literals +| mdata : MData → Expr → Data → Expr -- metadata +| proj : Name → Nat → Expr → Data → Expr -- projection +-- IMPORTANT: the following constructor will be deleted +| localE : Name → Name → Expr → Data → Expr -- Lean2 legacy. TODO: delete + +namespace Expr + +instance : Inhabited Expr := +⟨sort (arbitrary _) (arbitrary _)⟩ + +@[inline] def data : Expr → Data +| bvar _ d => d +| fvar _ d => d +| mvar _ d => d +| sort _ d => d +| const _ _ d => d +| app _ _ d => d +| lam _ _ _ d => d +| forallE _ _ _ d => d +| letE _ _ _ _ d => d +| lit _ d => d +| mdata _ _ d => d +| proj _ _ _ d => d +| localE _ _ _ d => d + +def hash (e : Expr) : USize := +e.data.hash + +instance : Hashable Expr := ⟨Expr.hash⟩ + +def hasFVar (e : Expr) : Bool := +e.data.hasFVar + +def hasExprMVar (e : Expr) : Bool := +e.data.hasExprMVar + +def hasLevelMVar (e : Expr) : Bool := +e.data.hasLevelMVar + +def hasMVar (e : Expr) : Bool := +let d := e.data; +d.hasExprMVar || d.hasLevelMVar + +def hasLevelParam (e : Expr) : Bool := +e.data.hasLevelParam + +def looseBVarRange (e : Expr) : Nat := +e.data.looseBVarRange.toNat + +def binderInfo (e : Expr) : BinderInfo := +e.data.binderInfo + +@[export lean_expr_hash] def hashEx : Expr → USize := hash +@[export lean_expr_has_fvar] def hasFVarEx : Expr → Bool := hasFVar +@[export lean_expr_has_expr_mvar] def hasExprMVarEx : Expr → Bool := hasExprMVar +@[export lean_expr_has_level_mvar] def hasLevelMVarEx : Expr → Bool := hasLevelMVar +@[export lean_expr_has_mvar] def hasMVarEx : Expr → Bool := hasMVar +@[export lean_expr_has_level_param] def hasLevelParamEx : Expr → Bool := hasLevelParam +@[export lean_expr_loose_bvar_range] def looseBVarRangeEx (e : Expr) : UInt32 := e.data.looseBVarRange +@[export lean_expr_binder_info] def binderInfoEx : Expr → BinderInfo := binderInfo + +end Expr + +def mkLit (l : Literal) : Expr := +Expr.lit l $ mkData (mixHash 3 (hash l)) + +def mkNatLit (n : Nat) : Expr := +mkLit (Literal.natVal n) + +def mkStrLit (s : String) : Expr := +mkLit (Literal.strVal s) + +def mkConst (n : Name) (lvls : List Level := []) : Expr := +Expr.const n lvls $ mkData (mixHash 5 $ mixHash (hash n) (hash lvls)) 0 false false (lvls.any Level.hasMVar) (lvls.any Level.hasParam) + +def Literal.type : Literal → Expr +| Literal.natVal _ => mkConst `Nat +| Literal.strVal _ => mkConst `String + +@[export lean_lit_type] +def Literal.typeEx : Literal → Expr := Literal.type + +def mkBVar (idx : Nat) : Expr := +Expr.bvar idx $ mkData (mixHash 7 $ hash idx) (idx+1) + +def mkSort (lvl : Level) : Expr := +Expr.sort lvl $ mkData (mixHash 11 $ hash lvl) 0 false false lvl.hasMVar lvl.hasParam + +def mkFVar (fvarId : Name) : Expr := +Expr.fvar fvarId $ mkData (mixHash 13 $ hash fvarId) 0 true + +def mkMVar (fvarId : Name) : Expr := +Expr.mvar fvarId $ mkData (mixHash 17 $ hash fvarId) 0 false true + +def mkMData (d : MData) (e : Expr) : Expr := +Expr.mdata d e $ mkData (mixHash 19 $ hash e) e.looseBVarRange e.hasFVar e.hasExprMVar e.hasLevelMVar e.hasLevelParam + +def mkProj (s : Name) (i : Nat) (e : Expr) : Expr := +Expr.proj s i e $ mkData (mixHash 23 $ mixHash (hash s) $ mixHash (hash i) (hash e)) + e.looseBVarRange e.hasFVar e.hasExprMVar e.hasLevelMVar e.hasLevelParam + +def mkApp (f a : Expr) : Expr := +Expr.app f a $ mkData (mixHash 29 $ mixHash (hash f) (hash a)) + (Nat.max f.looseBVarRange a.looseBVarRange) + (f.hasFVar || a.hasFVar) + (f.hasExprMVar || a.hasExprMVar) + (f.hasLevelMVar || a.hasLevelMVar) + (f.hasLevelParam || a.hasLevelParam) + +def mkLambda (x : Name) (bi : BinderInfo) (t : Expr) (b : Expr) : Expr := +Expr.lam x t b $ mkDataForBinder (mixHash 31 $ mixHash (hash t) (hash b)) + (Nat.max t.looseBVarRange (b.looseBVarRange - 1)) + (t.hasFVar || b.hasFVar) + (t.hasExprMVar || b.hasExprMVar) + (t.hasLevelMVar || b.hasLevelMVar) + (t.hasLevelParam || b.hasLevelParam) + bi + +def mkForall (x : Name) (bi : BinderInfo) (t : Expr) (b : Expr) : Expr := +Expr.forallE x t b $ mkDataForBinder (mixHash 37 $ mixHash (hash t) (hash b)) + (Nat.max t.looseBVarRange (b.looseBVarRange - 1)) + (t.hasFVar || b.hasFVar) + (t.hasExprMVar || b.hasExprMVar) + (t.hasLevelMVar || b.hasLevelMVar) + (t.hasLevelParam || b.hasLevelParam) + bi + +def mkLet (x : Name) (t : Expr) (v : Expr) (b : Expr) (nonDep : Bool := false) : Expr := +Expr.letE x t v b $ mkDataForLet (mixHash 41 $ mixHash (hash t) $ mixHash (hash v) (hash b)) + (Nat.max (Nat.max t.looseBVarRange v.looseBVarRange) (b.looseBVarRange - 1)) + (t.hasFVar || v.hasFVar || b.hasFVar) + (t.hasExprMVar || v.hasExprMVar || b.hasExprMVar) + (t.hasLevelMVar || v.hasLevelMVar || b.hasLevelMVar) + (t.hasLevelParam || v.hasLevelParam || b.hasLevelParam) + nonDep + +def mkLocal (x u : Name) (t : Expr) (bi : BinderInfo) : Expr := +Expr.localE x u t $ mkDataForBinder (mixHash 43 $ hash t) t.looseBVarRange true t.hasExprMVar t.hasLevelMVar t.hasLevelParam bi + +@[export lean_expr_mk_bvar] def mkBVarEx : Nat → Expr := mkBVar +@[export lean_expr_mk_fvar] def mkFVarEx : Name → Expr := mkFVar +@[export lean_expr_mk_mvar] def mkMVarEx : Name → Expr := mkMVar +@[export lean_expr_mk_sort] def mkSortEx : Level → Expr := mkSort +@[export lean_expr_mk_const] def mkConstEx (c : Name) (lvls : List Level) : Expr := mkConst c lvls +@[export lean_expr_mk_app] def mkAppEx : Expr → Expr → Expr := mkApp +@[export lean_expr_mk_lambda] def mkLambdaEx (n : Name) (d b : Expr) (bi : BinderInfo) : Expr := mkLambda n bi d b +@[export lean_expr_mk_forall] def mkForallEx (n : Name) (d b : Expr) (bi : BinderInfo) : Expr := mkForall n bi d b +@[export lean_expr_mk_let] def mkLetEx (n : Name) (t v b : Expr) : Expr := mkLet n t v b +@[export lean_expr_mk_lit] def mkLitEx : Literal → Expr := mkLit +@[export lean_expr_mk_mdata] def mkMDataEx : MData → Expr → Expr := mkMData +@[export lean_expr_mk_proj] def mkProjEx : Name → Nat → Expr → Expr := mkProj +@[export lean_expr_mk_local] def mkLocalEx : Name → Name → Expr → BinderInfo → Expr := mkLocal + +def mkCApp (f : Name) (a : Expr) : Expr := +mkApp (mkConst f) a + +def mkAppN (f : Expr) (args : Array Expr) : Expr := +args.foldl mkApp f + +private partial def mkAppRangeAux (n : Nat) (args : Array Expr) : Nat → Expr → Expr +| i, e => if i < n then mkAppRangeAux (i+1) (mkApp e (args.get! i)) else e + +/-- `mkAppRange f i j #[a_1, ..., a_i, ..., a_j, ... ]` ==> the expression `f a_i ... a_{j-1}` -/ +def mkAppRange (f : Expr) (i j : Nat) (args : Array Expr) : Expr := +mkAppRangeAux j args i f + +def mkAppRev (fn : Expr) (revArgs : Array Expr) : Expr := +revArgs.foldr (fun a r => mkApp r a) fn + +namespace Expr +-- TODO: implement it in Lean +@[extern "lean_expr_dbg_to_string"] +constant dbgToString (e : @& Expr) : String := arbitrary String + +@[extern "lean_expr_quick_lt"] +constant quickLt (a : @& Expr) (b : @& Expr) : Bool := arbitrary _ + +@[extern "lean_expr_lt"] +constant lt (a : @& Expr) (b : @& Expr) : Bool := arbitrary _ + +/- Return true iff `a` and `b` are alpha equivalent. + Binder annotations are ignored. -/ +@[extern "lean_expr_eqv"] +constant eqv (a : @& Expr) (b : @& Expr) : Bool := arbitrary _ + +instance : HasBeq Expr := ⟨Expr.eqv⟩ + +/- Return true iff `a` and `b` are equal. + Binder names and annotations are taking into account. -/ +@[extern "lean_expr_equal"] +constant equal (a : @& Expr) (b : @& Expr) : Bool := arbitrary _ + +def isSort : Expr → Bool +| sort _ _ => true +| _ => false + +def isBVar : Expr → Bool +| bvar _ _ => true +| _ => false + +def isMVar : Expr → Bool +| mvar _ _ => true +| _ => false + +def isFVar : Expr → Bool +| fvar _ _ => true +| _ => false + +def isApp : Expr → Bool +| app _ _ _ => true +| _ => false + +def isProj : Expr → Bool +| proj _ _ _ _ => true +| _ => false + +def isConst : Expr → Bool +| const _ _ _ => true +| _ => false + +def isConstOf : Expr → Name → Bool +| const n _ _, m => n == m +| _, _ => false + +def isForall : Expr → Bool +| forallE _ _ _ _ => true +| _ => false + +def isLambda : Expr → Bool +| lam _ _ _ _ => true +| _ => false + +def isBinding : Expr → Bool +| lam _ _ _ _ => true +| forallE _ _ _ _ => true +| _ => false + +def isLet : Expr → Bool +| letE _ _ _ _ _ => true +| _ => false + +def isMData : Expr → Bool +| mdata _ _ _ => true +| _ => false + +def getAppFn : Expr → Expr +| app f a _ => getAppFn f +| e => e + +def getAppNumArgsAux : Expr → Nat → Nat +| app f a _, n => getAppNumArgsAux f (n+1) +| e, n => n + +def getAppNumArgs (e : Expr) : Nat := +getAppNumArgsAux e 0 + +private def getAppArgsAux : Expr → Array Expr → Nat → Array Expr +| app f a _, as, i => getAppArgsAux f (as.set! i a) (i-1) +| _, as, _ => as + +@[inline] def getAppArgs (e : Expr) : Array Expr := +let dummy := mkSort levelZero; +let nargs := e.getAppNumArgs; +getAppArgsAux e (mkArray nargs dummy) (nargs-1) + +private def getAppRevArgsAux : Expr → Array Expr → Array Expr +| app f a _, as => getAppRevArgsAux f (as.push a) +| _, as => as + +@[inline] def getAppRevArgs (e : Expr) : Array Expr := +getAppRevArgsAux e (Array.mkEmpty e.getAppNumArgs) + +@[specialize] def withAppAux {α} (k : Expr → Array Expr → α) : Expr → Array Expr → Nat → α +| app f a _, as, i => withAppAux f (as.set! i a) (i-1) +| f, as, i => k f as + +@[inline] def withApp {α} (e : Expr) (k : Expr → Array Expr → α) : α := +let dummy := mkSort levelZero; +let nargs := e.getAppNumArgs; +withAppAux k e (mkArray nargs dummy) (nargs-1) + +@[specialize] private def withAppRevAux {α} (k : Expr → Array Expr → α) : Expr → Array Expr → α +| app f a _, as => withAppRevAux f (as.push a) +| f, as => k f as + +@[inline] def withAppRev {α} (e : Expr) (k : Expr → Array Expr → α) : α := +withAppRevAux k e (Array.mkEmpty e.getAppNumArgs) + +def getRevArgD : Expr → Nat → Expr → Expr +| app f a _, 0, _ => a +| app f _ _, i+1, v => getRevArgD f i v +| _, _, v => v + +def getRevArg! : Expr → Nat → Expr +| app f a _, 0 => a +| app f _ _, i+1 => getRevArg! f i +| _, _ => panic! "invalid index" + +@[inline] def getArg! (e : Expr) (i : Nat) (n := e.getAppNumArgs) : Expr := +getRevArg! e (n - i - 1) + +@[inline] def getArgD (e : Expr) (i : Nat) (v₀ : Expr) (n := e.getAppNumArgs) : Expr := +getRevArgD e (n - i - 1) v₀ + +def isAppOf (e : Expr) (n : Name) : Bool := +match e.getAppFn with +| const c _ _ => c == n +| _ => false + +def isAppOfArity : Expr → Name → Nat → Bool +| const c _ _, n, 0 => c == n +| app f _ _, n, a+1 => isAppOfArity f n a +| _, _, _ => false + +def appFn! : Expr → Expr +| app f _ _ => f +| _ => panic! "application expected" + +def appArg! : Expr → Expr +| app _ a _ => a +| _ => panic! "application expected" + +def constName! : Expr → Name +| const n _ _ => n +| _ => panic! "constant expected" + +def constLevels! : Expr → List Level +| const _ ls _ => ls +| _ => panic! "constant expected" + +def bvarIdx! : Expr → Nat +| bvar idx _ => idx +| _ => panic! "bvar expected" + +def fvarId! : Expr → Name +| fvar n _ => n +| _ => panic! "fvar expected" + +def mvarId! : Expr → Name +| mvar n _ => n +| _ => panic! "mvar expected" + +def bindingName! : Expr → Name +| forallE n _ _ _ => n +| lam n _ _ _ => n +| _ => panic! "binding expected" + +def bindingDomain! : Expr → Expr +| forallE _ _ d _ => d +| lam _ _ d _ => d +| _ => panic! "binding expected" + +def bindingBody! : Expr → Expr +| forallE _ _ b _ => b +| lam _ _ b _ => b +| _ => panic! "binding expected" + +def letName! : Expr → Name +| letE n _ _ _ _ => n +| _ => panic! "let expression expected" + +def hasLooseBVars (e : Expr) : Bool := +e.looseBVarRange > 0 + +@[extern "lean_expr_has_loose_bvar"] +constant hasLooseBVar (e : @& Expr) (bvarIdx : @& Nat) : Bool := arbitrary _ + +/-- Instantiate the loose bound variables in `e` using `subst`. + That is, a loose `Expr.bvar i` is replaced with `subst[i]`. -/ +@[extern "lean_expr_instantiate"] +constant instantiate (e : @& Expr) (subst : @& Array Expr) : Expr := arbitrary _ + +@[extern "lean_expr_instantiate1"] +constant instantiate1 (e : @& Expr) (subst : @& Expr) : Expr := arbitrary _ + +/-- Similar to instantiate, but `Expr.bvar i` is replaced with `subst[subst.size - i - 1]` -/ +@[extern "lean_expr_instantiate_rev"] +constant instantiateRev (e : @& Expr) (subst : @& Array Expr) : Expr := arbitrary _ + +/-- Similar to `instantiate`, but consider only the variables `xs` in the range `[beginIdx, endIdx)`. + Function panics if `beginIdx <= endIdx <= xs.size` does not hold. -/ +@[extern "lean_expr_instantiate_range"] +constant instantiateRange (e : @& Expr) (beginIdx endIdx : @& Nat) (xs : Array Expr) : Expr := arbitrary _ + +/-- Similar to `instantiateRev`, but consider only the variables `xs` in the range `[beginIdx, endIdx)`. + Function panics if `beginIdx <= endIdx <= xs.size` does not hold. -/ +@[extern "lean_expr_instantiate_rev_range"] +constant instantiateRevRange (e : @& Expr) (beginIdx endIdx : @& Nat) (xs : Array Expr) : Expr := arbitrary _ + +/-- Replace free variables `xs` with loose bound variables. -/ +@[extern "lean_expr_abstract"] +constant abstract (e : @& Expr) (xs : @& Array Expr) : Expr := arbitrary _ + +/-- Similar to `abstract`, but consider only the first `min n xs.size` entries in `xs`. -/ +@[extern "lean_expr_abstract_range"] +constant abstractRange (e : @& Expr) (n : @& Nat) (xs : @& Array Expr) : Expr := arbitrary _ + +@[extern "lean_instantiate_lparams"] +constant instantiateLevelParams (e : Expr) (paramNames : List Name) (lvls : List Level) : Expr := arbitrary _ + +instance : HasToString Expr := +⟨Expr.dbgToString⟩ + +-- TODO: should not use dbgToString, but constructors. +instance : HasRepr Expr := +⟨Expr.dbgToString⟩ + +end Expr + +def mkCAppN (n : Name) (args : Array Expr) : Expr := +mkAppN (mkConst n) args + +def mkAppB (f a b : Expr) := +mkApp (mkApp f a) b + +def mkCAppB (n : Name) (a b : Expr) := +mkAppB (mkConst n) a b + +def mkDecIsTrue (pred proof : Expr) := +mkAppB (mkConst `Decidable.isTrue) pred proof + +def mkDecIsFalse (pred proof : Expr) := +mkAppB (mkConst `Decidable.isFalse) pred proof + +abbrev ExprMap (α : Type) := HashMap Expr α +abbrev PersistentExprMap (α : Type) := PHashMap Expr α +abbrev ExprSet := HashSet Expr +abbrev PersistentExprSet := PHashSet Expr +abbrev PExprSet := PersistentExprSet + +/- Auxiliary type for forcing `==` to be structural equality for `Expr` -/ +structure ExprStructEq := +(val : Expr) + +instance exprToExprStructEq : HasCoe Expr ExprStructEq := ⟨ExprStructEq.mk⟩ + +namespace ExprStructEq + +protected def beq : ExprStructEq → ExprStructEq → Bool +| ⟨e₁⟩, ⟨e₂⟩ => Expr.equal e₁ e₂ + +protected def hash : ExprStructEq → USize +| ⟨e⟩ => e.hash + +instance : Inhabited ExprStructEq := ⟨{ val := arbitrary _ }⟩ +instance : HasBeq ExprStructEq := ⟨ExprStructEq.beq⟩ +instance : Hashable ExprStructEq := ⟨ExprStructEq.hash⟩ +instance : HasToString ExprStructEq := ⟨fun e => toString e.val⟩ +instance : HasRepr ExprStructEq := ⟨fun e => repr e.val⟩ + +end ExprStructEq + +abbrev ExprStructMap (α : Type) := HashMap ExprStructEq α +abbrev PersistentExprStructMap (α : Type) := PHashMap ExprStructEq α + +namespace Expr + +private partial def mkAppRevRangeAux (revArgs : Array Expr) (start : Nat) : Expr → Nat → Expr +| b, i => + if i == start then b + else + let i := i - 1; + mkAppRevRangeAux (mkApp b (revArgs.get! i)) i + +/-- `mkAppRevRange f b e args == mkAppRev f (revArgs.extract b e)` -/ +def mkAppRevRange (f : Expr) (beginIdx endIdx : Nat) (revArgs : Array Expr) : Expr := +mkAppRevRangeAux revArgs beginIdx f endIdx + +private def betaRevAux (revArgs : Array Expr) (sz : Nat) : Expr → Nat → Expr +| Expr.lam _ _ b _, i => + if i + 1 < sz then + betaRevAux b (i+1) + else + let n := sz - (i + 1); + mkAppRevRange (b.instantiateRange n sz revArgs) 0 n revArgs +| b, i => + let n := sz - i; + mkAppRevRange (b.instantiateRange n sz revArgs) 0 n revArgs + +/-- If `f` is a lambda expression, than "beta-reduce" it using `revArgs`. + This function is often used with `getAppRev` or `withAppRev`. + Examples: + - `betaRev (fun x y => t x y) #[]` ==> `fun x y => t x y` + - `betaRev (fun x y => t x y) #[a]` ==> `fun y => t a y` + - `betaRev (fun x y => t x y) #[a, b]` ==> t b a` + - `betaRev (fun x y => t x y) #[a, b, c, d]` ==> t d c b a` + Suppose `t` is `(fun x y => t x y) a b c d`, then + `args := t.getAppRev` is `#[d, c, b, a]`, + and `betaRev (fun x y => t x y) #[d, c, b, a]` is `t a b c d`. -/ +def betaRev (f : Expr) (revArgs : Array Expr) : Expr := +if revArgs.size == 0 then f +else betaRevAux revArgs revArgs.size f 0 + +private def etaExpandedBody : Expr → Nat → Nat → Option Expr +| app f (bvar j _) _, n+1, i => if j == i then etaExpandedBody f n (i+1) else none +| _, n+1, _ => none +| f, 0, _ => if f.hasLooseBVars then none else some f + +private def etaExpandedAux : Expr → Nat → Option Expr +| lam _ _ b _, n => etaExpandedAux b (n+1) +| e, n => etaExpandedBody e n 0 + +/- If `e` is of the form `(fun x₁ ... xₙ => f x₁ ... xₙ)` and `f` does not contain `x₁`, ..., `xₙ`, + then return `some f`. Otherwise, return `none`. + + It assumes `e` does not have loose bound variables. -/ +def etaExpanded? (e : Expr) : Option Expr := +etaExpandedAux e 0 + +/- The update functions here are defined using C code. They will try to avoid + allocating new values using pointer equality. + The hypotheses `(h : e.is... = true)` are used to ensure Lean will not crash + at runtime. + The `update*!` functions are inlined and provide a convenient way of using the + update proofs without providing proofs. + Note that if they are used under a match-expression, the compiler will eliminate + the double-match. -/ + +@[extern "lean_expr_update_app"] +def updateApp (e : Expr) (newFn : Expr) (newArg : Expr) (h : e.isApp = true) : Expr := +mkApp newFn newArg + +@[inline] def updateApp! (e : Expr) (newFn : Expr) (newArg : Expr) : Expr := +match e with +| app fn arg c => updateApp (app fn arg c) newFn newArg rfl +| _ => panic! "application expected" + +@[extern "lean_expr_update_const"] +def updateConst (e : Expr) (newLevels : List Level) (h : e.isConst = true) : Expr := +mkConst e.constName! newLevels + +@[inline] def updateConst! (e : Expr) (newLevels : List Level) : Expr := +match e with +| const n ls c => updateConst (const n ls c) newLevels rfl +| _ => panic! "constant expected" + +@[extern "lean_expr_update_sort"] +def updateSort (e : Expr) (newLevel : Level) (h : e.isSort = true) : Expr := +mkSort newLevel + +@[inline] def updateSort! (e : Expr) (newLevel : Level) : Expr := +match e with +| sort l c => updateSort (sort l c) newLevel rfl +| _ => panic! "level expected" + +@[extern "lean_expr_update_proj"] +def updateProj (e : Expr) (newExpr : Expr) (h : e.isProj = true) : Expr := +match e with +| proj s i _ _ => mkProj s i newExpr +| _ => e -- unreachable because of `h` + +@[extern "lean_expr_update_mdata"] +def updateMData (e : Expr) (newExpr : Expr) (h : e.isMData = true) : Expr := +match e with +| mdata d _ _ => mkMData d newExpr +| _ => e -- unreachable because of `h` + +@[inline] def updateMData! (e : Expr) (newExpr : Expr) : Expr := +match e with +| mdata d e c => updateMData (mdata d e c) newExpr rfl +| _ => panic! "mdata expected" + +@[inline] def updateProj! (e : Expr) (newExpr : Expr) : Expr := +match e with +| proj s i e c => updateProj (proj s i e c) newExpr rfl +| _ => panic! "proj expected" + +@[extern "lean_expr_update_forall"] +def updateForall (e : Expr) (newBinfo : BinderInfo) (newDomain : Expr) (newBody : Expr) (h : e.isForall = true) : Expr := +mkForall e.bindingName! newBinfo newDomain newBody + +@[inline] def updateForall! (e : Expr) (newBinfo : BinderInfo) (newDomain : Expr) (newBody : Expr) : Expr := +match e with +| forallE n d b c => updateForall (forallE n d b c) newBinfo newDomain newBody rfl +| _ => panic! "forall expected" + +@[inline] def updateForallE! (e : Expr) (newDomain : Expr) (newBody : Expr) : Expr := +match e with +| forallE n d b c => updateForall (forallE n d b c) c.binderInfo newDomain newBody rfl +| _ => panic! "forall expected" + +@[extern "lean_expr_update_lambda"] +def updateLambda (e : Expr) (newBinfo : BinderInfo) (newDomain : Expr) (newBody : Expr) (h : e.isLambda = true) : Expr := +mkLambda e.bindingName! newBinfo newDomain newBody + +@[inline] def updateLambda! (e : Expr) (newBinfo : BinderInfo) (newDomain : Expr) (newBody : Expr) : Expr := +match e with +| lam n d b c => updateLambda (lam n d b c) newBinfo newDomain newBody rfl +| _ => panic! "lambda expected" + +@[inline] def updateLambdaE! (e : Expr) (newDomain : Expr) (newBody : Expr) : Expr := +match e with +| lam n d b c => updateLambda (lam n d b c) c.binderInfo newDomain newBody rfl +| _ => panic! "lambda expected" + +@[extern "lean_expr_update_let"] +def updateLet (e : Expr) (newType : Expr) (newVal : Expr) (newBody : Expr) (h : e.isLet = true) : Expr := +mkLet e.letName! newType newVal newBody + +@[inline] def updateLet! (e : Expr) (newType : Expr) (newVal : Expr) (newBody : Expr) : Expr := +match e with +| letE n t v b c => updateLet (letE n t v b c) newType newVal newBody rfl +| _ => panic! "let expression expected" + +def updateFn : Expr → Expr → Expr +| e@(app f a _), g => e.updateApp (updateFn f g) a rfl +| _, g => g + +end Expr +end Lean diff --git a/stage0/src/Init/Lean/Format.lean b/stage0/src/Init/Lean/Format.lean new file mode 100644 index 0000000000..bf25b0fc1b --- /dev/null +++ b/stage0/src/Init/Lean/Format.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Lean.Options +import Init.Data.Array +universes u v + +namespace Lean + +inductive Format +| nil : Format +| line : Format +| text : String → Format +| nest : Nat → Format → Format +| compose : Bool → Format → Format → Format +| choice : Format → Format → Format + +namespace Format +@[export lean_format_append] +protected def append (a b : Format) : Format := +compose false a b + +instance : HasAppend Format := ⟨Format.append⟩ +instance : HasCoe String Format := ⟨text⟩ +instance : Inhabited Format := ⟨nil⟩ + +def join (xs : List Format) : Format := +xs.foldl HasAppend.append "" + +def isNil : Format → Bool +| nil => true +| _ => false + +def flatten : Format → Format +| nil => nil +| line => text " " +| f@(text _) => f +| nest _ f => flatten f +| choice f _ => flatten f +| f@(compose true _ _) => f +| f@(compose false f₁ f₂) => compose true (flatten f₁) (flatten f₂) + +@[export lean_format_group] +def group : Format → Format +| nil => nil +| f@(text _) => f +| f@(compose true _ _) => f +| f => choice (flatten f) f + +structure SpaceResult := +(found := false) +(exceeded := false) +(space := 0) + +@[inline] private def merge (w : Nat) (r₁ : SpaceResult) (r₂ : Thunk SpaceResult) : SpaceResult := +if r₁.exceeded || r₁.found then r₁ +else + let y := r₂.get; + if y.exceeded || y.found then y + else + let newSpace := r₁.space + y.space; + { space := newSpace, exceeded := newSpace > w } + +def spaceUptoLine : Format → Nat → SpaceResult +| nil, w => {} +| line, w => { found := true } +| text s, w => { space := s.length, exceeded := s.length > w } +| compose _ f₁ f₂, w => merge w (spaceUptoLine f₁ w) (spaceUptoLine f₂ w) +| nest _ f, w => spaceUptoLine f w +| choice f₁ f₂, w => spaceUptoLine f₂ w + +def spaceUptoLine' : List (Nat × Format) → Nat → SpaceResult +| [], w => {} +| p::ps, w => merge w (spaceUptoLine p.2 w) (spaceUptoLine' ps w) + +partial def be : Nat → Nat → String → List (Nat × Format) → String +| w, k, out, [] => out +| w, k, out, (i, nil)::z => be w k out z +| w, k, out, (i, (compose _ f₁ f₂))::z => be w k out ((i, f₁)::(i, f₂)::z) +| w, k, out, (i, (nest n f))::z => be w k out ((i+n, f)::z) +| w, k, out, (i, text s)::z => be w (k + s.length) (out ++ s) z +| w, k, out, (i, line)::z => be w i ((out ++ "\n").pushn ' ' i) z +| w, k, out, (i, choice f₁ f₂)::z => + let r := merge w (spaceUptoLine f₁ w) (spaceUptoLine' z w); + if r.exceeded then be w k out ((i, f₂)::z) else be w k out ((i, f₁)::z) + +@[inline] def bracket (l : String) (f : Format) (r : String) : Format := +group (nest l.length $ l ++ f ++ r) + +@[inline] def paren (f : Format) : Format := +bracket "(" f ")" + +@[inline] def sbracket (f : Format) : Format := +bracket "[" f "]" + +def defIndent := 4 +def defUnicode := true +def defWidth := 120 + +def getWidth (o : Options) : Nat := o.get `format.width defWidth +def getIndent (o : Options) : Nat := o.get `format.indent defIndent +def getUnicode (o : Options) : Bool := o.get `format.unicode defUnicode + +@[init] def indentOption : IO Unit := +registerOption `format.indent { defValue := defIndent, group := "format", descr := "indentation" } +@[init] def unicodeOption : IO Unit := +registerOption `format.unicode { defValue := defUnicode, group := "format", descr := "unicode characters" } +@[init] def widthOption : IO Unit := +registerOption `format.width { defValue := defWidth, group := "format", descr := "line width" } + +@[export lean_format_pretty] +def prettyAux (f : Format) (w : Nat := defWidth) : String := +be w 0 "" [(0, f)] + +def pretty (f : Format) (o : Options := {}) : String := +prettyAux f (getWidth o) + +end Format + +open Lean.Format + +class HasFormat (α : Type u) := +(format : α → Format) + +export Lean.HasFormat (format) + +def fmt {α : Type u} [HasFormat α] : α → Format := +format + +instance toStringToFormat {α : Type u} [HasToString α] : HasFormat α := +⟨text ∘ toString⟩ + +-- note: must take precendence over the above instance to avoid premature formatting +instance formatHasFormat : HasFormat Format := +⟨id⟩ + +instance stringHasFormat : HasFormat String := ⟨Format.text⟩ + +def Format.joinSep {α : Type u} [HasFormat α] : List α → Format → Format +| [], sep => nil +| [a], sep => format a +| a::as, sep => format a ++ sep ++ Format.joinSep as sep + +def Format.prefixJoin {α : Type u} [HasFormat α] (pre : Format) : List α → Format +| [] => nil +| a::as => pre ++ format a ++ Format.prefixJoin as + +def Format.joinSuffix {α : Type u} [HasFormat α] : List α → Format → Format +| [], suffix => nil +| a::as, suffix => format a ++ suffix ++ Format.joinSuffix as suffix + +def List.format {α : Type u} [HasFormat α] : List α → Format +| [] => "[]" +| xs => sbracket $ Format.joinSep xs ("," ++ line) + +instance listHasFormat {α : Type u} [HasFormat α] : HasFormat (List α) := +⟨List.format⟩ + +instance arrayHasFormat {α : Type u} [HasFormat α] : HasFormat (Array α) := +⟨fun a => "#" ++ fmt a.toList⟩ + +def Option.format {α : Type u} [HasFormat α] : Option α → Format +| none => "none" +| some a => "some " ++ fmt a + +instance optionHasFormat {α : Type u} [HasFormat α] : HasFormat (Option α) := +⟨Option.format⟩ + +instance prodHasFormat {α : Type u} {β : Type v} [HasFormat α] [HasFormat β] : HasFormat (Prod α β) := +⟨fun ⟨a, b⟩ => paren $ format a ++ "," ++ line ++ format b⟩ + +def Format.joinArraySep {α : Type u} [HasFormat α] (a : Array α) (sep : Format) : Format := +a.iterate nil (fun i a r => if i.val > 0 then r ++ sep ++ format a else r ++ format a) + +instance natHasFormat : HasFormat Nat := ⟨fun n => toString n⟩ +instance uint16HasFormat : HasFormat UInt16 := ⟨fun n => toString n⟩ +instance uint32HasFormat : HasFormat UInt32 := ⟨fun n => toString n⟩ +instance uint64HasFormat : HasFormat UInt64 := ⟨fun n => toString n⟩ +instance usizeHasFormat : HasFormat USize := ⟨fun n => toString n⟩ +instance nameHasFormat : HasFormat Name := ⟨fun n => n.toString⟩ + +protected def Format.repr : Format → Format +| nil => "Format.nil" +| line => "Format.line" +| text s => paren $ "Format.text" ++ line ++ repr s +| nest n f => paren $ "Format.nest" ++ line ++ repr n ++ line ++ Format.repr f +| compose b f₁ f₂ => paren $ "Format.compose " ++ repr b ++ line ++ Format.repr f₁ ++ line ++ Format.repr f₂ +| choice f₁ f₂ => paren $ "Format.choice" ++ line ++ Format.repr f₁ ++ line ++ Format.repr f₂ + + +instance formatHasToString : HasToString Format := ⟨Format.pretty⟩ + +instance : HasRepr Format := ⟨Format.pretty ∘ Format.repr⟩ + +def formatDataValue : DataValue → Format +| DataValue.ofString v => format (repr v) +| DataValue.ofBool v => format v +| DataValue.ofName v => "`" ++ format v +| DataValue.ofNat v => format v +| DataValue.ofInt v => format v + +instance dataValueHasFormat : HasFormat DataValue := ⟨formatDataValue⟩ + +def formatEntry : Name × DataValue → Format +| (n, v) => format n ++ " := " ++ format v + +instance entryHasFormat : HasFormat (Name × DataValue) := ⟨formatEntry⟩ + +def formatKVMap (m : KVMap) : Format := +sbracket (Format.joinSep m.entries ", ") + +instance kvMapHasFormat : HasFormat KVMap := ⟨formatKVMap⟩ + +end Lean diff --git a/stage0/src/Init/Lean/KVMap.lean b/stage0/src/Init/Lean/KVMap.lean new file mode 100644 index 0000000000..9a1bbd79c6 --- /dev/null +++ b/stage0/src/Init/Lean/KVMap.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Name +import Init.Data.Option.Basic +import Init.Data.Int + +namespace Lean + +inductive DataValue +| ofString (v : String) +| ofBool (v : Bool) +| ofName (v : Name) +| ofNat (v : Nat) +| ofInt (v : Int) + +def DataValue.beq : DataValue → DataValue → Bool +| DataValue.ofString s₁, DataValue.ofString s₂ => s₁ = s₂ +| DataValue.ofNat n₁, DataValue.ofNat n₂ => n₂ = n₂ +| DataValue.ofBool b₁, DataValue.ofBool b₂ => b₁ = b₂ +| _, _ => false + +instance DataValue.HasBeq : HasBeq DataValue := ⟨DataValue.beq⟩ + +instance string2DataValue : HasCoe String DataValue := ⟨DataValue.ofString⟩ +instance bool2DataValue : HasCoe Bool DataValue := ⟨DataValue.ofBool⟩ +instance name2DataValue : HasCoe Name DataValue := ⟨DataValue.ofName⟩ +instance nat2DataValue : HasCoe Nat DataValue := ⟨DataValue.ofNat⟩ +instance int2DataValue : HasCoe Int DataValue := ⟨DataValue.ofInt⟩ + +/- Remark: we do not use RBMap here because we need to manipulate KVMap objects in + C++ and RBMap is implemented in Lean. So, we use just a List until we can + generate C++ code from Lean code. -/ +structure KVMap := +(entries : List (Name × DataValue) := []) + +namespace KVMap +def empty : KVMap := +{} + +def isEmpty : KVMap → Bool +| ⟨m⟩ => m.isEmpty + +def findCore : List (Name × DataValue) → Name → Option DataValue +| [], k' => none +| (k,v)::m, k' => if k == k' then some v else findCore m k' + +def find : KVMap → Name → Option DataValue +| ⟨m⟩, k => findCore m k + +def findD (m : KVMap) (k : Name) (d₀ : DataValue) : DataValue := +(m.find k).getD d₀ + +def insertCore : List (Name × DataValue) → Name → DataValue → List (Name × DataValue) +| [], k', v' => [(k',v')] +| (k,v)::m, k', v' => if k == k' then (k, v') :: m else (k, v) :: insertCore m k' v' + +def insert : KVMap → Name → DataValue → KVMap +| ⟨m⟩, k, v => ⟨insertCore m k v⟩ + +def contains (m : KVMap) (n : Name) : Bool := +(m.find n).isSome + +def getString (m : KVMap) (k : Name) (defVal := "") : String := +match m.find k with +| some (DataValue.ofString v) => v +| _ => defVal + +def getNat (m : KVMap) (k : Name) (defVal := 0) : Nat := +match m.find k with +| some (DataValue.ofNat v) => v +| _ => defVal + +def getInt (m : KVMap) (k : Name) (defVal : Int := 0) : Int := +match m.find k with +| some (DataValue.ofInt v) => v +| _ => defVal + +def getBool (m : KVMap) (k : Name) (defVal := false) : Bool := +match m.find k with +| some (DataValue.ofBool v) => v +| _ => defVal + +def getName (m : KVMap) (k : Name) (defVal := Name.anonymous) : Name := +match m.find k with +| some (DataValue.ofName v) => v +| _ => defVal + +def setString (m : KVMap) (k : Name) (v : String) : KVMap := +m.insert k (DataValue.ofString v) + +def setNat (m : KVMap) (k : Name) (v : Nat) : KVMap := +m.insert k (DataValue.ofNat v) + +def setInt (m : KVMap) (k : Name) (v : Int) : KVMap := +m.insert k (DataValue.ofInt v) + +def setBool (m : KVMap) (k : Name) (v : Bool) : KVMap := +m.insert k (DataValue.ofBool v) + +def setName (m : KVMap) (k : Name) (v : Name) : KVMap := +m.insert k (DataValue.ofName v) + +def subsetAux : List (Name × DataValue) → KVMap → Bool +| [], m₂ => true +| (k, v₁)::m₁, m₂ => + match m₂.find k with + | some v₂ => v₁ == v₂ && subsetAux m₁ m₂ + | none => false + +def subset : KVMap → KVMap → Bool +| ⟨m₁⟩, m₂ => subsetAux m₁ m₂ + +def eqv (m₁ m₂ : KVMap) : Bool := +subset m₁ m₂ && subset m₂ m₁ + +instance : HasBeq KVMap := ⟨eqv⟩ + +class isKVMapVal (α : Type) := +(defVal : α) +(set : KVMap → Name → α → KVMap) +(get : KVMap → Name → α → α) + +export isKVMapVal (set) + +@[inline] def get {α : Type} [isKVMapVal α] (m : KVMap) (k : Name) (defVal := isKVMapVal.defVal α) : α := +isKVMapVal.get m k defVal + +instance boolVal : isKVMapVal Bool := +{ defVal := false, set := setBool, get := fun k n v => getBool k n v } + +instance natVal : isKVMapVal Nat := +{ defVal := 0, set := setNat, get := fun k n v => getNat k n v } + +instance intVal : isKVMapVal Int := +{ defVal := 0, set := setInt, get := fun k n v => getInt k n v } + +instance nameVal : isKVMapVal Name := +{ defVal := Name.anonymous, set := setName, get := fun k n v => getName k n v } + +instance stringVal : isKVMapVal String := +{ defVal := "", set := setString, get := fun k n v => getString k n v } + +end KVMap +end Lean diff --git a/stage0/src/Init/Lean/LBool.lean b/stage0/src/Init/Lean/LBool.lean new file mode 100644 index 0000000000..8f61ea4811 --- /dev/null +++ b/stage0/src/Init/Lean/LBool.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.ToString + +namespace Lean + +inductive LBool +| false +| true +| undef + +namespace LBool + +instance : Inhabited LBool := ⟨false⟩ + +def neg : LBool → LBool +| true => false +| false => true +| undef => undef + +def and : LBool → LBool → LBool +| true, b => b +| a, _ => a + +def beq : LBool → LBool → Bool +| true, true => Bool.true +| false, false => Bool.true +| undef, undef => Bool.true +| _, _ => Bool.false + +instance : HasBeq LBool := ⟨beq⟩ + +def toString : LBool → String +| true => "true" +| false => "false" +| undef => "undef" + +instance : HasToString LBool := ⟨toString⟩ + +end LBool + +end Lean + +def Bool.toLBool : Bool → Lean.LBool +| true => Lean.LBool.true +| false => Lean.LBool.false + +@[inline] def toLBoolM {m : Type → Type} [Monad m] (x : m Bool) : m Lean.LBool := +do b ← x; pure b.toLBool diff --git a/stage0/src/Init/Lean/LOption.lean b/stage0/src/Init/Lean/LOption.lean new file mode 100644 index 0000000000..790d45842a --- /dev/null +++ b/stage0/src/Init/Lean/LOption.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.ToString +universes u + +namespace Lean + +inductive LOption (α : Type u) +| none {} : LOption +| some : α → LOption +| undef {} : LOption + +namespace LOption +variables {α : Type u} + +instance : Inhabited (LOption α) := ⟨none⟩ + +instance [HasToString α] : HasToString (LOption α) := +⟨fun o => match o with | none => "none" | undef => "undef" | (some a) => "(some " ++ toString a ++ ")"⟩ + +def beq [HasBeq α] : LOption α → LOption α → Bool +| none, none => true +| undef, undef => true +| some a, some b => a == b +| _, _ => false + +instance [HasBeq α] : HasBeq (LOption α) := ⟨beq⟩ + +end LOption +end Lean + +def Option.toLOption {α : Type u} : Option α → Lean.LOption α +| none => Lean.LOption.none +| some a => Lean.LOption.some a diff --git a/stage0/src/Init/Lean/Level.lean b/stage0/src/Init/Lean/Level.lean new file mode 100644 index 0000000000..6c3da4e1f0 --- /dev/null +++ b/stage0/src/Init/Lean/Level.lean @@ -0,0 +1,440 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Option.Basic +import Init.Data.HashMap +import Init.Data.PersistentHashMap +import Init.Lean.Name +import Init.Lean.Format + +def Nat.imax (n m : Nat) : Nat := +if m = 0 then 0 else Nat.max n m + +namespace Lean + +/-- + Cached hash code, cached results, and other data for `Level`. + hash : 32-bits + hasMVar : 1-bit + hasParam : 1-bit + depth : 24-bits -/ +def Level.Data := UInt64 + +instance Level.Data.inhabited : Inhabited Level.Data := +inferInstanceAs (Inhabited UInt64) + +def Level.Data.hash (c : Level.Data) : USize := +c.toUInt32.toUSize + +instance Level.Data.hasBeq : HasBeq Level.Data := +⟨fun (a b : UInt64) => a == b⟩ + +def Level.Data.depth (c : Level.Data) : UInt32 := +(c.shiftRight 40).toUInt32 + +def Level.Data.hasMVar (c : Level.Data) : Bool := +((c.shiftRight 32).land 1) == 1 + +def Level.Data.hasParam (c : Level.Data) : Bool := +((c.shiftRight 33).land 1) == 1 + +def Level.mkData (h : USize) (depth : Nat) (hasMVar hasParam : Bool) : Level.Data := +if depth > Nat.pow 2 24 - 1 then panic! "universe level depth is too big" +else + let r : UInt64 := h.toUInt32.toUInt64 + hasMVar.toUInt64.shiftLeft 32 + hasParam.toUInt64.shiftLeft 33 + depth.toUInt64.shiftLeft 40; + r + +open Level + +inductive Level +| zero : Data → Level +| succ : Level → Data → Level +| max : Level → Level → Data → Level +| imax : Level → Level → Data → Level +| param : Name → Data → Level +| mvar : Name → Data → Level + +namespace Level + +@[inline] def data : Level → Data +| zero d => d +| mvar _ d => d +| param _ d => d +| succ _ d => d +| max _ _ d => d +| imax _ _ d => d + +def hash (u : Level) : USize := +u.data.hash + +instance : Hashable Level := ⟨hash⟩ + +def depth (u : Level) : Nat := +u.data.depth.toNat + +def hasMVar (u : Level) : Bool := +u.data.hasMVar + +def hasParam (u : Level) : Bool := +u.data.hasParam + +@[export lean_level_hash] def hashEx : Level → USize := hash +@[export lean_level_has_mvar] def hasMVarEx : Level → Bool := hasMVar +@[export lean_level_has_param] def hasParamEx : Level → Bool := hasParam +@[export lean_level_depth] def depthEx (u : Level) : UInt32 := u.data.depth + +end Level + +def levelZero := +Level.zero $ mkData 2221 0 false false + +def mkLevelMVar (mvarId : Name) := +Level.mvar mvarId $ mkData (mixHash 2237 $ hash mvarId) 0 true false + +def mkLevelParam (name : Name) := +Level.param name $ mkData (mixHash 2239 $ hash name) 0 false true + +def mkLevelSucc (u : Level) := +Level.succ u $ mkData (mixHash 2243 $ hash u) (u.depth + 1) u.hasMVar u.hasParam + +def mkLevelMax (u v : Level) := +Level.max u v $ mkData (mixHash 2251 $ mixHash (hash u) (hash v)) (Nat.max u.depth v.depth + 1) + (u.hasMVar || v.hasMVar) + (u.hasParam || v.hasParam) + +def mkLevelIMax (u v : Level) := +Level.imax u v $ mkData (mixHash 2267 $ mixHash (hash u) (hash v)) (Nat.max u.depth v.depth + 1) + (u.hasMVar || v.hasMVar) + (u.hasParam || v.hasParam) + +def levelOne := mkLevelSucc levelZero + +@[export lean_level_mk_zero] def mkLevelZeroEx : Unit → Level := fun _ => levelZero +@[export lean_level_mk_succ] def mkLevelSuccEx : Level → Level := mkLevelSucc +@[export lean_level_mk_mvar] def mkLevelMVarEx : Name → Level := mkLevelMVar +@[export lean_level_mk_param] def mkLevelParamEx : Name → Level := mkLevelParam +@[export lean_level_mk_max] def mkLevelMaxEx : Level → Level → Level := mkLevelMax +@[export lean_level_mk_imax] def mkLevelIMaxEx : Level → Level → Level := mkLevelIMax + +namespace Level + +instance : Inhabited Level := ⟨levelZero⟩ + +def isZero : Level → Bool +| zero _ => true +| _ => false + +def isSucc : Level → Bool +| succ _ _ => true +| _ => false + +def isMax : Level → Bool +| max _ _ _ => true +| _ => false + +def isIMax : Level → Bool +| imax _ _ _ => true +| _ => false + +def isMaxIMax : Level → Bool +| max _ _ _ => true +| imax _ _ _ => true +| _ => false + +def isParam : Level → Bool +| param _ _ => true +| _ => false + +def isMVar : Level → Bool +| mvar _ _ => true +| _ => false + +def mvarId! : Level → Name +| mvar mvarId _ => mvarId +| _ => panic! "metavariable expected" + +/-- If result is true, then forall assignments `A` which assigns all parameters and metavariables occuring + in `l`, `l[A] != zero` -/ +def isNeverZero : Level → Bool +| zero _ => false +| param _ _ => false +| mvar _ _ => false +| succ _ _ => true +| max l₁ l₂ _ => isNeverZero l₁ || isNeverZero l₂ +| imax l₁ l₂ _ => isNeverZero l₂ + +def ofNat : Nat → Level +| 0 => levelZero +| n+1 => mkLevelSucc (ofNat n) + +def addOffsetAux : Nat → Level → Level +| 0, u => u +| (n+1), u => addOffsetAux n (mkLevelSucc u) + +def addOffset (u : Level) (n : Nat) : Level := +u.addOffsetAux n + +def isExplicit : Level → Bool +| zero _ => true +| succ u _ => !u.hasMVar && !u.hasParam && isExplicit u +| _ => false + +def getOffsetAux : Level → Nat → Nat +| succ u _, r => getOffsetAux u (r+1) +| _, r => r + +def getOffset (lvl : Level) : Nat := + getOffsetAux lvl 0 + +def getLevelOffset : Level → Level +| succ u _ => getLevelOffset u +| u => u + +def toNat (lvl : Level) : Option Nat := +match lvl.getLevelOffset with +| zero _ => lvl.getOffset +| _ => none + +def instantiate (s : Name → Option Level) : Level → Level +| u@(zero _) => u +| succ u _ => mkLevelSucc (instantiate u) +| max u₁ u₂ _ => mkLevelMax (instantiate u₁) (instantiate u₂) +| imax u₁ u₂ _ => mkLevelIMax (instantiate u₁) (instantiate u₂) +| u@(param n _) => + match s n with + | some u' => u' + | none => u +| u => u + +@[extern "lean_level_eq"] +protected constant beq (a : @& Level) (b : @& Level) : Bool := arbitrary _ + +instance : HasBeq Level := ⟨Level.beq⟩ + +/-- `occurs u l` return `true` iff `u` occurs in `l`. -/ +def occurs : Level → Level → Bool +| u, v@(succ v₁ _) => u == v || occurs u v₁ +| u, v@(max v₁ v₂ _) => u == v || occurs u v₁ || occurs u v₂ +| u, v@(imax v₁ v₂ _) => u == v || occurs u v₁ || occurs u v₂ +| u, v => u == v + +def ctorToNat : Level → Nat +| zero _ => 0 +| param _ _ => 1 +| mvar _ _ => 2 +| succ _ _ => 3 +| max _ _ _ => 4 +| imax _ _ _ => 5 + +/- TODO: use well founded recursion. -/ +partial def normLtAux : Level → Nat → Level → Nat → Bool +| succ l₁ _, k₁, l₂, k₂ => normLtAux l₁ (k₁+1) l₂ k₂ +| l₁, k₁, succ l₂ _, k₂ => normLtAux l₁ k₁ l₂ (k₂+1) +| l₁@(max l₁₁ l₁₂ _), k₁, l₂@(max l₂₁ l₂₂ _), k₂ => + if l₁ == l₂ then k₁ < k₂ + else if l₁₁ == l₂₁ then normLtAux l₁₁ 0 l₂₁ 0 + else normLtAux l₁₂ 0 l₂₂ 0 +| l₁@(imax l₁₁ l₁₂ _), k₁, l₂@(imax l₂₁ l₂₂ _), k₂ => + if l₁ == l₂ then k₁ < k₂ + else if l₁₁ == l₂₁ then normLtAux l₁₁ 0 l₂₁ 0 + else normLtAux l₁₂ 0 l₂₂ 0 +| param n₁ _, k₁, param n₂ _, k₂ => if n₁ == n₂ then k₁ < k₂ else Name.lt n₁ n₂ -- use Name.lt because it is lexicographical +| mvar n₁ _, k₁, mvar n₂ _, k₂ => if n₁ == n₂ then k₁ < k₂ else Name.quickLt n₁ n₂ -- metavariables are temporary, the actual order doesn't matter +| l₁, k₁, l₂, k₂ => if l₁ == l₂ then k₁ < k₂ else ctorToNat l₁ < ctorToNat l₂ + +/-- + A total order on level expressions that has the following properties + - `succ l` is an immediate successor of `l`. + - `zero` is the minimal element. + This total order is used in the normalization procedure. -/ +def normLt (l₁ l₂ : Level) : Bool := +normLtAux l₁ 0 l₂ 0 + +private def isAlreadyNormalizedCheap : Level → Bool +| zero _ => true +| param _ _ => true +| mvar _ _ => true +| succ u _ => isAlreadyNormalizedCheap u +| _ => false + +/- Auxiliary function used at `normalize` -/ +private def mkIMaxAux : Level → Level → Level +| _, u@(zero _) => u +| zero _, u => u +| u₁, u₂ => if u₁ == u₂ then u₁ else mkLevelIMax u₁ u₂ + +/- Auxiliary function used at `normalize` -/ +@[specialize] private partial def getMaxArgsAux (normalize : Level → Level) : Level → Bool → Array Level → Array Level +| max l₁ l₂ _, alreadyNormalized, lvls => getMaxArgsAux l₂ alreadyNormalized (getMaxArgsAux l₁ alreadyNormalized lvls) +| l, false, lvls => getMaxArgsAux (normalize l) true lvls +| l, true, lvls => lvls.push l + +private def accMax (result : Level) (prev : Level) (offset : Nat) : Level := +if result.isZero then prev.addOffset offset +else mkLevelMax result (prev.addOffset offset) + +/- Auxiliary function used at `normalize`. + Remarks: + - `lvls` are sorted using `normLt` + - `extraK` is the outter offset of the `max` term. We will push it inside. + - `i` is the current array index + - `prev + prevK` is the "previous" level that has not been added to `result` yet. + - `result` is the accumulator + -/ +private partial def mkMaxAux (lvls : Array Level) (extraK : Nat) : Nat → Level → Nat → Level → Level +| i, prev, prevK, result => + if h : i < lvls.size then + let lvl := lvls.get ⟨i, h⟩; + let curr := lvl.getLevelOffset; + let currK := lvl.getOffset; + if curr == prev then + mkMaxAux (i+1) curr currK result + else + mkMaxAux (i+1) curr currK (accMax result prev (extraK + prevK)) + else + accMax result prev (extraK + prevK) + +partial def normalize : Level → Level +| l => + if isAlreadyNormalizedCheap l then l + else + let k := l.getOffset; + let u := l.getLevelOffset; + match u with + | max l₁ l₂ _ => + let lvls := getMaxArgsAux normalize l₁ false #[]; + let lvls := getMaxArgsAux normalize l₂ false lvls; + let lvls := lvls.qsort normLt; + let lvl₁ := lvls.get! 0; + let prev := lvl₁.getLevelOffset; + let prevK := lvl₁.getOffset; + mkMaxAux lvls k 1 prev prevK levelZero + | imax l₁ l₂ _ => + if l₂.isNeverZero then addOffset (normalize (mkLevelMax l₁ l₂)) k + else + let l₁ := normalize l₁; + let l₂ := normalize l₂; + addOffset (mkIMaxAux l₁ l₂) k + | _ => unreachable! + + +/- Return true if `u` and `v` denote the same level. + Check is currently incomplete. -/ +def isEquiv (u v : Level) : Bool := +u == v || u.normalize == v.normalize + +/-- Reduce (if possible) universe level by 1 -/ +def dec : Level → Option Level +| zero _ => none +| param _ _ => none +| mvar _ _ => none +| succ l _ => l +| max l₁ l₂ _ => mkLevelMax <$> dec l₁ <*> dec l₂ +/- Remark: `mkLevelMax` in the following line is not a typo. + If `dec l₂` succeeds, then `imax l₁ l₂` is equivalent to `max l₁ l₂`. -/ +| imax l₁ l₂ _ => mkLevelMax <$> dec l₁ <*> dec l₂ + +/- Level to Format -/ +namespace LevelToFormat +inductive Result +| leaf : Format → Result +| num : Nat → Result +| offset : Result → Nat → Result +| maxNode : List Result → Result +| imaxNode : List Result → Result + +def Result.succ : Result → Result +| Result.offset f k => Result.offset f (k+1) +| Result.num k => Result.num (k+1) +| f => Result.offset f 1 + +def Result.max : Result → Result → Result +| f, Result.maxNode Fs => Result.maxNode (f::Fs) +| f₁, f₂ => Result.maxNode [f₁, f₂] + +def Result.imax : Result → Result → Result +| f, Result.imaxNode Fs => Result.imaxNode (f::Fs) +| f₁, f₂ => Result.imaxNode [f₁, f₂] + +def parenIfFalse : Format → Bool → Format +| f, true => f +| f, false => f.paren + +@[specialize] private def formatLst (fmt : Result → Format) : List Result → Format +| [] => Format.nil +| r::rs => Format.line ++ fmt r ++ formatLst rs + +partial def Result.format : Result → Bool → Format +| Result.leaf f, _ => f +| Result.num k, _ => toString k +| Result.offset f 0, r => Result.format f r +| Result.offset f (k+1), r => + let f' := Result.format f false; + parenIfFalse (f' ++ "+" ++ fmt (k+1)) r +| Result.maxNode fs, r => parenIfFalse (Format.group $ "max" ++ formatLst (fun r => Result.format r false) fs) r +| Result.imaxNode fs, r => parenIfFalse (Format.group $ "imax" ++ formatLst (fun r => Result.format r false) fs) r + +def toResult : Level → Result +| zero _ => Result.num 0 +| succ l _ => Result.succ (toResult l) +| max l₁ l₂ _ => Result.max (toResult l₁) (toResult l₂) +| imax l₁ l₂ _ => Result.imax (toResult l₁) (toResult l₂) +| param n _ => Result.leaf (fmt n) +| mvar n _ => Result.leaf (fmt n) + +end LevelToFormat + +protected def format (l : Level) : Format := +(LevelToFormat.toResult l).format true + +instance : HasFormat Level := ⟨Level.format⟩ +instance : HasToString Level := ⟨Format.pretty ∘ Level.format⟩ + +/- The update functions here are defined using C code. They will try to avoid + allocating new values using pointer equality. + The hypotheses `(h : e.is... = true)` are used to ensure Lean will not crash + at runtime. + The `update*!` functions are inlined and provide a convenient way of using the + update proofs without providing proofs. + Note that if they are used under a match-expression, the compiler will eliminate + the double-match. -/ + +@[extern "lean_level_update_succ"] +def updateSucc (lvl : Level) (newLvl : Level) (h : lvl.isSucc = true) : Level := +mkLevelSucc newLvl + +@[inline] def updateSucc! (lvl : Level) (newLvl : Level) : Level := +match lvl with +| succ lvl d => updateSucc (succ lvl d) newLvl rfl +| _ => panic! "succ level expected" + +@[extern "lean_level_update_max"] +def updateMax (lvl : Level) (newLhs : Level) (newRhs : Level) (h : lvl.isMax = true) : Level := +mkLevelMax newLhs newRhs + +@[inline] def updateMax! (lvl : Level) (newLhs : Level) (newRhs : Level) : Level := +match lvl with +| max lhs rhs d => updateMax (max lhs rhs d) newLhs newRhs rfl +| _ => panic! "max level expected" + +@[extern "lean_level_update_imax"] +def updateIMax (lvl : Level) (newLhs : Level) (newRhs : Level) (h : lvl.isIMax = true) : Level := +mkLevelIMax newLhs newRhs + +@[inline] def updateIMax! (lvl : Level) (newLhs : Level) (newRhs : Level) : Level := +match lvl with +| max lhs rhs d => updateIMax (imax lhs rhs d) newLhs newRhs rfl +| _ => panic! "imax level expected" + +end Level + +abbrev LevelMap (α : Type) := HashMap Level α +abbrev PersistentLevelMap (α : Type) := PHashMap Level α + +end Lean + +abbrev Nat.toLevel (n : Nat) : Lean.Level := +Lean.Level.ofNat n diff --git a/stage0/src/Init/Lean/Linter.lean b/stage0/src/Init/Lean/Linter.lean new file mode 100644 index 0000000000..edb5015655 --- /dev/null +++ b/stage0/src/Init/Lean/Linter.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sebastian Ullrich +-/ +prelude +import Init.System.IO +import Init.Lean.Attributes +import Init.Lean.Message +import Init.Lean.Syntax + +namespace Lean + +def Linter := Environment → Name → /-Syntax → -/IO MessageLog + +def mkLintersRef : IO (IO.Ref (Array Linter)) := +IO.mkRef #[] + +/- Linters should be loadable as plugins, so store in a global IO ref instead of an attribute managed by the + environment (which only contains `import`ed objects). -/ +@[init mkLintersRef, export lean_linters_ref] +constant lintersRef : IO.Ref (Array Linter) := arbitrary _ + +def addLinter (l : Linter) : IO Unit := do + ls ← lintersRef.get; + lintersRef.set (ls.push l) + +end Lean diff --git a/stage0/src/Init/Lean/LocalContext.lean b/stage0/src/Init/Lean/LocalContext.lean new file mode 100644 index 0000000000..87e684224a --- /dev/null +++ b/stage0/src/Init/Lean/LocalContext.lean @@ -0,0 +1,293 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.PersistentArray.Basic +import Init.Data.PersistentHashMap.Basic +import Init.Lean.Expr + +namespace Lean + +inductive LocalDecl +| cdecl (index : Nat) (name : Name) (userName : Name) (type : Expr) (bi : BinderInfo) +| ldecl (index : Nat) (name : Name) (userName : Name) (type : Expr) (value : Expr) + +namespace LocalDecl +instance : Inhabited LocalDecl := ⟨ldecl (arbitrary _) (arbitrary _) (arbitrary _) (arbitrary _) (arbitrary _)⟩ + +def isLet : LocalDecl → Bool +| cdecl _ _ _ _ _ => false +| ldecl _ _ _ _ _ => true + +def index : LocalDecl → Nat +| cdecl idx _ _ _ _ => idx +| ldecl idx _ _ _ _ => idx + +def name : LocalDecl → Name +| cdecl _ n _ _ _ => n +| ldecl _ n _ _ _ => n + +def userName : LocalDecl → Name +| cdecl _ _ n _ _ => n +| ldecl _ _ n _ _ => n + +def type : LocalDecl → Expr +| cdecl _ _ _ t _ => t +| ldecl _ _ _ t _ => t + +def binderInfo : LocalDecl → BinderInfo +| cdecl _ _ _ _ bi => bi +| ldecl _ _ _ _ _ => BinderInfo.default + +def value? : LocalDecl → Option Expr +| cdecl _ _ _ _ _ => none +| ldecl _ _ _ _ v => some v + +def value : LocalDecl → Expr +| cdecl _ _ _ _ _ => panic! "let declaration expected" +| ldecl _ _ _ _ v => v + +def updateUserName : LocalDecl → Name → LocalDecl +| cdecl index name _ type bi, userName => cdecl index name userName type bi +| ldecl index name _ type val, userName => ldecl index name userName type val + +def toExpr (decl : LocalDecl) : Expr := +mkFVar decl.name + +end LocalDecl + +structure LocalContext := +(nameToDecl : PersistentHashMap Name LocalDecl := {}) +(decls : PersistentArray (Option LocalDecl) := {}) + +namespace LocalContext +instance : Inhabited LocalContext := ⟨{}⟩ + +@[export lean_mk_empty_local_ctx] +def mkEmpty : Unit → LocalContext := +fun _ => {} + +def empty : LocalContext := +{} + +@[export lean_local_ctx_is_empty] +def isEmpty (lctx : LocalContext) : Bool := +lctx.nameToDecl.isEmpty + +/- Low level API for creating local declarations. It is used to implement actions in the monads `Elab` and `Tactic`. It should not be used directly since the argument `(name : Name)` is assumed to be "unique". -/ +@[export lean_local_ctx_mk_local_decl] +def mkLocalDecl (lctx : LocalContext) (fvarId : Name) (userName : Name) (type : Expr) (bi : BinderInfo := BinderInfo.default) : LocalContext := +match lctx with +| { nameToDecl := map, decls := decls } => + let idx := decls.size; + let decl := LocalDecl.cdecl idx fvarId userName type bi; + { nameToDecl := map.insert fvarId decl, decls := decls.push decl } + +@[export lean_local_ctx_mk_let_decl] +def mkLetDecl (lctx : LocalContext) (fvarId : Name) (userName : Name) (type : Expr) (value : Expr) : LocalContext := +match lctx with +| { nameToDecl := map, decls := decls } => + let idx := decls.size; + let decl := LocalDecl.ldecl idx fvarId userName type value; + { nameToDecl := map.insert fvarId decl, decls := decls.push decl } + +@[export lean_local_ctx_find] +def find (lctx : LocalContext) (fvarId : Name) : Option LocalDecl := +lctx.nameToDecl.find fvarId + +def findFVar (lctx : LocalContext) (e : Expr) : Option LocalDecl := +lctx.find e.fvarId! + +def contains (lctx : LocalContext) (fvarId : Name) : Bool := +lctx.nameToDecl.contains fvarId + +def containsFVar (lctx : LocalContext) (e : Expr) : Bool := +lctx.contains e.fvarId! + +private partial def popTailNoneAux : PArray (Option LocalDecl) → PArray (Option LocalDecl) +| a => + if a.size == 0 then a + else match a.get! (a.size - 1) with + | none => popTailNoneAux a.pop + | some _ => a + +@[export lean_local_ctx_erase] +def erase (lctx : LocalContext) (fvarId : Name) : LocalContext := +match lctx with +| { nameToDecl := map, decls := decls } => + match map.find fvarId with + | none => lctx + | some decl => { nameToDecl := map.erase fvarId, decls := popTailNoneAux (decls.set decl.index none) } + +@[export lean_local_ctx_pop] +def pop (lctx : LocalContext): LocalContext := +match lctx with +| { nameToDecl := map, decls := decls } => + if decls.size == 0 then lctx + else match decls.get! (decls.size - 1) with + | none => lctx -- unreachable + | some decl => { nameToDecl := map.erase decl.name, decls := popTailNoneAux decls.pop } + +@[export lean_local_ctx_find_from_user_name] +def findFromUserName (lctx : LocalContext) (userName : Name) : Option LocalDecl := +lctx.decls.findRev (fun decl => + match decl with + | none => none + | some decl => if decl.userName == userName then some decl else none) + +@[export lean_local_ctx_uses_user_name] +def usesUserName (lctx : LocalContext) (userName : Name) : Bool := +(lctx.findFromUserName userName).isSome + +partial def getUnusedNameAux (lctx : LocalContext) (suggestion : Name) : Nat → Name × Nat +| i => + let curr := suggestion.appendIndexAfter i; + if lctx.usesUserName curr then getUnusedNameAux (i + 1) + else (curr, i + 1) + +@[export lean_local_ctx_get_unused_name] +def getUnusedName (lctx : LocalContext) (suggestion : Name) : Name := +if lctx.usesUserName suggestion then (lctx.getUnusedNameAux suggestion 1).1 +else suggestion + +@[export lean_local_ctx_last_decl] +def lastDecl (lctx : LocalContext) : Option LocalDecl := +lctx.decls.get! (lctx.decls.size - 1) + +@[export lean_local_ctx_rename_user_name] +def renameUserName (lctx : LocalContext) (fromName : Name) (toName : Name) : LocalContext := +match lctx with +| { nameToDecl := map, decls := decls } => + match lctx.findFromUserName fromName with + | none => lctx + | some decl => + let decl := decl.updateUserName toName; + { nameToDecl := map.insert decl.name decl, + decls := decls.set decl.index decl } + +@[export lean_local_ctx_num_indices] +def numIndices (lctx : LocalContext) : Nat := +lctx.decls.size + +@[export lean_local_ctx_get] +def get! (lctx : LocalContext) (i : Nat) : Option LocalDecl := +lctx.decls.get! i + +section +universes u v +variables {m : Type u → Type v} [Monad m] +variable {β : Type u} + +@[specialize] def foldlM (lctx : LocalContext) (f : β → LocalDecl → m β) (b : β) : m β := +lctx.decls.foldlM (fun b decl => match decl with + | none => pure b + | some decl => f b decl) + b + +@[specialize] def forM (lctx : LocalContext) (f : LocalDecl → m β) : m PUnit := +lctx.decls.forM $ fun decl => match decl with + | none => pure PUnit.unit + | some decl => f decl *> pure PUnit.unit + +@[specialize] def findDeclM (lctx : LocalContext) (f : LocalDecl → m (Option β)) : m (Option β) := +lctx.decls.findM $ fun decl => match decl with + | none => pure none + | some decl => f decl + +@[specialize] def findDeclRevM (lctx : LocalContext) (f : LocalDecl → m (Option β)) : m (Option β) := +lctx.decls.findRevM $ fun decl => match decl with + | none => pure none + | some decl => f decl + +@[specialize] def foldlFromM (lctx : LocalContext) (f : β → LocalDecl → m β) (b : β) (decl : LocalDecl) : m β := +lctx.decls.foldlFromM (fun b decl => match decl with + | none => pure b + | some decl => f b decl) + b decl.index + +end + +@[inline] def foldl {β} (lctx : LocalContext) (f : β → LocalDecl → β) (b : β) : β := +Id.run $ lctx.foldlM f b + +@[inline] def findDecl {β} (lctx : LocalContext) (f : LocalDecl → Option β) : Option β := +Id.run $ lctx.findDeclM f + +@[inline] def findDeclRev {β} (lctx : LocalContext) (f : LocalDecl → Option β) : Option β := +Id.run $ lctx.findDeclRevM f + +@[inline] def foldlFrom {β} (lctx : LocalContext) (f : β → LocalDecl → β) (b : β) (decl : LocalDecl) : β := +Id.run $ lctx.foldlFromM f b decl + +partial def isSubPrefixOfAux (a₁ a₂ : PArray (Option LocalDecl)) : Nat → Nat → Bool +| i, j => + if i < a₁.size then + if j < a₂.size then + match a₁.get! i with + | none => isSubPrefixOfAux (i+1) j + | some decl₁ => + match a₂.get! j with + | none => isSubPrefixOfAux i (j+1) + | some decl₂ => + if decl₁.name == decl₂.name then isSubPrefixOfAux (i+1) (j+1) else isSubPrefixOfAux i (j+1) + else false + else true + +/- Given `lctx₁` of the form `(x_1 : A_1) ... (x_n : A_n)`, then return true + iff there is a local context `B_1* (x_1 : A_1) ... B_n* (x_n : A_n)` which is a prefix + of `lctx₂` where `B_i`'s are (possibly empty) sequences of local declarations. -/ +def isSubPrefixOf (lctx₁ lctx₂ : LocalContext) : Bool := +isSubPrefixOfAux lctx₁.decls lctx₂.decls 0 0 + +@[inline] def mkBinding (isLambda : Bool) (lctx : LocalContext) (xs : Array Expr) (b : Expr) : Expr := +let b := b.abstract xs; +xs.size.foldRev (fun i b => + let x := xs.get! i; + match lctx.findFVar x with + | some (LocalDecl.cdecl _ _ n ty bi) => + let ty := ty.abstractRange i xs; + if isLambda then + Lean.mkLambda n bi ty b + else + Lean.mkForall n bi ty b + | some (LocalDecl.ldecl _ _ n ty val) => + if b.hasLooseBVar 0 then + let ty := ty.abstractRange i xs; + let val := val.abstractRange i xs; + mkLet n ty val b + else + b + | none => panic! "unknown free variable") b + +def mkLambda (lctx : LocalContext) (xs : Array Expr) (b : Expr) : Expr := +mkBinding true lctx xs b + +def mkForall (lctx : LocalContext) (xs : Array Expr) (b : Expr) : Expr := +mkBinding false lctx xs b + +section +universes u +variables {m : Type → Type u} [Monad m] + +@[inline] def anyM (lctx : LocalContext) (p : LocalDecl → m Bool) : m Bool := +lctx.decls.anyM $ fun d => match d with + | some decl => p decl + | none => pure false + +@[inline] def allM (lctx : LocalContext) (p : LocalDecl → m Bool) : m Bool := +lctx.decls.allM $ fun d => match d with + | some decl => p decl + | none => pure true + +end + +@[inline] def any (lctx : LocalContext) (p : LocalDecl → Bool) : Bool := +Id.run $ lctx.anyM p + +@[inline] def all (lctx : LocalContext) (p : LocalDecl → Bool) : Bool := +Id.run $ lctx.allM p + +end LocalContext +end Lean diff --git a/stage0/src/Init/Lean/Message.lean b/stage0/src/Init/Lean/Message.lean new file mode 100644 index 0000000000..0f2be1e2c4 --- /dev/null +++ b/stage0/src/Init/Lean/Message.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sebastian Ullrich, Leonardo de Moura + +Message Type used by the Lean frontend +-/ +prelude +import Init.Data.ToString +import Init.Lean.Position +import Init.Lean.Syntax +import Init.Lean.MetavarContext +import Init.Lean.Environment + +namespace Lean +def mkErrorStringWithPos (fileName : String) (line col : Nat) (msg : String) : String := +fileName ++ ":" ++ toString line ++ ":" ++ toString col ++ " " ++ toString msg + +inductive MessageSeverity +| information | warning | error + +/- Structure message data. We use it for reporting errors, trace messages, etc. -/ +inductive MessageData +| ofFormat : Format → MessageData +| ofSyntax : Syntax → MessageData +| ofExpr : Expr → MessageData +| ofLevel : Level → MessageData +| ofName : Name → MessageData +/- `context env mctx lctx d` specifies the pretty printing context `(env, mctx, lctx)` for the nested expressions in `d`. -/ +| context : Environment → MetavarContext → LocalContext → MessageData → MessageData +/- Lifted `Format.nest` -/ +| nest : Nat → MessageData → MessageData +/- Lifted `Format.group` -/ +| group : MessageData → MessageData +/- Lifted `Format.compose` -/ +| compose : MessageData → MessageData → MessageData +/- Tagged sections. `Name` should be viewed as a "kind", and is used by `MessageData` inspector functions. + Example: an inspector that tries to find "definitional equality failures" may look for the tag "DefEqFailure". -/ +| tagged : Name → MessageData → MessageData +| node : Array MessageData → MessageData + +namespace MessageData + +instance : Inhabited MessageData := ⟨MessageData.ofFormat (arbitrary _)⟩ + +partial def formatAux : Option (Environment × MetavarContext × LocalContext) → MessageData → Format +| _, ofFormat fmt => fmt +| _, ofSyntax s => s.formatStx +| _, ofLevel u => fmt u +| _, ofName n => fmt n +| none, ofExpr e => format (toString e) +| some (env, mctx, lctx), ofExpr e => format (toString e) -- TODO: invoke pretty printer +| _, context env mctx lctx d => formatAux (some (env, mctx, lctx)) d +| ctx, tagged cls d => Format.sbracket (format cls) ++ " " ++ formatAux ctx d +| ctx, nest n d => Format.nest n (formatAux ctx d) +| ctx, compose d₁ d₂ => formatAux ctx d₁ ++ formatAux ctx d₂ +| ctx, group d => Format.group (formatAux ctx d) +| ctx, node ds => Format.nest 2 $ ds.foldl (fun r d => r ++ Format.line ++ formatAux ctx d) Format.nil + +instance : HasAppend MessageData := ⟨compose⟩ + +instance : HasFormat MessageData := ⟨fun d => formatAux none d⟩ + +instance coeOfFormat : HasCoe Format MessageData := ⟨ofFormat⟩ +instance coeOfLevel : HasCoe Level MessageData := ⟨ofLevel⟩ +instance coeOfExpr : HasCoe Expr MessageData := ⟨ofExpr⟩ +instance coeOfName : HasCoe Name MessageData := ⟨ofName⟩ + +partial def arrayExpr.toMessageData (es : Array Expr) : Nat → MessageData → MessageData +| i, acc => + if h : i < es.size then + let e := es.get ⟨i, h⟩; + let acc := if i == 0 then acc ++ ofExpr e else acc ++ ", " ++ ofExpr e; + arrayExpr.toMessageData (i+1) acc + else + acc ++ "]" + +instance coeOfArrayExpr : HasCoe (Array Expr) MessageData := ⟨fun es => arrayExpr.toMessageData es 0 "#["⟩ + +end MessageData + +structure Message := +(fileName : String) +(pos : Position) +(endPos : Option Position := none) +(severity : MessageSeverity := MessageSeverity.error) +(caption : String := "") +(data : MessageData) + +namespace Message + +protected def toString (msg : Message) : String := +mkErrorStringWithPos msg.fileName msg.pos.line msg.pos.column + ((match msg.severity with + | MessageSeverity.information => "" + | MessageSeverity.warning => "warning: " + | MessageSeverity.error => "error: ") ++ + (if msg.caption == "" then "" else msg.caption ++ ":\n") ++ toString (fmt msg.data)) + +instance : Inhabited Message := +⟨{ fileName := "", pos := ⟨0, 1⟩, data := arbitrary _}⟩ + +instance : HasToString Message := +⟨Message.toString⟩ +end Message + +structure MessageLog := +-- messages are stored in reverse for efficient append +(revList : List Message := []) + +namespace MessageLog +def empty : MessageLog := ⟨{}⟩ + +def isEmpty (log : MessageLog) : Bool := +log.revList.isEmpty + +instance : Inhabited MessageLog := ⟨{}⟩ + +def add (msg : Message) (log : MessageLog) : MessageLog := +⟨msg :: log.revList⟩ + +protected def append (l₁ l₂ : MessageLog) : MessageLog := +⟨l₂.revList ++ l₁.revList⟩ + +instance : HasAppend MessageLog := +⟨MessageLog.append⟩ + +def hasErrors (log : MessageLog) : Bool := +log.revList.any $ fun m => match m.severity with +| MessageSeverity.error => true +| _ => false + +def toList (log : MessageLog) : List Message := +log.revList.reverse +end MessageLog +end Lean diff --git a/stage0/src/Init/Lean/Meta.lean b/stage0/src/Init/Lean/Meta.lean new file mode 100644 index 0000000000..0edb61a761 --- /dev/null +++ b/stage0/src/Init/Lean/Meta.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Meta.Basic +import Init.Lean.Meta.LevelDefEq +import Init.Lean.Meta.WHNF +import Init.Lean.Meta.InferType +import Init.Lean.Meta.FunInfo +import Init.Lean.Meta.ExprDefEq diff --git a/stage0/src/Init/Lean/Meta/Basic.lean b/stage0/src/Init/Lean/Meta/Basic.lean new file mode 100644 index 0000000000..280ce0060f --- /dev/null +++ b/stage0/src/Init/Lean/Meta/Basic.lean @@ -0,0 +1,613 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Reader +import Init.Lean.NameGenerator +import Init.Lean.Environment +import Init.Lean.LOption +import Init.Lean.Trace +import Init.Lean.Class +import Init.Lean.ReducibilityAttrs +import Init.Lean.Meta.Exception + +/- +This module provides four (mutually dependent) goodies that are needed for building the elaborator and tactic frameworks. +1- Weak head normal form computation with support for metavariables and transparency modes. +2- Definitionally equality checking with support for metavariables (aka unification modulo definitional equality). +3- Type inference. +4- Type class resolution. + +They are packed into the MetaM monad. +-/ + +namespace Lean +namespace Meta + +inductive TransparencyMode +| all | default | reducible + +namespace TransparencyMode +instance : Inhabited TransparencyMode := ⟨TransparencyMode.default⟩ + +def beq : TransparencyMode → TransparencyMode → Bool +| all, all => true +| default, default => true +| reducible, reducible => true +| _, _ => false + +instance : HasBeq TransparencyMode := ⟨beq⟩ + +def hash : TransparencyMode → USize +| all => 7 +| default => 11 +| reducible => 13 + +instance : Hashable TransparencyMode := ⟨hash⟩ + +def lt : TransparencyMode → TransparencyMode → Bool +| reducible, default => true +| reducible, all => true +| default, all => true +| _, _ => false + +end TransparencyMode + +structure LocalInstance := +(className : Name) +(fvar : Expr) + +abbrev LocalInstances := Array LocalInstance + +structure Config := +(opts : Options := {}) +-- TODO: merge all *Approx flags. +(foApprox : Bool := false) +(ctxApprox : Bool := false) +(quasiPatternApprox : Bool := false) +/- + When the following flag is set, + `isDefEq` throws the exeption `Exeption.isDefEqStuck` + whenever it encounters a constraint `?m ... =?= t` where + `?m` is read only. + This feature is useful for type class resolution where + we may want to notify the caller that the TC problem may be solveable + later after it assigns `?m`. -/ +(isDefEqStuckEx : Bool := false) +(debug : Bool := false) +(transparency : TransparencyMode := TransparencyMode.default) + +structure ParamInfo := +(implicit : Bool := false) +(instImplicit : Bool := false) +(prop : Bool := false) +(hasFwdDeps : Bool := false) +(backDeps : Array Nat := #[]) + +instance ParamInfo.inhabited : Inhabited ParamInfo := ⟨{}⟩ + +structure FunInfo := +(paramInfo : Array ParamInfo := #[]) +(resultDeps : Array Nat := #[]) + +structure InfoCacheKey := +(transparency : TransparencyMode) +(expr : Expr) +(nargs? : Option Nat) + +namespace InfoCacheKey +instance : Inhabited InfoCacheKey := ⟨⟨arbitrary _, arbitrary _, arbitrary _⟩⟩ +instance : Hashable InfoCacheKey := +⟨fun ⟨transparency, expr, nargs⟩ => mixHash (hash transparency) $ mixHash (hash expr) (hash nargs)⟩ +instance : HasBeq InfoCacheKey := +⟨fun ⟨t₁, e₁, n₁⟩ ⟨t₂, e₂, n₂⟩ => t₁ == t₂ && n₁ == n₂ && e₁ == e₂⟩ +end InfoCacheKey + +structure Cache := +(inferType : PersistentExprStructMap Expr := {}) +(funInfo : PersistentHashMap InfoCacheKey FunInfo := {}) + +structure Context := +(config : Config := {}) +(lctx : LocalContext := {}) +(localInstances : LocalInstances := #[]) + +structure PostponedEntry := +(lhs : Level) +(rhs : Level) + +structure State := +(env : Environment) +(mctx : MetavarContext := {}) +(cache : Cache := {}) +(ngen : NameGenerator := {}) +(traceState : TraceState := {}) +(postponed : PersistentArray PostponedEntry := {}) + +abbrev MetaM := ReaderT Context (EStateM Exception State) + +instance MetaM.inhabited {α} : Inhabited (MetaM α) := +⟨fun c s => EStateM.Result.error (arbitrary _) s⟩ + +@[inline] def getLCtx : MetaM LocalContext := +do ctx ← read; pure ctx.lctx + +@[inline] def getConfig : MetaM Config := +do ctx ← read; pure ctx.config + +@[inline] def getMCtx : MetaM MetavarContext := +do s ← get; pure s.mctx + +@[inline] def getEnv : MetaM Environment := +do s ← get; pure s.env + +def mkWHNFRef : IO (IO.Ref (Expr → MetaM Expr)) := +IO.mkRef $ fun _ => throw $ Exception.other "whnf implementation was not set" + +@[init mkWHNFRef] def whnfRef : IO.Ref (Expr → MetaM Expr) := arbitrary _ + +def mkInferTypeRef : IO (IO.Ref (Expr → MetaM Expr)) := +IO.mkRef $ fun _ => throw $ Exception.other "inferType implementation was not set" + +@[init mkInferTypeRef] def inferTypeRef : IO.Ref (Expr → MetaM Expr) := arbitrary _ + +def mkIsExprDefEqAuxRef : IO (IO.Ref (Expr → Expr → MetaM Bool)) := +IO.mkRef $ fun _ _ => throw $ Exception.other "isDefEq implementation was not set" + +@[init mkIsExprDefEqAuxRef] def isExprDefEqAuxRef : IO.Ref (Expr → Expr → MetaM Bool) := arbitrary _ + +def mkSynthPendingRef : IO (IO.Ref (Expr → MetaM Bool)) := +IO.mkRef $ fun _ => pure false + +@[init mkSynthPendingRef] def synthPendingRef : IO.Ref (Expr → MetaM Bool) := arbitrary _ + +structure MetaExtState := +(whnf : Expr → MetaM Expr) +(inferType : Expr → MetaM Expr) +(isDefEqAux : Expr → Expr → MetaM Bool) +(synthPending : Expr → MetaM Bool) + +instance MetaExtState.inhabited : Inhabited MetaExtState := +⟨{ whnf := arbitrary _, inferType := arbitrary _, isDefEqAux := arbitrary _, synthPending := arbitrary _ }⟩ + +def mkMetaExtension : IO (EnvExtension MetaExtState) := +registerEnvExtension $ do + whnf ← whnfRef.get; + inferType ← inferTypeRef.get; + isDefEqAux ← isExprDefEqAuxRef.get; + synthPending ← synthPendingRef.get; + pure { whnf := whnf, inferType := inferType, isDefEqAux := isDefEqAux, synthPending := synthPending } + +@[init mkMetaExtension] +constant metaExt : EnvExtension MetaExtState := arbitrary _ + +def whnf (e : Expr) : MetaM Expr := +do env ← getEnv; + (metaExt.getState env).whnf e + +def inferType (e : Expr) : MetaM Expr := +do env ← getEnv; + (metaExt.getState env).inferType e + +def isExprDefEqAux (t s : Expr) : MetaM Bool := +do env ← getEnv; + (metaExt.getState env).isDefEqAux t s + +def synthPending (e : Expr) : MetaM Bool := +do env ← getEnv; + (metaExt.getState env).synthPending e + +def mkFreshId : MetaM Name := +do s ← get; + let id := s.ngen.curr; + modify $ fun s => { ngen := s.ngen.next, .. s }; + pure id + +def mkFreshExprMVarAt (lctx : LocalContext) (type : Expr) (userName : Name := Name.anonymous) (synthetic : Bool := false) : MetaM Expr := +do mvarId ← mkFreshId; + modify $ fun s => { mctx := s.mctx.addExprMVarDecl mvarId userName lctx type synthetic, .. s }; + pure $ mkMVar mvarId + +def mkFreshExprMVar (type : Expr) (userName : Name := Name.anonymous) (synthetic : Bool := false) : MetaM Expr := +do lctx ← getLCtx; + mkFreshExprMVarAt lctx type userName synthetic + +def mkFreshLevelMVar : MetaM Level := +do mvarId ← mkFreshId; + modify $ fun s => { mctx := s.mctx.addLevelMVarDecl mvarId, .. s}; + pure $ mkLevelMVar mvarId + +@[inline] def throwEx {α} (f : ExceptionContext → Exception) : MetaM α := +do ctx ← read; + s ← get; + throw (f {env := s.env, mctx := s.mctx, lctx := ctx.lctx }) + +def throwBug {α} (b : Bug) : MetaM α := +throwEx $ Exception.bug b + +/-- Execute `x` only in debugging mode. -/ +@[inline] private def whenDebugging {α} (x : MetaM α) : MetaM Unit := +do ctx ← read; + when ctx.config.debug (do x; pure ()) + +@[inline] def reduceAll? : MetaM Bool := +do ctx ← read; pure $ ctx.config.transparency == TransparencyMode.all + +@[inline] def reduceReducibleOnly? : MetaM Bool := +do ctx ← read; pure $ ctx.config.transparency == TransparencyMode.reducible + +@[inline] def getTransparency : MetaM TransparencyMode := +do ctx ← read; pure $ ctx.config.transparency + +@[inline] private def getOptions : MetaM Options := +do ctx ← read; pure ctx.config.opts + +-- Remark: wanted to use `private`, but in C++ parser, `private` declarations do not shadow outer public ones. +-- TODO: fix this bug +@[inline] def isReducible (constName : Name) : MetaM Bool := +do env ← getEnv; pure $ isReducible env constName + +/-- While executing `x`, ensure the given transparency mode is used. -/ +@[inline] def usingTransparency {α} (mode : TransparencyMode) (x : MetaM α) : MetaM α := +adaptReader + (fun (ctx : Context) => { config := { transparency := mode, .. ctx.config }, .. ctx }) + x + +@[inline] def usingAtLeastTransparency {α} (mode : TransparencyMode) (x : MetaM α) : MetaM α := +adaptReader + (fun (ctx : Context) => + let oldMode := ctx.config.transparency; + let mode := if oldMode.lt mode then mode else oldMode; + { config := { transparency := mode, .. ctx.config }, .. ctx }) + x + +def isSyntheticExprMVar (mvarId : Name) : MetaM Bool := +do mctx ← getMCtx; + match mctx.findDecl mvarId with + | some d => pure $ d.synthetic + | _ => throwEx $ Exception.unknownExprMVar mvarId + +def isReadOnlyOrSyntheticExprMVar (mvarId : Name) : MetaM Bool := +do mctx ← getMCtx; + match mctx.findDecl mvarId with + | some d => pure $ d.synthetic || d.depth != mctx.depth + | _ => throwEx $ Exception.unknownExprMVar mvarId + +def isReadOnlyLevelMVar (mvarId : Name) : MetaM Bool := +do mctx ← getMCtx; + match mctx.findLevelDepth mvarId with + | some depth => pure $ depth != mctx.depth + | _ => throwEx $ Exception.unknownLevelMVar mvarId + +@[inline] def isExprMVarAssigned (mvarId : Name) : MetaM Bool := +do mctx ← getMCtx; + pure $ mctx.isExprAssigned mvarId + +@[inline] def getExprMVarAssignment (mvarId : Name) : MetaM (Option Expr) := +do mctx ← getMCtx; pure (mctx.getExprAssignment mvarId) + +def assignExprMVar (mvarId : Name) (val : Expr) : MetaM Unit := +do whenDebugging $ whenM (isExprMVarAssigned mvarId) $ throwBug $ Bug.overwritingExprMVar mvarId; + modify $ fun s => { mctx := s.mctx.assignExpr mvarId val, .. s } + +def dbgTrace {α} [HasToString α] (a : α) : MetaM Unit := +_root_.dbgTrace (toString a) $ fun _ => pure () + +@[inline] private def getTraceState : MetaM TraceState := +do s ← get; pure s.traceState + +instance tracer : SimpleMonadTracerAdapter MetaM := +{ getOptions := getOptions, + getTraceState := getTraceState, + modifyTraceState := fun f => modify $ fun s => { traceState := f s.traceState, .. s } } + +def getConstAux (constName : Name) (exception? : Bool) : MetaM (Option ConstantInfo) := +do env ← getEnv; + match env.find constName with + | some (info@(ConstantInfo.thmInfo _)) => + condM reduceAll? (pure (some info)) (pure none) + | some info => + condM reduceReducibleOnly? + (condM (isReducible constName) (pure (some info)) (pure none)) + (pure (some info)) + | none => + if exception? then throwEx $ Exception.unknownConst constName + else pure none + +@[inline] def getConst (constName : Name) : MetaM (Option ConstantInfo) := +getConstAux constName true + +@[inline] def getConstNoEx (constName : Name) : MetaM (Option ConstantInfo) := +getConstAux constName false + +def getLocalDecl (fvarId : Name) : MetaM LocalDecl := +do lctx ← getLCtx; + match lctx.find fvarId with + | some d => pure d + | none => throwEx $ Exception.unknownFVar fvarId + +def getFVarLocalDecl (fvar : Expr) : MetaM LocalDecl := +getLocalDecl fvar.fvarId! + +def getMVarDecl (mvarId : Name) : MetaM MetavarDecl := +do mctx ← getMCtx; + match mctx.findDecl mvarId with + | some d => pure d + | none => throwEx $ Exception.unknownExprMVar mvarId + +def instantiateMVars (e : Expr) : MetaM Expr := +if e.hasMVar then + modifyGet $ fun s => + let (e, mctx) := s.mctx.instantiateMVars e; + (e, { mctx := mctx, .. s }) +else + pure e + +@[inline] private def liftMkBindingM {α} (x : MetavarContext.MkBindingM α) : MetaM α := +fun ctx s => + match x ctx.lctx { mctx := s.mctx, ngen := s.ngen } with + | EStateM.Result.ok e newS => + EStateM.Result.ok e { mctx := newS.mctx, ngen := newS.ngen, .. s} + | EStateM.Result.error (MetavarContext.MkBinding.Exception.readOnlyMVar mctx mvarId) newS => + EStateM.Result.error + (Exception.readOnlyMVar mvarId { lctx := ctx.lctx, mctx := newS.mctx, env := s.env }) + { mctx := newS.mctx, ngen := newS.ngen, .. s } + | EStateM.Result.error (MetavarContext.MkBinding.Exception.revertFailure mctx lctx toRevert decl) newS => + EStateM.Result.error + (Exception.revertFailure toRevert decl { lctx := lctx, mctx := mctx, env := s.env }) + { mctx := newS.mctx, ngen := newS.ngen, .. s } + +def mkForall (xs : Array Expr) (e : Expr) : MetaM Expr := +if xs.isEmpty then pure e else liftMkBindingM $ MetavarContext.mkForall xs e + +def mkLambda (xs : Array Expr) (e : Expr) : MetaM Expr := +if xs.isEmpty then pure e else liftMkBindingM $ MetavarContext.mkLambda xs e + +/-- Save cache, execute `x`, restore cache -/ +@[inline] def savingCache {α} (x : MetaM α) : MetaM α := +do s ← get; + let savedCache := s.cache; + finally x (modify $ fun s => { cache := savedCache, .. s }) + +def isClassQuickConst (constName : Name) : MetaM (LOption Name) := +do env ← getEnv; + if isClass env constName then + pure (LOption.some constName) + else do + cinfo? ← getConst constName; + match cinfo? with + | some _ => pure LOption.undef + | none => pure LOption.none + +partial def isClassQuick : Expr → MetaM (LOption Name) +| Expr.bvar _ _ => pure LOption.none +| Expr.lit _ _ => pure LOption.none +| Expr.fvar _ _ => pure LOption.none +| Expr.sort _ _ => pure LOption.none +| Expr.lam _ _ _ _ => pure LOption.none +| Expr.letE _ _ _ _ _ => pure LOption.undef +| Expr.proj _ _ _ _ => pure LOption.undef +| Expr.forallE _ _ b _ => isClassQuick b +| Expr.mdata _ e _ => isClassQuick e +| Expr.const n _ _ => isClassQuickConst n +| Expr.mvar mvarId _ => do + val? ← getExprMVarAssignment mvarId; + match val? with + | some val => isClassQuick val + | none => pure LOption.none +| Expr.app f _ _ => + match f.getAppFn with + | Expr.const n _ _ => isClassQuickConst n + | Expr.lam _ _ _ _ => pure LOption.undef + | _ => pure LOption.none +| Expr.localE _ _ _ _ => unreachable! + +/-- Reset type class cache, execute `x`, and restore cache -/ +@[inline] def resettingTypeClassCache {α} (x : MetaM α) : MetaM α := +x -- TODO + +/-- Add entry `{ className := className, fvar := fvar }` to localInstances, + and then execute continuation `k`. + It resets the type class cache using `resettingTypeClassCache`. -/ +@[inline] def withNewLocalInstance {α} (className : Name) (fvar : Expr) (k : MetaM α) : MetaM α := +resettingTypeClassCache $ + adaptReader + (fun (ctx : Context) => { + localInstances := ctx.localInstances.push { className := className, fvar := fvar }, + .. ctx }) + k + +/-- + `withNewLocalInstances isClassExpensive fvars j k` updates the vector or local instances + using free variables `fvars[j] ... fvars.back`, and execute `k`. + + - `isClassExpensive` is defined later. + - The type class chache is reset whenever a new local instance is found. + - `isClassExpensive` uses `whnf` which depends (indirectly) on the set of local instances. + Thus, each new local instance requires a new `resettingTypeClassCache`. -/ +@[specialize] partial def withNewLocalInstances {α} + (isClassExpensive : Expr → MetaM (Option Name)) + (fvars : Array Expr) : Nat → MetaM α → MetaM α +| i, k => + if h : i < fvars.size then do + let fvar := fvars.get ⟨i, h⟩; + decl ← getFVarLocalDecl fvar; + c? ← isClassQuick decl.type; + match c? with + | LOption.none => withNewLocalInstances (i+1) k + | LOption.undef => do + c? ← isClassExpensive decl.type; + match c? with + | none => withNewLocalInstances (i+1) k + | some c => withNewLocalInstance c fvar $ withNewLocalInstances (i+1) k + | LOption.some c => withNewLocalInstance c fvar $ withNewLocalInstances (i+1) k + else + k + +/-- + `forallTelescopeAux whnf k lctx fvars j type` + Remarks: + - `lctx` is the `MetaM` local context exteded with the declaration for `fvars`. + - `type` is the type we are computing the telescope for. It contains only + dangling bound variables in the range `[j, fvars.size)` + - if `reducing? == true` and `type` is not `forallE`, we use `whnf`. + - when `type` is not a `forallE` nor it can't be reduced to one, we + excute the continuation `k`. + + Here is an example that demonstrates the `reducing?`. + Suppose we have + ``` + abbrev StateM s a := s -> Prod a s + ``` + Now, assume we are trying to build the telescope for + ``` + forall (x : Nat), StateM Int Bool + ``` + if `reducing? == true`, the function executes `k #[(x : Nat) (s : Int)] Bool`. + if `reducing? == false`, the function executes `k #[(x : Nat)] (StateM Int Bool)` + + if `maxFVars?` is `some max`, then we interrupt the telescope construction + when `fvars.size == max` +-/ +@[specialize] private partial def forallTelescopeReducingAuxAux {α} + (isClassExpensive : Expr → MetaM (Option Name)) + (reducing? : Bool) (maxFVars? : Option Nat) + (k : Array Expr → Expr → MetaM α) + : LocalContext → Array Expr → Nat → Expr → MetaM α +| lctx, fvars, j, Expr.forallE n d b c => do + let d := d.instantiateRevRange j fvars.size fvars; + fvarId ← mkFreshId; + let lctx := lctx.mkLocalDecl fvarId n d c.binderInfo; + let fvar := mkFVar fvarId; + let fvars := fvars.push fvar; + match maxFVars? with + | none => forallTelescopeReducingAuxAux lctx fvars j b + | some maxFVars => + if fvars.size < maxFVars then + forallTelescopeReducingAuxAux lctx fvars j b + else + let type := b.instantiateRevRange j fvars.size fvars; + adaptReader (fun (ctx : Context) => { lctx := lctx, .. ctx }) $ + withNewLocalInstances isClassExpensive fvars j $ + k fvars type +| lctx, fvars, j, type => + let type := type.instantiateRevRange j fvars.size fvars; + adaptReader (fun (ctx : Context) => { lctx := lctx, .. ctx }) $ + withNewLocalInstances isClassExpensive fvars j $ + if reducing? then do + newType ← whnf type; + if newType.isForall then + forallTelescopeReducingAuxAux lctx fvars fvars.size newType + else + k fvars type + else + k fvars type + +/- We need this auxiliary definition because it depends on `isClassExpensive`, + and `isClassExpensive` depends on it. -/ +@[specialize] private def forallTelescopeReducingAux {α} + (isClassExpensive : Expr → MetaM (Option Name)) + (type : Expr) (maxFVars? : Option Nat) (k : Array Expr → Expr → MetaM α) : MetaM α := +do newType ← whnf type; + if newType.isForall then + savingCache $ do + lctx ← getLCtx; + forallTelescopeReducingAuxAux isClassExpensive true maxFVars? k lctx #[] 0 newType + else + k #[] type + +partial def isClassExpensive : Expr → MetaM (Option Name) +| type => usingTransparency TransparencyMode.reducible $ -- when testing whether a type is a type class, we only unfold reducible constants. + forallTelescopeReducingAux isClassExpensive type none $ fun xs type => do + match type.getAppFn with + | Expr.const c _ _ => do + env ← getEnv; + pure $ if isClass env c then some c else none + | _ => pure none + +/-- + Given `type` of the form `forall xs, A`, execute `k xs A`. + This combinator will declare local declarations, create free variables for them, + execute `k` with updated local context, and make sure the cache is restored after executing `k`. -/ +@[inline] def forallTelescope {α} (type : Expr) (k : Array Expr → Expr → MetaM α) : MetaM α := +savingCache $ do + lctx ← getLCtx; + forallTelescopeReducingAuxAux isClassExpensive false none k lctx #[] 0 type + +/-- + Similar to `forallTelescope`, but given `type` of the form `forall xs, A`, + it reduces `A` and continues bulding the telescope if it is a `forall`. -/ +@[inline] def forallTelescopeReducing {α} (type : Expr) (k : Array Expr → Expr → MetaM α) : MetaM α := +forallTelescopeReducingAux isClassExpensive type none k + +/-- + Similar to `forallTelescopeReducing`, stops constructing the telescope when + it reaches size `maxFVars`. -/ +@[inline] def forallBoundedTelescope {α} (type : Expr) (maxFVars? : Option Nat) (k : Array Expr → Expr → MetaM α) : MetaM α := +forallTelescopeReducingAux isClassExpensive type maxFVars? k + +def isClass (type : Expr) : MetaM (Option Name) := +do c? ← isClassQuick type; + match c? with + | LOption.none => pure none + | LOption.some c => pure (some c) + | LOption.undef => isClassExpensive type + +/-- Similar to `forallTelescopeAuxAux` but for lambda and let expressions. -/ +@[specialize] private partial def lambdaTelescopeAux {α} + (k : Array Expr → Expr → MetaM α) + : LocalContext → Array Expr → Nat → Expr → MetaM α +| lctx, fvars, j, Expr.lam n d b c => do + let d := d.instantiateRevRange j fvars.size fvars; + fvarId ← mkFreshId; + let lctx := lctx.mkLocalDecl fvarId n d c.binderInfo; + let fvar := mkFVar fvarId; + lambdaTelescopeAux lctx (fvars.push fvar) j b +| lctx, fvars, j, Expr.letE n t v b _ => do + let t := t.instantiateRevRange j fvars.size fvars; + let v := v.instantiateRevRange j fvars.size fvars; + fvarId ← mkFreshId; + let lctx := lctx.mkLetDecl fvarId n t v; + let fvar := mkFVar fvarId; + lambdaTelescopeAux lctx (fvars.push fvar) j b +| lctx, fvars, j, e => + let e := e.instantiateRevRange j fvars.size fvars; + adaptReader (fun (ctx : Context) => { lctx := lctx, .. ctx }) $ + withNewLocalInstances isClassExpensive fvars j $ do + k fvars e + +/-- Similar to `forallTelescope` but for lambda and let expressions. -/ +@[specialize] def lambdaTelescope {α} + (e : Expr) (k : Array Expr → Expr → MetaM α) : MetaM α := +savingCache $ do + lctx ← getLCtx; + lambdaTelescopeAux k lctx #[] 0 e + +@[inline] def liftStateMCtx {α} (x : StateM MetavarContext α) : MetaM α := +fun _ s => + let (a, mctx) := x.run s.mctx; + EStateM.Result.ok a { mctx := mctx, .. s } + +def instantiateLevelMVars (lvl : Level) : MetaM Level := +liftStateMCtx $ MetavarContext.instantiateLevelMVars lvl + +def assignLevelMVar (mvarId : Name) (lvl : Level) : MetaM Unit := +modify $ fun s => { mctx := MetavarContext.assignLevel s.mctx mvarId lvl, .. s } + +def mkFreshLevelMVarId : MetaM Name := +do mvarId ← mkFreshId; + modify $ fun s => { mctx := s.mctx.addLevelMVarDecl mvarId, .. s }; + pure mvarId + +def whnfUsingDefault : Expr → MetaM Expr := +fun e => usingTransparency TransparencyMode.default $ whnf e + +/-- Execute `x` using approximate unification. -/ +@[inline] def approxDefEq {α} (x : MetaM α) : MetaM α := +adaptReader (fun (ctx : Context) => { config := { foApprox := true, ctxApprox := true, quasiPatternApprox := true, .. ctx.config }, .. ctx }) + x + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/Check.lean b/stage0/src/Init/Lean/Meta/Check.lean new file mode 100644 index 0000000000..9a2c475c8d --- /dev/null +++ b/stage0/src/Init/Lean/Meta/Check.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Meta.InferType + +/- +This is not the Kernel type checker, but an auxiliary method for checking +whether terms produced by tactics and `isDefEq` are type correct. +-/ + +namespace Lean +namespace Meta + +private def ensureType (e : Expr) : MetaM Unit := +do getLevel e; pure () + +@[specialize] private def checkLambdaLet + (check : Expr → MetaM Unit) + (e : Expr) : MetaM Unit := +lambdaTelescope e $ fun xs b => do + xs.forM $ fun x => do { + xDecl ← getFVarLocalDecl x; + match xDecl with + | LocalDecl.cdecl _ _ _ t _ => do + ensureType t; + check t + | LocalDecl.ldecl _ _ _ t v => do + ensureType t; + check t; + vType ← inferType v; + unlessM (isExprDefEqAux t vType) $ throwEx $ Exception.letTypeMismatch x.fvarId!; + check v + }; + check b + +@[specialize] private def checkForall + (check : Expr → MetaM Unit) + (e : Expr) : MetaM Unit := +forallTelescope e $ fun xs b => do + xs.forM $ fun x => do { + xDecl ← getFVarLocalDecl x; + ensureType xDecl.type; + check xDecl.type + }; + ensureType b; + check b + +private def checkConstant (c : Name) (lvls : List Level) : MetaM Unit := +do env ← getEnv; + match env.find c with + | none => throwEx $ Exception.unknownConst c + | some cinfo => unless (lvls.length == cinfo.lparams.length) $ throwEx $ Exception.incorrectNumOfLevels c lvls + +@[specialize] private def checkApp + (check : Expr → MetaM Unit) + (f a : Expr) : MetaM Unit := +do check f; + check a; + fType ← inferType f; + fType ← whnf fType; + match fType with + | Expr.forallE _ d _ _ => do + aType ← inferType a; + unlessM (isExprDefEqAux d aType) $ throwEx $ Exception.appTypeMismatch f a + | _ => unless fType.isForall $ throwEx $ Exception.functionExpected f a + +private partial def checkAux : Expr → MetaM Unit +| e@(Expr.forallE _ _ _ _) => checkForall checkAux e +| e@(Expr.lam _ _ _ _) => checkLambdaLet checkAux e +| e@(Expr.letE _ _ _ _ _) => checkLambdaLet checkAux e +| Expr.const c lvls _ => checkConstant c lvls +| Expr.app f a _ => checkApp checkAux f a +| Expr.mdata _ e _ => checkAux e +| Expr.proj _ _ e _ => checkAux e +| _ => pure () + +def check (e : Expr) : MetaM Unit := +traceCtx `Meta.check $ + usingTransparency TransparencyMode.all $ checkAux e + +def isTypeCorrect (e : Expr) : MetaM Bool := +catch + (traceCtx `Meta.check $ do checkAux e; pure true) + (fun ex => do + trace! `Meta.typeError ex.toMessageData; + pure false) + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/Exception.lean b/stage0/src/Init/Lean/Meta/Exception.lean new file mode 100644 index 0000000000..d9dead3c64 --- /dev/null +++ b/stage0/src/Init/Lean/Meta/Exception.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment +import Init.Lean.Message +import Init.Lean.MetavarContext + +namespace Lean +namespace Meta + +structure ExceptionContext := +(env : Environment) (mctx : MetavarContext) (lctx : LocalContext) + +inductive Bug +| overwritingExprMVar (mvarId : Name) + +inductive Exception +| unknownConst (constName : Name) (ctx : ExceptionContext) +| unknownFVar (fvarId : Name) (ctx : ExceptionContext) +| unknownExprMVar (mvarId : Name) (ctx : ExceptionContext) +| unknownLevelMVar (mvarId : Name) (ctx : ExceptionContext) +| unexpectedBVar (bvarIdx : Nat) +| functionExpected (f a : Expr) (ctx : ExceptionContext) +| typeExpected (type : Expr) (ctx : ExceptionContext) +| incorrectNumOfLevels (constName : Name) (constLvls : List Level) (ctx : ExceptionContext) +| invalidProjection (structName : Name) (idx : Nat) (s : Expr) (ctx : ExceptionContext) +| revertFailure (toRevert : Array Expr) (decl : LocalDecl) (ctx : ExceptionContext) +| readOnlyMVar (mvarId : Name) (ctx : ExceptionContext) +| isDefEqStuck (t s : Expr) (ctx : ExceptionContext) +| letTypeMismatch (fvarId : Name) (ctx : ExceptionContext) +| appTypeMismatch (f a : Expr) (ctx : ExceptionContext) +| bug (b : Bug) (ctx : ExceptionContext) +| other (msg : String) + +namespace Exception +instance : Inhabited Exception := ⟨other ""⟩ + +-- TODO: improve, use (to be implemented) pretty printer +def toStr : Exception → String +| unknownConst c _ => "unknown constant '" ++ toString c ++ "'" +| unknownFVar fvarId _ => "unknown free variable '" ++ toString fvarId ++ "'" +| unknownExprMVar mvarId _ => "unknown metavariable '" ++ toString mvarId ++ "'" +| unknownLevelMVar mvarId _ => "unknown universe level metavariable '" ++ toString mvarId ++ "'" +| unexpectedBVar bvarIdx => "unexpected loose bound variable #" ++ toString bvarIdx +| functionExpected fType args _ => "function expected" +| typeExpected _ _ => "type expected" +| incorrectNumOfLevels c lvls _ => "incorrect number of universe levels for '" ++ toString c ++ "' " ++ toString lvls +| invalidProjection _ _ _ _ => "invalid projection" +| revertFailure _ _ _ => "revert failure" +| readOnlyMVar _ _ => "try to assign read only metavariable" +| isDefEqStuck _ _ _ => "isDefEq is stuck" +| letTypeMismatch _ _ => "type mismatch at let-expression" +| appTypeMismatch _ _ _ => "application type mismatch" +| bug _ _ => "bug" +| other s => s + +instance : HasToString Exception := ⟨toStr⟩ + +private def mkCtx (c : ExceptionContext) (m : MessageData) : MessageData := +MessageData.context c.env c.mctx c.lctx m + +def toMessageData : Exception → MessageData +| unknownConst c ctx => mkCtx ctx $ `unknownConst ++ " " ++ c +| unknownFVar fvarId ctx => mkCtx ctx $ `unknownFVar ++ " " ++ fvarId +| unknownExprMVar mvarId ctx => mkCtx ctx $ `unknownExprMVar ++ " " ++ mkMVar mvarId +| unknownLevelMVar mvarId ctx => mkCtx ctx $ `unknownLevelMVar ++ " " ++ mkLevelMVar mvarId +| unexpectedBVar bvarIdx => `unexpectedBVar ++ " " ++ mkBVar bvarIdx +| functionExpected f a ctx => mkCtx ctx $ `functionExpected ++ " " ++ mkApp f a +| typeExpected t ctx => mkCtx ctx $ `typeExpected ++ " " ++ t +| incorrectNumOfLevels c lvls ctx => mkCtx ctx $ `incorrectNumOfLevels ++ " " ++ mkConst c lvls +| invalidProjection s i e ctx => mkCtx ctx $ `invalidProjection ++ " " ++ mkProj s i e +| revertFailure xs decl ctx => mkCtx ctx $ `revertFailure -- TODO improve +| readOnlyMVar mvarId ctx => mkCtx ctx $ `readOnlyMVar ++ " " ++ mkMVar mvarId +| isDefEqStuck t s ctx => mkCtx ctx $ `isDefEqStuck ++ " " ++ t ++ " =?= " ++ s +| letTypeMismatch fvarId ctx => mkCtx ctx $ `letTypeMismatch ++ " " ++ mkFVar fvarId +| appTypeMismatch f a ctx => mkCtx ctx $ `appTypeMismatch ++ " " ++ mkApp f a +| bug _ _ => "internal bug" -- TODO improve +| other s => s + +end Exception + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/ExprDefEq.lean b/stage0/src/Init/Lean/Meta/ExprDefEq.lean new file mode 100644 index 0000000000..fd7f22dfb1 --- /dev/null +++ b/stage0/src/Init/Lean/Meta/ExprDefEq.lean @@ -0,0 +1,1005 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.ProjFns +import Init.Lean.Meta.WHNF +import Init.Lean.Meta.InferType +import Init.Lean.Meta.FunInfo +import Init.Lean.Meta.LevelDefEq +import Init.Lean.Meta.Check +import Init.Lean.Meta.Offset + +namespace Lean +namespace Meta + +/-- + Try to solve `a := (fun x => t) =?= b` by eta-expanding `b`. + + Remark: eta-reduction is not a good alternative even in a system without universe cumulativity like Lean. + Example: + ``` + (fun x : A => f ?m) =?= f + ``` + The left-hand side of the constraint above it not eta-reduced because `?m` is a metavariable. -/ +private def isDefEqEta (a b : Expr) : MetaM Bool := +if a.isLambda && !b.isLambda then do + bType ← inferType b; + bType ← whnfUsingDefault bType; + match bType with + | Expr.forallE n d b c => + let b' := Lean.mkLambda n c.binderInfo d (mkApp b (mkBVar 0)); + try $ isExprDefEqAux a b' + | _ => pure false +else + pure false + +/-- + Return `true` if `e` is of the form `fun (x_1 ... x_n) => ?m x_1 ... x_n)`, and `?m` is unassigned. + Remark: `n` may be 0. -/ +def isEtaUnassignedMVar (e : Expr) : MetaM Bool := +match e.etaExpanded? with +| some (Expr.mvar mvarId _) => + condM (isReadOnlyOrSyntheticExprMVar mvarId) + (pure false) + (condM (isExprMVarAssigned mvarId) + (pure false) + (pure true)) +| _ => pure false + + +/- + First pass for `isDefEqArgs`. We unify explicit arguments, *and* easy cases + Here, we say a case is easy if it is of the form + + ?m =?= t + or + t =?= ?m + + where `?m` is unassigned. + + These easy cases are not just an optimization. When + `?m` is a function, by assigning it to t, we make sure + a unification constraint (in the explicit part) + ``` + ?m t =?= f s + ``` + is not higher-order. + + We also handle the eta-expanded cases: + ``` + fun x₁ ... xₙ => ?m x₁ ... xₙ =?= t + t =?= fun x₁ ... xₙ => ?m x₁ ... xₙ + + This is important because type inference often produces + eta-expanded terms, and without this extra case, we could + introduce counter intuitive behavior. + + Pre: `paramInfo.size <= args₁.size = args₂.size` +-/ +private partial def isDefEqArgsFirstPass + (paramInfo : Array ParamInfo) (args₁ args₂ : Array Expr) : Nat → Array Nat → MetaM (Option (Array Nat)) +| i, postponed => + if h : i < paramInfo.size then + let info := paramInfo.get ⟨i, h⟩; + let a₁ := args₁.get! i; + let a₂ := args₂.get! i; + if info.implicit || info.instImplicit then + condM (isEtaUnassignedMVar a₁ <||> isEtaUnassignedMVar a₂) + (condM (isExprDefEqAux a₁ a₂) + (isDefEqArgsFirstPass (i+1) postponed) + (pure none)) + (isDefEqArgsFirstPass (i+1) (postponed.push i)) + else + condM (isExprDefEqAux a₁ a₂) + (isDefEqArgsFirstPass (i+1) postponed) + (pure none) + else + pure (some postponed) + +private partial def isDefEqArgsAux (args₁ args₂ : Array Expr) (h : args₁.size = args₂.size) : Nat → MetaM Bool +| i => + if h₁ : i < args₁.size then + let a₁ := args₁.get ⟨i, h₁⟩; + let a₂ := args₂.get ⟨i, h ▸ h₁⟩; + condM (isExprDefEqAux a₁ a₂) + (isDefEqArgsAux (i+1)) + (pure false) + else + pure true + +private def isDefEqArgs (f : Expr) (args₁ args₂ : Array Expr) : MetaM Bool := +if h : args₁.size = args₂.size then do + finfo ← getFunInfoNArgs f args₁.size; + (some postponed) ← isDefEqArgsFirstPass finfo.paramInfo args₁ args₂ 0 #[] | pure false; + (isDefEqArgsAux args₁ args₂ h finfo.paramInfo.size) + <&&> + (postponed.allM $ fun i => do + /- Second pass: unify implicit arguments. + In the second pass, we make sure we are unfolding at + least non reducible definitions (default setting). -/ + let a₁ := args₁.get! i; + let a₂ := args₂.get! i; + let info := finfo.paramInfo.get! i; + when info.instImplicit $ do { + synthPending a₁; + synthPending a₂; + pure () + }; + usingAtLeastTransparency TransparencyMode.default $ isExprDefEqAux a₁ a₂) +else + pure false + +/-- + Check whether the types of the free variables at `fvars` are + definitionally equal to the types at `ds₂`. + + Pre: `fvars.size == ds₂.size` + + This method also updates the set of local instances, and invokes + the continuation `k` with the updated set. + + We can't use `withNewLocalInstances` because the `isDeq fvarType d₂` + may use local instances. -/ +@[specialize] partial def isDefEqBindingDomain (fvars : Array Expr) (ds₂ : Array Expr) : Nat → MetaM Bool → MetaM Bool +| i, k => + if h : i < fvars.size then do + let fvar := fvars.get ⟨i, h⟩; + fvarDecl ← getFVarLocalDecl fvar; + let fvarType := fvarDecl.type; + let d₂ := ds₂.get! i; + condM (isExprDefEqAux fvarType d₂) + (do c? ← isClass fvarType; + match c? with + | some className => withNewLocalInstance className fvar $ isDefEqBindingDomain (i+1) k + | none => isDefEqBindingDomain (i+1) k) + (pure false) + else + k + +/- Auxiliary function for `isDefEqBinding` for handling binders `forall/fun`. + It accumulates the new free variables in `fvars`, and declare them at `lctx`. + We use the domain types of `e₁` to create the new free variables. + We store the domain types of `e₂` at `ds₂`. -/ +private partial def isDefEqBindingAux : LocalContext → Array Expr → Expr → Expr → Array Expr → MetaM Bool +| lctx, fvars, e₁, e₂, ds₂ => + let process (n : Name) (d₁ d₂ b₁ b₂ : Expr) : MetaM Bool := do { + let d₁ := d₁.instantiateRev fvars; + let d₂ := d₂.instantiateRev fvars; + fvarId ← mkFreshId; + let lctx := lctx.mkLocalDecl fvarId n d₁; + let fvars := fvars.push (mkFVar fvarId); + isDefEqBindingAux lctx fvars b₁ b₂ (ds₂.push d₂) + }; + match e₁, e₂ with + | Expr.forallE n d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂ + | Expr.lam n d₁ b₁ _, Expr.lam _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂ + | _, _ => + adaptReader (fun (ctx : Context) => { lctx := lctx, .. ctx }) $ + isDefEqBindingDomain fvars ds₂ 0 $ + isExprDefEqAux (e₁.instantiateRev fvars) (e₂.instantiateRev fvars) + +@[inline] private def isDefEqBinding (a b : Expr) : MetaM Bool := +do lctx ← getLCtx; + isDefEqBindingAux lctx #[] a b #[] + +/- + Each metavariable is declared in a particular local context. + We use the notation `C |- ?m : t` to denote a metavariable `?m` that + was declared at the local context `C` with type `t` (see `MetavarDecl`). + We also use `?m@C` as a shorthand for `C |- ?m : t` where `t` is the type of `?m`. + + The following method process the unification constraint + + ?m@C a₁ ... aₙ =?= t + + We say the unification constraint is a pattern IFF + + 1) `a₁ ... aₙ` are pairwise distinct free variables that are ​*not*​ let-variables. + 2) `a₁ ... aₙ` are not in `C` + 3) `t` only contains free variables in `C` and/or `{a₁, ..., aₙ}` + 4) For every metavariable `?m'@C'` occurring in `t`, `C'` is a subprefix of `C` + 5) `?m` does not occur in `t` + + Claim: we don't have to check free variable declarations. That is, + if `t` contains a reference to `x : A := v`, we don't need to check `v`. + Reason: The reference to `x` is a free variable, and it must be in `C` (by 1 and 3). + If `x` is in `C`, then any metavariable occurring in `v` must have been defined in a strict subprefix of `C`. + So, condition 4 and 5 are satisfied. + + If the conditions above have been satisfied, then the + solution for the unification constrain is + + ?m := fun a₁ ... aₙ => t + + Now, we consider some workarounds/approximations. + + A1) Suppose `t` contains a reference to `x : A := v` and `x` is not in `C` (failed condition 3) + (precise) solution: unfold `x` in `t`. + + A2) Suppose some `aᵢ` is in `C` (failed condition 2) + (approximated) solution (when `config.foApprox` is set to true) : + ignore condition and also use + + ?m := fun a₁ ... aₙ => t + + Here is an example where this approximation fails: + Given `C` containing `a : nat`, consider the following two constraints + ?m@C a =?= a + ?m@C b =?= a + + If we use the approximation in the first constraint, we get + ?m := fun x => x + when we apply this solution to the second one we get a failure. + + IMPORTANT: When applying this approximation we need to make sure the + abstracted term `fun a₁ ... aₙ => t` is type correct. The check + can only be skipped in the pattern case described above. Consider + the following example. Given the local context + + (α : Type) (a : α) + + we try to solve + + ?m α =?= @id α a + + If we use the approximation above we obtain: + + ?m := (fun α' => @id α' a) + + which is a type incorrect term. `a` has type `α` but it is expected to have + type `α'`. + + The problem occurs because the right hand side contains a free variable + `a` that depends on the free variable `α` being abstracted. Note that + this dependency cannot occur in patterns. + + Here is another example in the same local context + + ?m_1 α =?= id ?m_2 + + If we use the approximation above we obtain: + + ?m_1 := (fun α' => id (?m_2' α')) + + where `?m_2'` is a new metavariable, and `?m_2 := ?m_2 α` + + Now, suppose we assign `?m_2'`. + + ?m_2 := (fun α => @id α a) + + Then, we have + + ?m_1 := (fun α' => id (@id α' a)) + + which is again type incorrect. + + We can address the issue on the first example by type checking + the term after abstraction. This is not a significant performance + bottleneck because this case doesn't happen very often in practice + (262 times when compiling stdlib on Jan 2018). The second example + is trickier, but it also occurs less frequently (8 times when compiling + stdlib on Jan 2018, and all occurrences were at Init/Control when + we define monads and auxiliary combinators for them). + We considered three options for the addressing the issue on the second example: + + a) For each metavariable that may contain a free variable + that depends on a term being abstracted, we create a fresh metavariable + with a smaller local context. In the example above, when we perform + the assignment + + ?m_1 := (fun α' => id (?m_2' α')) + + b) If we find a metavariable with this kind of dependency, we just + fail and fallback to first-order unification. + + c) If we find a metavariable on the term after abstraction, we just + fail and fallback to first-order unification. + + The first two options are incomparable, each one of them can solve + problems where the other fails. The third one is weaker than the second, + but we didn't find any example in the stdlib where the second option + applies. The first and third options are also incomparable. + + So, we decide to use the third option since it is the simplest to implement, + and all examples we have identified are in Init/Control. + + A3) `a₁ ... aₙ` are not pairwise distinct (failed condition 1). + In Lean3, we would try to approximate this case using an approach similar to A2. + However, this approximation complicates the code, and is never used in the + Lean3 stdlib and mathlib. + + A4) `t` contains a metavariable `?m'@C'` where `C'` is not a subprefix of `C`. + (approximated) solution: restrict the context of `?m'` + If `?m'` is assigned, the workaround is precise, and we just unfold `?m'`. + + A5) If some `aᵢ` is not a free variable, + then we use first-order unification (if `config.foApprox` is set to true) + + ?m a_1 ... a_i a_{i+1} ... a_{i+k} =?= f b_1 ... b_k + + reduces to + + ?M a_1 ... a_i =?= f + a_{i+1} =?= b_1 + ... + a_{i+k} =?= b_k + + + A6) If (m =?= v) is of the form + + ?m a_1 ... a_n =?= ?m b_1 ... b_k + + then we use first-order unification (if `config.foApprox` is set to true) +-/ + +namespace CheckAssignment + +structure Context := +(lctx : LocalContext) +(mvarId : Name) +(mvarDecl : MetavarDecl) +(fvars : Array Expr) +(ctxApprox : Bool) +(hasCtxLocals : Bool) + +inductive Exception +| occursCheck +| useFOApprox +| outOfScopeFVar (fvarId : Name) +| readOnlyMVarWithBiggerLCtx (mvarId : Name) +| mvarTypeNotWellFormedInSmallerLCtx (mvarId : Name) +| unknownExprMVar (mvarId : Name) + +structure State := +(mctx : MetavarContext) +(ngen : NameGenerator) +(cache : ExprStructMap Expr := {}) + +abbrev CheckAssignmentM := ReaderT Context (EStateM Exception State) + +private def findCached (e : Expr) : CheckAssignmentM (Option Expr) := +do s ← get; pure $ s.cache.find e + +private def cache (e r : Expr) : CheckAssignmentM Unit := +modify $ fun s => { cache := s.cache.insert e r, .. s } + +instance : MonadCache Expr Expr CheckAssignmentM := +{ findCached := findCached, cache := cache } + +@[inline] private def visit (f : Expr → CheckAssignmentM Expr) (e : Expr) : CheckAssignmentM Expr := +if !e.hasExprMVar && !e.hasFVar then pure e else checkCache e f + +@[specialize] def checkFVar (check : Expr → CheckAssignmentM Expr) (fvar : Expr) : CheckAssignmentM Expr := +do ctx ← read; + if ctx.mvarDecl.lctx.containsFVar fvar then pure fvar + else do + let lctx := ctx.lctx; + match lctx.findFVar fvar with + | some (LocalDecl.ldecl _ _ _ _ v) => visit check v + | _ => + if ctx.fvars.contains fvar then pure fvar + else throw $ Exception.outOfScopeFVar fvar.fvarId! + +@[inline] def getMCtx : CheckAssignmentM MetavarContext := +do s ← get; pure s.mctx + +def mkAuxMVar (lctx : LocalContext) (type : Expr) : CheckAssignmentM Expr := +do s ← get; + let mvarId := s.ngen.curr; + modify $ fun s => { ngen := s.ngen.next, mctx := s.mctx.addExprMVarDecl mvarId Name.anonymous lctx type, .. s }; + pure (mkMVar mvarId) + +@[specialize] def checkMVar (check : Expr → CheckAssignmentM Expr) (mvar : Expr) : CheckAssignmentM Expr := +do let mvarId := mvar.mvarId!; + ctx ← read; + mctx ← getMCtx; + match mctx.getExprAssignment mvarId with + | some v => visit check v + | none => + if mvarId == ctx.mvarId then throw Exception.occursCheck + else match mctx.findDecl mvarId with + | none => throw $ Exception.unknownExprMVar mvarId + | some mvarDecl => + if ctx.hasCtxLocals then throw $ Exception.useFOApprox -- we use option c) described at workaround A2 + else if mvarDecl.lctx.isSubPrefixOf ctx.mvarDecl.lctx then pure mvar + else if mvarDecl.depth != mctx.depth || mvarDecl.synthetic then throw $ Exception.readOnlyMVarWithBiggerLCtx mvarId + else if ctx.ctxApprox && ctx.mvarDecl.lctx.isSubPrefixOf mvarDecl.lctx then + let mvarType := mvarDecl.type; + if mctx.isWellFormed ctx.mvarDecl.lctx mvarType then do + /- Create an auxiliary metavariable with a smaller context. -/ + newMVar ← mkAuxMVar ctx.mvarDecl.lctx mvarType; + modify $ fun s => { mctx := s.mctx.assignExpr mvarId newMVar, .. s }; + pure newMVar + else + throw $ Exception.mvarTypeNotWellFormedInSmallerLCtx mvarId + else + pure mvar + +partial def check : Expr → CheckAssignmentM Expr +| e@(Expr.mdata _ b _) => do b ← visit check b; pure $ e.updateMData! b +| e@(Expr.proj _ _ s _) => do s ← visit check s; pure $ e.updateProj! s +| e@(Expr.app f a _) => do f ← visit check f; a ← visit check a; pure $ e.updateApp! f a +| e@(Expr.lam _ d b _) => do d ← visit check d; b ← visit check b; pure $ e.updateLambdaE! d b +| e@(Expr.forallE _ d b _) => do d ← visit check d; b ← visit check b; pure $ e.updateForallE! d b +| e@(Expr.letE _ t v b _) => do t ← visit check t; v ← visit check v; b ← visit check b; pure $ e.updateLet! t v b +| e@(Expr.bvar _ _) => pure e +| e@(Expr.sort _ _) => pure e +| e@(Expr.const _ _ _) => pure e +| e@(Expr.lit _ _) => pure e +| e@(Expr.fvar _ _) => visit (checkFVar check) e +| e@(Expr.mvar _ _) => visit (checkMVar check) e +| Expr.localE _ _ _ _ => unreachable! + +end CheckAssignment + +private def checkAssignmentFailure (mvarId : Name) (fvars : Array Expr) (v : Expr) (ex : CheckAssignment.Exception) : MetaM (Option Expr) := +match ex with +| CheckAssignment.Exception.occursCheck => do + trace! `Meta.isDefEq.assignment.occursCheck + (mkMVar mvarId ++ fvars ++ " := " ++ v); + pure none +| CheckAssignment.Exception.useFOApprox => + pure none +| CheckAssignment.Exception.outOfScopeFVar fvarId => do + trace! `Meta.isDefEq.assignment.outOfScopeFVar + (mkFVar fvarId ++ " @ " ++ mkMVar mvarId ++ fvars ++ " := " ++ v); + pure none +| CheckAssignment.Exception.readOnlyMVarWithBiggerLCtx nestedMVarId => do + trace! `Meta.isDefEq.assignment.readOnlyMVarWithBiggerLCtx + (mkMVar nestedMVarId ++ " @ " ++ mkMVar mvarId ++ fvars ++ " := " ++ v); + pure none +| CheckAssignment.Exception.mvarTypeNotWellFormedInSmallerLCtx nestedMVarId => do + trace! `Meta.isDefEq.assignment.mvarTypeNotWellFormedInSmallerLCtx + (mkMVar nestedMVarId ++ " @ " ++ mkMVar mvarId ++ fvars ++ " := " ++ v); + pure none +| CheckAssignment.Exception.unknownExprMVar mvarId => + -- This case can only happen if the MetaM API is being misused + throwEx $ Exception.unknownExprMVar mvarId + +namespace CheckAssignmentQuick + +@[inline] private def visit (f : Expr → Bool) (e : Expr) : Bool := +if !e.hasExprMVar && !e.hasFVar then true else f e + +partial def check + (hasCtxLocals ctxApprox : Bool) + (mctx : MetavarContext) (lctx : LocalContext) (mvarDecl : MetavarDecl) (mvarId : Name) (fvars : Array Expr) : Expr → Bool +| e@(Expr.mdata _ b _) => check b +| e@(Expr.proj _ _ s _) => check s +| e@(Expr.app f a _) => visit check f && visit check a +| e@(Expr.lam _ d b _) => visit check d && visit check b +| e@(Expr.forallE _ d b _) => visit check d && visit check b +| e@(Expr.letE _ t v b _) => visit check t && visit check v && visit check b +| e@(Expr.bvar _ _) => true +| e@(Expr.sort _ _) => true +| e@(Expr.const _ _ _) => true +| e@(Expr.lit _ _) => true +| e@(Expr.fvar fvarId _) => + if mvarDecl.lctx.contains fvarId then true + else match lctx.find fvarId with + | some (LocalDecl.ldecl _ _ _ _ v) => false -- need expensive CheckAssignment.check + | _ => + if fvars.any $ fun x => x.fvarId! == fvarId then true + else false -- We could throw an exception here, but we would have to use ExceptM. So, we let CheckAssignment.check do it +| e@(Expr.mvar mvarId' _) => do + match mctx.getExprAssignment mvarId' with + | some _ => false -- use CheckAssignment.check to instantiate + | none => + if mvarId' == mvarId then false -- occurs check failed, use CheckAssignment.check to throw exception + else match mctx.findDecl mvarId' with + | none => false + | some mvarDecl' => + if hasCtxLocals then false -- use CheckAssignment.check + else if mvarDecl'.lctx.isSubPrefixOf mvarDecl.lctx then true + else if mvarDecl'.depth != mctx.depth || mvarDecl'.synthetic then false -- use CheckAssignment.check + else if ctxApprox && mvarDecl.lctx.isSubPrefixOf mvarDecl'.lctx then false -- use CheckAssignment.check + else true +| Expr.localE _ _ _ _ => unreachable! + +end CheckAssignmentQuick + +/-- + Auxiliary function for handling constraints of the form `?m a₁ ... aₙ =?= v`. + It will check whether we can perform the assignment + ``` + ?m := fun fvars => t + ``` + The result is `none` if the assignment can't be performed. + The result is `some newV` where `newV` is a possibly updated `v`. This method may need + to unfold let-declarations. -/ +def checkAssignment (mvarId : Name) (fvars : Array Expr) (v : Expr) : MetaM (Option Expr) := +fun ctx s => if !v.hasExprMVar && !v.hasFVar then EStateM.Result.ok (some v) s else + let mvarDecl := s.mctx.getDecl mvarId; + let hasCtxLocals := fvars.any $ fun fvar => mvarDecl.lctx.containsFVar fvar; + if CheckAssignmentQuick.check hasCtxLocals ctx.config.ctxApprox s.mctx ctx.lctx mvarDecl mvarId fvars v then + EStateM.Result.ok (some v) s + else + let checkCtx : CheckAssignment.Context := { + lctx := ctx.lctx, + mvarId := mvarId, + mvarDecl := s.mctx.getDecl mvarId, + fvars := fvars, + ctxApprox := ctx.config.ctxApprox, + hasCtxLocals := hasCtxLocals + }; + match (CheckAssignment.check v checkCtx).run { mctx := s.mctx, ngen := s.ngen } with + | EStateM.Result.ok e newS => EStateM.Result.ok (some e) { mctx := newS.mctx, ngen := newS.ngen, .. s } + | EStateM.Result.error ex newS => checkAssignmentFailure mvarId fvars v ex ctx { ngen := newS.ngen, .. s } + +/- + We try to unify arguments before we try to unify the functions. + The motivation is the following: the universe constraints in + the arguments propagate to the function. -/ +private partial def isDefEqFOApprox (f₁ f₂ : Expr) (args₁ args₂ : Array Expr) : Nat → Nat → MetaM Bool +| i₁, i₂ => + if h : i₂ < args₂.size then + let arg₁ := args₁.get! i₁; + let arg₂ := args₂.get ⟨i₂, h⟩; + condM (isExprDefEqAux arg₁ arg₂) + (isDefEqFOApprox (i₁+1) (i₂+1)) + (pure false) + else + isExprDefEqAux f₁ f₂ + +private def processAssignmentFOApproxAux (mvar : Expr) (args : Array Expr) (v : Expr) : MetaM Bool := +let vArgs := v.getAppArgs; +if vArgs.isEmpty then + /- ?m a_1 ... a_k =?= t, where t is not an application -/ + pure false +else if args.size > vArgs.size then + /- + ?m a_1 ... a_i a_{i+1} ... a_{i+k} =?= f b_1 ... b_k + + reduces to + + ?m a_1 ... a_i =?= f + a_{i+1} =?= b_1 + ... + a_{i+k} =?= b_k + -/ + let f₁ := mkAppRange mvar 0 (args.size - vArgs.size) args; + let i₁ := args.size - vArgs.size; + isDefEqFOApprox f₁ v.getAppFn args vArgs i₁ 0 +else if args.size < vArgs.size then + /- + ?m a_1 ... a_k =?= f b_1 ... b_i b_{i+1} ... b_{i+k} + + reduces to + + ?m =?= f b_1 ... b_i + a_1 =?= b_{i+1} + ... + a_k =?= b_{i+k} + -/ + let vFn := mkAppRange v.getAppFn 0 (vArgs.size - args.size) vArgs; + let i₂ := vArgs.size - args.size; + isDefEqFOApprox mvar vFn args vArgs 0 i₂ +else + /- + ?m a_1 ... a_k =?= f b_1 ... b_k + + reduces to + + ?m =?= f + a_1 =?= b_1 + ... + a_k =?= b_k + -/ + isDefEqFOApprox mvar v.getAppFn args vArgs 0 0 + +/- + Auxiliary method for applying first-order unification. It is an approximation. + Remark: this method is trying to solve the unification constraint: + + ?m a₁ ... aₙ =?= v + + It is uses processAssignmentFOApproxAux, if it fails, it tries to unfold `v`. + + We have added support for unfolding here because we want to be able to solve unification problems such as + + ?m Unit =?= ITactic + + where `ITactic` is defined as + + def ITactic := Tactic Unit +-/ +private partial def processAssignmentFOApprox (mvar : Expr) (args : Array Expr) : Expr → MetaM Bool +| v => do + trace! `Meta.isDefEq.foApprox (mvar ++ " " ++ args ++ " := " ++ v); + condM (try $ processAssignmentFOApproxAux mvar args v) + (pure true) + (do v? ← unfoldDefinition v; + match v? with + | none => pure false + | some v => processAssignmentFOApprox v) + +private partial def simpAssignmentArgAux : Expr → MetaM Expr +| Expr.mdata _ e _ => simpAssignmentArgAux e +| e@(Expr.fvar fvarId _) => do + decl ← getLocalDecl fvarId; + match decl.value? with + | some value => simpAssignmentArgAux value + | _ => pure e +| e => pure e + +/- Auxiliary procedure for processing `?m a₁ ... aₙ =?= v`. + We apply it to each `aᵢ`. It instantiates assigned metavariables if `aᵢ` is of the form `f[?n] b₁ ... bₘ`, + and then removes metadata, and zeta-expand let-decls. -/ +private def simpAssignmentArg (arg : Expr) : MetaM Expr := +do arg ← if arg.getAppFn.hasExprMVar then instantiateMVars arg else pure arg; + simpAssignmentArgAux arg + +private partial def processAssignmentAux (mvar : Expr) (mvarDecl : MetavarDecl) (v : Expr) : Nat → Array Expr → MetaM Bool +| i, args => + if h : i < args.size then do + cfg ← getConfig; + let arg := args.get ⟨i, h⟩; + arg ← simpAssignmentArg arg; + let args := args.set ⟨i, h⟩ arg; + let useFOApprox : Unit → MetaM Bool := fun _ => + if cfg.foApprox then + processAssignmentFOApprox mvar args v + else + pure false; + match arg with + | Expr.fvar fvarId _ => + if args.anyRange 0 i (fun prevArg => prevArg == arg) then + useFOApprox () + else if mvarDecl.lctx.contains fvarId && !cfg.quasiPatternApprox then + useFOApprox () + else + processAssignmentAux (i+1) args + | _ => + useFOApprox () + else do + cfg ← getConfig; + v ← instantiateMVars v; -- enforce A4 + if cfg.foApprox && args.isEmpty && v.getAppFn == mvar then + processAssignmentFOApprox mvar args v + else do + let useFOApprox : Unit → MetaM Bool := fun _ => + if cfg.foApprox then processAssignmentFOApprox mvar args v + else pure false; + let mvarId := mvar.mvarId!; + v? ← checkAssignment mvarId args v; + match v? with + | none => useFOApprox () + | some v => do + v ← mkLambda args v; + let finalize : Unit → MetaM Bool := fun _ => do { + -- must check whether types are definitionally equal or not, before assigning and returning true + mvarType ← inferType mvar; + vType ← inferType v; + condM (usingTransparency TransparencyMode.default $ isExprDefEqAux mvarType vType) + (do assignExprMVar mvarId v; pure true) + (do trace! `Meta.isDefEq.assignment.typeMismatch (mvar ++ " : " ++ mvarType ++ " := " ++ v ++ " : " ++ vType); + pure false) + }; + if args.any (fun arg => mvarDecl.lctx.containsFVar arg) then + /- We need to type check `v` because abstraction using `mkLambda` may have produced + a type incorrect term. See discussion at A2 -/ + condM (isTypeCorrect v) + (finalize ()) + (do trace! `Meta.isDefEq.assignment.typeError (mvar ++ " := " ++ v); + useFOApprox ()) + else + finalize () + +/-- Tries to solve `?m a₁ ... aₙ =?= v` by assigning `?m`. + It assumes `?m` is unassigned. -/ +private def processAssignment (mvarApp : Expr) (v : Expr) : MetaM Bool := +do let mvar := mvarApp.getAppFn; + mvarDecl ← getMVarDecl mvar.mvarId!; + processAssignmentAux mvar mvarDecl v 0 mvarApp.getAppArgs + +private def isDeltaCandidate (t : Expr) : MetaM (Option ConstantInfo) := +match t.getAppFn with +| Expr.const c _ _ => getConst c +| _ => pure none + +/-- Auxiliary method for isDefEqDelta -/ +private def isListLevelDefEq (us vs : List Level) : MetaM LBool := +toLBoolM $ isListLevelDefEqAux us vs + +/-- Auxiliary method for isDefEqDelta -/ +private def isDefEqLeft (fn : Name) (t s : Expr) : MetaM LBool := +do trace! `Meta.isDefEq.delta.unfoldLeft fn; + toLBoolM $ isExprDefEqAux t s + +/-- Auxiliary method for isDefEqDelta -/ +private def isDefEqRight (fn : Name) (t s : Expr) : MetaM LBool := +do trace! `Meta.isDefEq.delta.unfoldRight fn; + toLBoolM $ isExprDefEqAux t s + +/-- Auxiliary method for isDefEqDelta -/ +private def isDefEqLeftRight (fn : Name) (t s : Expr) : MetaM LBool := +do trace! `Meta.isDefEq.delta.unfoldLeftRight fn; + toLBoolM $ isExprDefEqAux t s + +/-- Try to solve `f a₁ ... aₙ =?= f b₁ ... bₙ` by solving `a₁ =?= b₁, ..., aₙ =?= bₙ`. + + Auxiliary method for isDefEqDelta -/ +private def tryHeuristic (t s : Expr) : MetaM Bool := +let tFn := t.getAppFn; +let sFn := s.getAppFn; +traceCtx `Meta.isDefEq.delta $ + try $ do + b ← isDefEqArgs tFn t.getAppArgs s.getAppArgs + <&&> + isListLevelDefEqAux tFn.constLevels! sFn.constLevels!; + unless b $ trace! `Meta.isDefEq.delta ("heuristic failed " ++ t ++ " =?= " ++ s); + pure b + +/-- Auxiliary method for isDefEqDelta -/ +private abbrev unfold {α} (e : Expr) (failK : MetaM α) (successK : Expr → MetaM α) : MetaM α := +do e? ← unfoldDefinition e; + match e? with + | some e => successK e + | none => failK + +/-- Auxiliary method for isDefEqDelta -/ +private def unfoldBothDefEq (fn : Name) (t s : Expr) : MetaM LBool := +match t, s with +| Expr.const _ ls₁ _, Expr.const _ ls₂ _ => isListLevelDefEq ls₁ ls₂ +| Expr.app _ _ _, Expr.app _ _ _ => + condM (tryHeuristic t s) + (pure LBool.true) + (unfold t + (unfold s (pure LBool.false) (fun s => isDefEqRight fn t s)) + (fun t => unfold s (isDefEqLeft fn t s) (fun s => isDefEqLeftRight fn t s))) +| _, _ => pure LBool.false + +private def sameHeadSymbol (t s : Expr) : Bool := +match t.getAppFn, s.getAppFn with +| Expr.const c₁ _ _, Expr.const c₂ _ _ => true +| _, _ => false + +/-- + - If headSymbol (unfold t) == headSymbol s, then unfold t + - If headSymbol (unfold s) == headSymbol t, then unfold s + - Otherwise unfold t and s if possible. + + Auxiliary method for isDefEqDelta -/ +private def unfoldComparingHeadsDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := +unfold t + (unfold s + (pure LBool.undef) -- `t` and `s` failed to be unfolded + (fun s => isDefEqRight sInfo.name t s)) + (fun tNew => + if sameHeadSymbol tNew s then + isDefEqLeft tInfo.name tNew s + else + unfold s + (isDefEqLeft tInfo.name tNew s) + (fun sNew => + if sameHeadSymbol t sNew then + isDefEqRight sInfo.name t sNew + else + isDefEqLeftRight tInfo.name tNew sNew)) + +/-- If `t` and `s` do not contain metavariables, then use + kernel definitional equality heuristics. + Otherwise, use `unfoldComparingHeadsDefEq`. + + Auxiliary method for isDefEqDelta -/ +private def unfoldDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := +if !t.hasExprMVar && !s.hasExprMVar then + /- If `t` and `s` do not contain metavariables, + we simulate strategy used in the kernel. -/ + if tInfo.hints.lt sInfo.hints then + unfold t (unfoldComparingHeadsDefEq tInfo sInfo t s) $ fun t => isDefEqLeft tInfo.name t s + else if sInfo.hints.lt tInfo.hints then + unfold s (unfoldComparingHeadsDefEq tInfo sInfo t s) $ fun s => isDefEqRight sInfo.name t s + else + unfoldComparingHeadsDefEq tInfo sInfo t s +else + unfoldComparingHeadsDefEq tInfo sInfo t s + +/-- + When `TransparencyMode` is set to `default` or `all`. + If `t` is reducible and `s` is not ==> `isDefEqLeft (unfold t) s` + If `s` is reducible and `t` is not ==> `isDefEqRight t (unfold s)` + + Otherwise, use `unfoldDefEq` + + Auxiliary method for isDefEqDelta -/ +private def unfoldReducibeDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := +condM reduceReducibleOnly? + (unfoldDefEq tInfo sInfo t s) + (do tReducible ← isReducible tInfo.name; + sReducible ← isReducible sInfo.name; + if tReducible && !sReducible then + unfold t (unfoldDefEq tInfo sInfo t s) $ fun t => isDefEqLeft tInfo.name t s + else if !tReducible && sReducible then + unfold s (unfoldDefEq tInfo sInfo t s) $ fun s => isDefEqRight sInfo.name t s + else + unfoldDefEq tInfo sInfo t s) + +/-- + If `t` is a projection function application and `s` is not ==> `isDefEqRight t (unfold s)` + If `s` is a projection function application and `t` is not ==> `isDefEqRight (unfold t) s` + + Otherwise, use `unfoldReducibeDefEq` + + Auxiliary method for isDefEqDelta -/ +private def unfoldNonProjFnDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := +do env ← getEnv; + let tProj? := env.isProjectionFn tInfo.name; + let sProj? := env.isProjectionFn sInfo.name; + if tProj? && !sProj? then + unfold s (unfoldDefEq tInfo sInfo t s) $ fun s => isDefEqRight sInfo.name t s + else if !tProj? && sProj? then + unfold t (unfoldDefEq tInfo sInfo t s) $ fun t => isDefEqLeft tInfo.name t s + else + unfoldReducibeDefEq tInfo sInfo t s + +/-- + isDefEq by lazy delta reduction. + This method implements many different heuristics: + 1- If only `t` can be unfolded => then unfold `t` and continue + 2- If only `s` can be unfolded => then unfold `s` and continue + 3- If `t` and `s` can be unfolded and they have the same head symbol, then + a) First try to solve unification by unifying arguments. + b) If it fails, unfold both and continue. + Implemented by `unfoldBothDefEq` + 4- If `t` is a projection function application and `s` is not => then unfold `s` and continue. + 5- If `s` is a projection function application and `t` is not => then unfold `t` and continue. + Remark: 4&5 are implemented by `unfoldNonProjFnDefEq` + 6- If `t` is reducible and `s` is not => then unfold `t` and continue. + 7- If `s` is reducible and `t` is not => then unfold `s` and continue + Remark: 6&7 are implemented by `unfoldReducibeDefEq` + 8- If `t` and `s` do not contain metavariables, then use heuristic used in the Kernel. + Implemented by `unfoldDefEq` + 9- If `headSymbol (unfold t) == headSymbol s`, then unfold t and continue. + 10- If `headSymbol (unfold s) == headSymbol t`, then unfold s + 11- Otherwise, unfold `t` and `s` and continue. + Remark: 9&10&11 are implemented by `unfoldComparingHeadsDefEq` -/ +private def isDefEqDelta (t s : Expr) : MetaM LBool := +do tInfo? ← isDeltaCandidate t.getAppFn; + sInfo? ← isDeltaCandidate s.getAppFn; + match tInfo?, sInfo? with + | none, none => pure LBool.undef + | some tInfo, none => unfold t (pure LBool.undef) $ fun t => isDefEqLeft tInfo.name t s + | none, some sInfo => unfold s (pure LBool.undef) $ fun s => isDefEqRight sInfo.name t s + | some tInfo, some sInfo => + if tInfo.name == sInfo.name then + unfoldBothDefEq tInfo.name t s + else + unfoldNonProjFnDefEq tInfo sInfo t s + +private def isAssigned : Expr → MetaM Bool +| Expr.mvar mvarId _ => isExprMVarAssigned mvarId +| _ => pure false + +private def isSynthetic : Expr → MetaM Bool +| Expr.mvar mvarId _ => isSyntheticExprMVar mvarId +| _ => pure false + +private def isAssignable : Expr → MetaM Bool +| Expr.mvar mvarId _ => do b ← isReadOnlyOrSyntheticExprMVar mvarId; pure (!b) +| _ => pure false + +private def etaEq (t s : Expr) : Bool := +match t.etaExpanded? with +| some t => t == s +| none => false + +private def isLetFVar (fvarId : Name) : MetaM Bool := +do decl ← getLocalDecl fvarId; + pure decl.isLet + +private partial def isDefEqQuick : Expr → Expr → MetaM LBool +| Expr.lit l₁ _, Expr.lit l₂ _ => pure (l₁ == l₂).toLBool +| Expr.sort u _, Expr.sort v _ => toLBoolM $ isLevelDefEqAux u v +| t@(Expr.lam _ _ _ _), s@(Expr.lam _ _ _ _) => if t == s then pure LBool.true else toLBoolM $ isDefEqBinding t s +| t@(Expr.forallE _ _ _ _), s@(Expr.forallE _ _ _ _) => if t == s then pure LBool.true else toLBoolM $ isDefEqBinding t s +| Expr.mdata _ t _, s => isDefEqQuick t s +| t, Expr.mdata _ s _ => isDefEqQuick t s +| Expr.fvar fvarId₁ _, Expr.fvar fvarId₂ _ => + condM (isLetFVar fvarId₁ <||> isLetFVar fvarId₂) + (pure LBool.undef) + (pure (fvarId₁ == fvarId₂).toLBool) +| t, s => + cond (t == s) (pure LBool.true) $ + cond (etaEq t s || etaEq s t) (pure LBool.true) $ -- t =?= (fun xs => t xs) + let tFn := t.getAppFn; + let sFn := s.getAppFn; + cond (!tFn.isMVar && !sFn.isMVar) (pure LBool.undef) $ + condM (isAssigned tFn) (do t ← instantiateMVars t; isDefEqQuick t s) $ + condM (isAssigned sFn) (do s ← instantiateMVars s; isDefEqQuick t s) $ + condM (isSynthetic tFn <&&> synthPending tFn) (do t ← instantiateMVars t; isDefEqQuick t s) $ + condM (isSynthetic sFn <&&> synthPending sFn) (do s ← instantiateMVars s; isDefEqQuick t s) $ do + tAssign? ← isAssignable tFn; + sAssign? ← isAssignable sFn; + let assign (t s : Expr) : MetaM LBool := toLBoolM $ processAssignment t s; + cond (tAssign? && !sAssign?) (assign t s) $ + cond (!tAssign? && sAssign?) (assign s t) $ + cond (!tAssign? && !sAssign?) + (if tFn.isMVar || sFn.isMVar then do + ctx ← read; + if ctx.config.isDefEqStuckEx then throwEx $ Exception.isDefEqStuck t s + else pure LBool.false + else pure LBool.undef) $ do + -- Both `t` and `s` are terms of the form `?m ...` + tMVarDecl ← getMVarDecl tFn.mvarId!; + sMVarDecl ← getMVarDecl sFn.mvarId!; + cond (!sMVarDecl.lctx.isSubPrefixOf tMVarDecl.lctx) (assign s t) $ + /- + Local context for `s` is a sub prefix of the local context for `t`. + + Remark: + It is easier to solve the assignment + ?m2 := ?m1 a_1 ... a_n + than + ?m1 a_1 ... a_n := ?m2 + Reason: the first one has a precise solution. For example, + consider the constraint `?m1 ?m =?= ?m2` -/ + cond (!t.isApp && s.isApp) (assign t s) $ + cond (!s.isApp && t.isApp && tMVarDecl.lctx.isSubPrefixOf sMVarDecl.lctx) (assign s t) $ + assign t s + +private def isDefEqProofIrrel (t s : Expr) : MetaM LBool := +do tType ← inferType t; + condM (isProp tType) + (do sType ← inferType s; toLBoolM $ isExprDefEqAux tType sType) + (pure LBool.undef) + +@[inline] def tryL (x : MetaM LBool) (k : MetaM Bool) : MetaM Bool := +do status ← x; + match status with + | LBool.true => pure true + | LBool.false => pure false + | LBool.undef => k + +@[specialize] private partial def isDefEqWHNF + (t s : Expr) + (k : Expr → Expr → MetaM Bool) : MetaM Bool := +do t' ← whnfCore t; + s' ← whnfCore s; + if t == t' && s == s' then + k t' s' + else + tryL (isDefEqQuick t' s') $ k t' s' + +@[specialize] private def unstuckMVar + (e : Expr) + (successK : Expr → MetaM Bool) (failK : MetaM Bool): MetaM Bool := +do s? ← WHNF.getStuckMVar getConst whnf e; + match s? with + | some s => + condM (synthPending s) + (do e ← instantiateMVars e; successK e) + failK + | none => failK + +private def isDefEqOnFailure (t s : Expr) : MetaM Bool := +unstuckMVar t (fun t => isExprDefEqAux t s) $ +unstuckMVar s (fun s => isExprDefEqAux t s) $ +pure false + +partial def isExprDefEqAuxImpl : Expr → Expr → MetaM Bool +| t, s => do + trace! `Meta.isDefEq.step (t ++ " =?= " ++ s); + tryL (isDefEqQuick t s) $ + tryL (isDefEqProofIrrel t s) $ + isDefEqWHNF t s $ fun t s => do + tryL (isDefEqOffset t s) $ do + tryL (isDefEqDelta t s) $ + condM (isDefEqEta t s <||> isDefEqEta s t) (pure true) $ + match t, s with + | Expr.const _ us _, Expr.const _ vs _ => isListLevelDefEqAux us vs + | Expr.app _ _ _, Expr.app _ _ _ => + let tFn := t.getAppFn; + condM (try (isExprDefEqAux tFn s.getAppFn <&&> isDefEqArgs tFn t.getAppArgs s.getAppArgs)) + (pure true) + (isDefEqOnFailure t s) + | _, _ => isDefEqOnFailure t s + +@[init] def setIsExprDefEqAuxRef : IO Unit := +isExprDefEqAuxRef.set isExprDefEqAuxImpl + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/FunInfo.lean b/stage0/src/Init/Lean/Meta/FunInfo.lean new file mode 100644 index 0000000000..56bc2c9099 --- /dev/null +++ b/stage0/src/Init/Lean/Meta/FunInfo.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Meta.Basic +import Init.Lean.Meta.InferType + +namespace Lean +namespace Meta + +@[inline] private def checkFunInfoCache (fn : Expr) (maxArgs? : Option Nat) (k : MetaM FunInfo) : MetaM FunInfo := +do s ← get; + t ← getTransparency; + match s.cache.funInfo.find ⟨t, fn, maxArgs?⟩ with + | some finfo => pure finfo + | none => do + finfo ← k; + modify $ fun s => { cache := { funInfo := s.cache.funInfo.insert ⟨t, fn, maxArgs?⟩ finfo, .. s.cache }, .. s }; + pure finfo + +@[inline] private def whenHasVar {α} (e : Expr) (deps : α) (k : α → α) : α := +if e.hasFVar then k deps else deps + +private def collectDepsAux (fvars : Array Expr) : Expr → Array Nat → Array Nat +| e@(Expr.app f a _), deps => whenHasVar e deps (collectDepsAux a ∘ collectDepsAux f) +| e@(Expr.forallE _ d b _), deps => whenHasVar e deps (collectDepsAux b ∘ collectDepsAux d) +| e@(Expr.lam _ d b _), deps => whenHasVar e deps (collectDepsAux b ∘ collectDepsAux d) +| e@(Expr.letE _ t v b _), deps => whenHasVar e deps (collectDepsAux b ∘ collectDepsAux v ∘ collectDepsAux t) +| Expr.proj _ _ e _, deps => collectDepsAux e deps +| Expr.mdata _ e _, deps => collectDepsAux e deps +| e@(Expr.fvar _ _), deps => + match fvars.indexOf e with + | none => deps + | some i => if deps.contains i.val then deps else deps.push i.val +| _, deps => deps + +private def collectDeps (fvars : Array Expr) (e : Expr) : Array Nat := +let deps := collectDepsAux fvars e #[]; +deps.qsort (fun i j => i < j) + +/-- Update `hasFwdDeps` fields using new `backDeps` -/ +private def updateHasFwdDeps (pinfo : Array ParamInfo) (backDeps : Array Nat) : Array ParamInfo := +if backDeps.size == 0 then + pinfo +else + -- update hasFwdDeps fields + pinfo.mapIdx $ fun i info => + if info.hasFwdDeps then info + else if backDeps.contains i then + { hasFwdDeps := true, .. info } + else + info + +private def getFunInfoAux (fn : Expr) (maxArgs? : Option Nat) : MetaM FunInfo := +checkFunInfoCache fn maxArgs? $ do + fnType ← inferType fn; + usingTransparency TransparencyMode.default $ + forallBoundedTelescope fnType maxArgs? $ fun fvars type => do + pinfo ← fvars.size.foldM + (fun (i : Nat) (pinfo : Array ParamInfo) => do + let fvar := fvars.get! i; + decl ← getFVarLocalDecl fvar; + prop ← isProp decl.type; + let backDeps := collectDeps fvars decl.type; + let pinfo := updateHasFwdDeps pinfo backDeps; + pure $ pinfo.push { + backDeps := backDeps, + prop := prop, + implicit := decl.binderInfo == BinderInfo.implicit, + instImplicit := decl.binderInfo == BinderInfo.instImplicit }) + #[]; + let resultDeps := collectDeps fvars type; + let pinfo := updateHasFwdDeps pinfo resultDeps; + pure { resultDeps := resultDeps, paramInfo := pinfo } + +def getFunInfo (fn : Expr) : MetaM FunInfo := +getFunInfoAux fn none + +def getFunInfoNArgs (fn : Expr) (nargs : Nat) : MetaM FunInfo := +getFunInfoAux fn (some nargs) + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/InferType.lean b/stage0/src/Init/Lean/Meta/InferType.lean new file mode 100644 index 0000000000..d1ecc809ff --- /dev/null +++ b/stage0/src/Init/Lean/Meta/InferType.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.LBool +import Init.Lean.Meta.Basic + +namespace Lean +namespace Meta + +private def inferAppType (f : Expr) (args : Array Expr) : MetaM Expr := +do fType ← inferType f; + (j, fType) ← args.size.foldM + (fun i (acc : Nat × Expr) => + let (j, type) := acc; + match type with + | Expr.forallE _ _ b _ => pure (j, b) + | _ => do + type ← whnf $ type.instantiateRevRange j i args; + match type with + | Expr.forallE _ _ b _ => pure (i, b) + | _ => throwEx $ Exception.functionExpected (mkAppRange f 0 i args) (args.get! i)) + (0, fType); + pure $ fType.instantiateRevRange j args.size args + +private def inferConstType (c : Name) (lvls : List Level) : MetaM Expr := +do env ← getEnv; + match env.find c with + | some cinfo => + if cinfo.lparams.length == lvls.length then + pure $ cinfo.instantiateTypeLevelParams lvls + else + throwEx $ Exception.incorrectNumOfLevels c lvls + | none => + throwEx $ Exception.unknownConst c + +private def inferProjType (structName : Name) (idx : Nat) (e : Expr) : MetaM Expr := +do let failed : Unit → MetaM Expr := fun _ => throwEx $ Exception.invalidProjection structName idx e; + structType ← inferType e; + structType ← whnf structType; + env ← getEnv; + matchConst env structType.getAppFn failed $ fun structInfo structLvls => do + match structInfo with + | ConstantInfo.inductInfo { nparams := n, ctors := [ctor], .. } => + let structParams := structType.getAppArgs; + if n != structParams.size then failed () + else match env.find ctor with + | none => failed () + | some (ctorInfo) => do + ctorType ← inferAppType (mkConst ctor structLvls) structParams; + ctorType ← idx.foldM + (fun i ctorType => do + ctorType ← whnf ctorType; + match ctorType with + | Expr.forallE _ _ body _ => + if body.hasLooseBVars then + pure $ body.instantiate1 $ mkProj structName i e + else + pure body + | _ => failed ()) + ctorType; + ctorType ← whnf ctorType; + match ctorType with + | Expr.forallE _ d _ _ => pure d + | _ => failed () + | _ => failed () + +def getLevel (type : Expr) : MetaM Level := +do typeType ← inferType type; + typeType ← whnf typeType; + match typeType with + | Expr.sort lvl _ => pure lvl + | Expr.mvar mvarId _ => + condM (isReadOnlyOrSyntheticExprMVar mvarId) + (throwEx $ Exception.typeExpected type) + (do levelMVarId ← mkFreshId; + let lvl := mkLevelMVar levelMVarId; + assignExprMVar mvarId (mkSort lvl); + pure lvl) + | _ => throwEx $ Exception.typeExpected type + +private def inferForallType (e : Expr) : MetaM Expr := +forallTelescope e $ fun xs e => do + lvl ← getLevel e; + lvl ← xs.foldrM + (fun x lvl => do + xType ← inferType x; + xTypeLvl ← getLevel xType; + pure $ mkLevelIMax xTypeLvl lvl) + lvl; + pure $ mkSort lvl.normalize + +/- Infer type of lambda and let expressions -/ +private def inferLambdaType (e : Expr) : MetaM Expr := +lambdaTelescope e $ fun xs e => do + type ← inferType e; + mkForall xs type + +@[inline] private def withLocalDecl {α} (name : Name) (bi : BinderInfo) (type : Expr) (x : Expr → MetaM α) : MetaM α := +savingCache $ do + fvarId ← mkFreshId; + adaptReader (fun (ctx : Context) => { lctx := ctx.lctx.mkLocalDecl fvarId name type bi, .. ctx }) $ + x (mkFVar fvarId) + +private def inferMVarType (mvarId : Name) : MetaM Expr := +do mctx ← getMCtx; + match mctx.findDecl mvarId with + | some d => pure d.type + | none => throwEx $ Exception.unknownExprMVar mvarId + +private def inferFVarType (fvarId : Name) : MetaM Expr := +do lctx ← getLCtx; + match lctx.find fvarId with + | some d => pure d.type + | none => throwEx $ Exception.unknownFVar fvarId + +@[inline] private def checkInferTypeCache (e : Expr) (inferType : MetaM Expr) : MetaM Expr := +do s ← get; + match s.cache.inferType.find e with + | some type => pure type + | none => do + type ← inferType; + modify $ fun s => { cache := { inferType := s.cache.inferType.insert e type, .. s.cache }, .. s }; + pure type + +private partial def inferTypeAux : Expr → MetaM Expr +| Expr.const c lvls _ => inferConstType c lvls +| e@(Expr.proj n i s _) => checkInferTypeCache e (inferProjType n i s) +| e@(Expr.app f _ _) => checkInferTypeCache e (inferAppType f.getAppFn e.getAppArgs) +| Expr.mvar mvarId _ => inferMVarType mvarId +| Expr.fvar fvarId _ => inferFVarType fvarId +| Expr.bvar bidx _ => throw $ Exception.unexpectedBVar bidx +| Expr.mdata _ e _ => inferTypeAux e +| Expr.lit v _ => pure v.type +| Expr.sort lvl _ => pure $ mkSort (mkLevelSucc lvl) +| e@(Expr.forallE _ _ _ _) => checkInferTypeCache e (inferForallType e) +| e@(Expr.lam _ _ _ _) => checkInferTypeCache e (inferLambdaType e) +| e@(Expr.letE _ _ _ _ _) => checkInferTypeCache e (inferLambdaType e) +| Expr.localE _ _ _ _ => unreachable! + +def inferTypeImpl (e : Expr) : MetaM Expr := +usingTransparency TransparencyMode.default (inferTypeAux e) + +@[init] def setInferTypeRef : IO Unit := +inferTypeRef.set inferTypeImpl + +/-- + Return `LBool.true` if given level is always equivalent to universe level zero. + It is used to implement `isProp`. -/ +private def isAlwaysZero : Level → Bool +| Level.zero _ => true +| Level.mvar _ _ => false +| Level.param _ _ => false +| Level.succ _ _ => false +| Level.max u v _ => isAlwaysZero u && isAlwaysZero v +| Level.imax _ u _ => isAlwaysZero u + +/-- + `isArrowProp type n` is an "approximate" predicate which returns `LBool.true` + if `type` is of the form `A_1 -> ... -> A_n -> Prop`. + Remark: `type` can be a dependent arrow. -/ +private partial def isArrowProp : Expr → Nat → MetaM LBool +| Expr.sort u _, 0 => do u ← instantiateLevelMVars u; pure $ (isAlwaysZero u).toLBool +| Expr.forallE _ _ _ _, 0 => pure LBool.false +| Expr.forallE _ _ b _, n+1 => isArrowProp b n +| Expr.letE _ _ _ b _, n => isArrowProp b n +| Expr.mdata _ e _, n => isArrowProp e n +| _, _ => pure LBool.undef + +/-- + `isPropQuickApp f n` is an "approximate" predicate which returns `LBool.true` + if `f` applied to `n` arguments is a proposition. -/ +private partial def isPropQuickApp : Expr → Nat → MetaM LBool +| Expr.const c lvls _, arity => do constType ← inferConstType c lvls; isArrowProp constType arity +| Expr.fvar fvarId _, arity => do fvarType ← inferFVarType fvarId; isArrowProp fvarType arity +| Expr.mvar mvarId _, arity => do mvarType ← inferMVarType mvarId; isArrowProp mvarType arity +| Expr.app f _ _, arity => isPropQuickApp f (arity+1) +| Expr.mdata _ e _, arity => isPropQuickApp e arity +| Expr.letE _ _ _ b _, arity => isPropQuickApp b arity +| Expr.lam _ _ _ _, 0 => pure LBool.false +| Expr.lam _ _ b _, arity+1 => isPropQuickApp b arity +| _, _ => pure LBool.undef + +/-- + `isPropQuick e` is an "approximate" predicate which returns `LBool.true` + if `e` is a proposition. -/ +private partial def isPropQuick : Expr → MetaM LBool +| Expr.bvar _ _ => pure LBool.undef +| Expr.lit _ _ => pure LBool.false +| Expr.sort _ _ => pure LBool.false +| Expr.lam _ _ _ _ => pure LBool.false +| Expr.letE _ _ _ b _ => isPropQuick b +| Expr.proj _ _ _ _ => pure LBool.undef +| Expr.forallE _ _ b _ => isPropQuick b +| Expr.mdata _ e _ => isPropQuick e +| Expr.const c lvls _ => do constType ← inferConstType c lvls; isArrowProp constType 0 +| Expr.fvar fvarId _ => do fvarType ← inferFVarType fvarId; isArrowProp fvarType 0 +| Expr.mvar mvarId _ => do mvarType ← inferMVarType mvarId; isArrowProp mvarType 0 +| Expr.app f _ _ => isPropQuickApp f 1 +| Expr.localE _ _ _ _ => unreachable! + +/-- `isProp whnf e` return `true` if `e` is a proposition. + + If `e` contains metavariables, it may not be possible + to decide whether is a proposition or not. We return `false` in this + case. We considered using `LBool` and retuning `LBool.undef`, but + we have no applications for it. -/ +def isProp (e : Expr) : MetaM Bool := +do r ← isPropQuick e; + match r with + | LBool.true => pure true + | LBool.false => pure false + | LBool.undef => do + -- dbgTrace ("PropQuick failed " ++ toString e); + type ← inferType e; + type ← whnfUsingDefault type; + match type with + | Expr.sort u _ => do u ← instantiateLevelMVars u; pure $ isAlwaysZero u + | _ => pure false + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/LevelDefEq.lean b/stage0/src/Init/Lean/Meta/LevelDefEq.lean new file mode 100644 index 0000000000..59e1aa4fb8 --- /dev/null +++ b/stage0/src/Init/Lean/Meta/LevelDefEq.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Meta.Basic + +namespace Lean +namespace Meta + +private def strictOccursMaxAux (lvl : Level) : Level → Bool +| Level.max u v _ => strictOccursMaxAux u || strictOccursMaxAux v +| u => u != lvl && lvl.occurs u + +/-- + Return true iff `lvl` occurs in `max u_1 ... u_n` and `lvl != u_i` for all `i in [1, n]`. + That is, `lvl` is a proper level subterm of some `u_i`. -/ +private def strictOccursMax (lvl : Level) : Level → Bool +| Level.max u v _ => strictOccursMaxAux lvl u || strictOccursMaxAux lvl v +| _ => false + +/-- `mkMaxArgsDiff mvarId (max u_1 ... (mvar mvarId) ... u_n) v` => `max v u_1 ... u_n` -/ +private def mkMaxArgsDiff (mvarId : Name) : Level → Level → Level +| Level.max u v _, acc => mkMaxArgsDiff v $ mkMaxArgsDiff u acc +| l@(Level.mvar id _), acc => if id != mvarId then mkLevelMax acc l else acc +| l, acc => mkLevelMax acc l + +/-- + Solve `?m =?= max ?m v` by creating a fresh metavariable `?n` + and assigning `?m := max ?n v` -/ +private def solveSelfMax (mId : Name) (v : Level) : MetaM Unit := +do n ← mkFreshLevelMVar; + assignLevelMVar mId $ mkMaxArgsDiff mId v n + +private def postponeIsLevelDefEq (lhs : Level) (rhs : Level) : MetaM Unit := +modify $ fun s => { postponed := s.postponed.push { lhs := lhs, rhs := rhs }, .. s } + +inductive LevelConstraintKind +| mvarEq -- ?m =?= l where ?m does not occur in l +| mvarEqSelfMax -- ?m =?= max ?m l where ?m does not occur in l +| other + +private def getLevelConstraintKind (u v : Level) : MetaM LevelConstraintKind := +match u with +| Level.mvar mvarId _ => + condM (isReadOnlyLevelMVar mvarId) + (pure LevelConstraintKind.other) + (if !u.occurs v then pure LevelConstraintKind.mvarEq + else if !strictOccursMax u v then pure LevelConstraintKind.mvarEqSelfMax + else pure LevelConstraintKind.other) +| _ => + pure LevelConstraintKind.other + +partial def isLevelDefEqAux : Level → Level → MetaM Bool +| Level.succ lhs _, Level.succ rhs _ => isLevelDefEqAux lhs rhs +| lhs, rhs => + if lhs == rhs then + pure true + else do + trace! `Meta.isLevelDefEq.step (lhs ++ " =?= " ++ rhs); + lhs' ← instantiateLevelMVars lhs; + let lhs' := lhs'.normalize; + rhs' ← instantiateLevelMVars rhs; + let rhs' := rhs'.normalize; + if lhs != lhs' || rhs != rhs' then + isLevelDefEqAux lhs' rhs' + else do + mctx ← getMCtx; + if !mctx.hasAssignableLevelMVar lhs && !mctx.hasAssignableLevelMVar rhs then + pure false + else do + k ← getLevelConstraintKind lhs rhs; + match k with + | LevelConstraintKind.mvarEq => do assignLevelMVar lhs.mvarId! rhs; pure true + | LevelConstraintKind.mvarEqSelfMax => do solveSelfMax lhs.mvarId! rhs; pure true + | _ => do + k ← getLevelConstraintKind rhs lhs; + match k with + | LevelConstraintKind.mvarEq => do assignLevelMVar rhs.mvarId! lhs; pure true + | LevelConstraintKind.mvarEqSelfMax => do solveSelfMax rhs.mvarId! lhs; pure true + | _ => + if lhs.isMVar || rhs.isMVar then + pure false + else if lhs.isSucc || rhs.isSucc then + match lhs.dec, rhs.dec with + | some lhs', some rhs' => isLevelDefEqAux lhs' rhs' + | _, _ => do postponeIsLevelDefEq lhs rhs; pure true + else do postponeIsLevelDefEq lhs rhs; pure true + +def isListLevelDefEqAux : List Level → List Level → MetaM Bool +| [], [] => pure true +| u::us, v::vs => isLevelDefEqAux u v <&&> isListLevelDefEqAux us vs +| _, _ => pure false + +private def getNumPostponed : MetaM Nat := +do s ← get; + pure s.postponed.size + +private def getResetPostponed : MetaM (PersistentArray PostponedEntry) := +do s ← get; + let ps := s.postponed; + modify $ fun s => { postponed := {}, .. s }; + pure ps + +private def processPostponedStep : MetaM Bool := +traceCtx `type_context.level_is_def_eq.postponed_step $ do + ps ← getResetPostponed; + ps.foldlM + (fun (r : Bool) (p : PostponedEntry) => + if r then + isLevelDefEqAux p.lhs p.rhs + else + pure false) + true + +private partial def processPostponedAux : Unit → MetaM Bool +| _ => do + numPostponed ← getNumPostponed; + if numPostponed == 0 then + pure true + else do + trace! `type_context.level_is_def_eq ("processing #" ++ toString numPostponed ++ " postponed is-def-eq level constraints"); + r ← processPostponedStep; + if !r then + pure r + else do + numPostponed' ← getNumPostponed; + if numPostponed' == 0 then + pure true + else if numPostponed' < numPostponed then + processPostponedAux () + else do + trace! `type_context.level_is_def_eq ("no progress solving pending is-def-eq level constraints"); + pure false + +private def processPostponed : MetaM Bool := +do numPostponed ← getNumPostponed; + if numPostponed == 0 then pure true + else traceCtx `type_context.level_is_def_eq.postponed $ processPostponedAux () + + +private def restore (env : Environment) (mctx : MetavarContext) (postponed : PersistentArray PostponedEntry) : MetaM Unit := +modify $ fun s => { env := env, mctx := mctx, postponed := postponed, .. s } + +/-- + `try x` executes `x` and process all postponed universe level constraints produced by `x`. + We keep the modifications only if both return `true`. + + Remark: postponed universe level constraints must be solved before returning. Otherwise, + we don't know whether `x` really succeeded. -/ +@[specialize] def try (x : MetaM Bool) : MetaM Bool := +do s ← get; + let env := s.env; + let mctx := s.mctx; + let postponed := s.postponed; + modify $ fun s => { postponed := {}, .. s }; + catch + (condM x + (condM processPostponed + (pure true) + (do restore env mctx postponed; pure false)) + (do restore env mctx postponed; pure false)) + (fun ex => do restore env mctx postponed; throw ex) + +/- Public interface -/ + +def isLevelDefEq (u v : Level) : MetaM Bool := +traceCtx `Meta.isLevelDefEq $ do + b ← try $ isLevelDefEqAux u v; + trace! `Meta.isLevelDefEq (u ++ " =?= " ++ v ++ " ... " ++ if b then "success" else "failure"); + pure b + +def isExprDefEq (t s : Expr) : MetaM Bool := +traceCtx `Meta.isDefEq $ do + b ← try $ isExprDefEqAux t s; + trace! `Meta.isDefEq (t ++ " =?= " ++ s ++ " ... " ++ if b then "success" else "failure"); + pure b + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/Offset.lean b/stage0/src/Init/Lean/Meta/Offset.lean new file mode 100644 index 0000000000..31b028a1e2 --- /dev/null +++ b/stage0/src/Init/Lean/Meta/Offset.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.LBool +import Init.Lean.Meta.InferType + +namespace Lean +namespace Meta + +partial def evalNat : Expr → Option Nat +| Expr.lit (Literal.natVal n) _ => pure n +| Expr.mdata _ e _ => evalNat e +| Expr.const `Nat.zero _ _ => pure 0 +| e@(Expr.app _ a _) => + let fn := e.getAppFn; + match fn with + | Expr.const c _ _ => + let nargs := e.getAppNumArgs; + if c == `Nat.succ && nargs == 1 then do + v ← evalNat a; pure $ v+1 + else if c == `Nat.add && nargs == 2 then do + v₁ ← evalNat (e.getArg! 0); + v₂ ← evalNat (e.getArg! 1); + pure $ v₁ + v₂ + else if c == `Nat.sub && nargs == 2 then do + v₁ ← evalNat (e.getArg! 0); + v₂ ← evalNat (e.getArg! 1); + pure $ v₁ - v₂ + else if c == `Nat.mul && nargs == 2 then do + v₁ ← evalNat (e.getArg! 0); + v₂ ← evalNat (e.getArg! 1); + pure $ v₁ * v₂ + else if c == `HasAdd.add && nargs == 4 then do + v₁ ← evalNat (e.getArg! 2); + v₂ ← evalNat (e.getArg! 3); + pure $ v₁ + v₂ + else if c == `HasAdd.sub && nargs == 4 then do + v₁ ← evalNat (e.getArg! 2); + v₂ ← evalNat (e.getArg! 3); + pure $ v₁ - v₂ + else if c == `HasAdd.mul && nargs == 4 then do + v₁ ← evalNat (e.getArg! 2); + v₂ ← evalNat (e.getArg! 3); + pure $ v₁ * v₂ + else + none + | _ => none +| _ => none + +/- Quick function for converting `e` into `s + k` s.t. `e` is definitionally equal to `Nat.add s k`. -/ +private partial def getOffset : Expr → Expr × Nat +| e@(Expr.app _ a _) => + let fn := e.getAppFn; + match fn with + | Expr.const c _ _ => + let nargs := e.getAppNumArgs; + if c == `Nat.succ && nargs == 1 then + let (s, k) := getOffset a; + (s, k+1) + else if c == `Nat.add && nargs == 2 then + match evalNat (e.getArg! 1) with + | none => (e, 0) + | some v => + let (s, k) := getOffset (e.getArg! 0); + (s, k+v) + else if c == `HasAdd.add && nargs == 4 then + match evalNat (e.getArg! 3) with + | none => (e, 0) + | some v => + let (s, k) := getOffset (e.getArg! 0); + (s, k+v) + else + (e, 0) + | _ => (e, 0) +| e => (e, 0) + +private partial def isOffset : Expr → Option (Expr × Nat) +| e@(Expr.app _ a _) => + let fn := e.getAppFn; + match fn with + | Expr.const c _ _ => + let nargs := e.getAppNumArgs; + if (c == `Nat.succ && nargs == 1) || (c == `Nat.add && nargs == 2) || (c == `HasAdd.add && nargs == 4) then + some (getOffset e) + else none + | _ => none +| _ => none + +def isDefEqOffset (s t : Expr) : MetaM LBool := +let isDefEq (s t) : MetaM LBool := toLBoolM $ isExprDefEqAux s t; +match isOffset s with +| some (s, k₁) => match isOffset t with + | some (t, k₂) => -- s+k₁ =?= t+k₂ + if k₁ == k₂ then isDefEq s t + else if k₁ < k₂ then isDefEq s (mkCAppB `Nat.add t (mkNatLit $ k₂ - k₁)) + else isDefEq (mkCAppB `Nat.add s (mkNatLit $ k₁ - k₂)) t + | none => match evalNat t with + | some v₂ => -- s+k₁ =?= v₂ + if v₂ ≥ k₁ then isDefEq s (mkNatLit $ v₂ - k₁) else pure LBool.false + | none => pure LBool.undef +| none => match evalNat s with + | some v₁ => match isOffset t with + | some (t, k₂) => -- v₁ =?= t+k₂ + if v₁ ≥ k₂ then isDefEq s (mkNatLit $ v₁ - k₂) else pure LBool.false + | none => match evalNat t with + | some v₂ => pure (v₁ == v₂).toLBool -- v₁ =?= v₂ + | none => pure LBool.undef + | none => pure LBool.undef + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/Meta/WHNF.lean b/stage0/src/Init/Lean/Meta/WHNF.lean new file mode 100644 index 0000000000..b886cdb0b3 --- /dev/null +++ b/stage0/src/Init/Lean/Meta/WHNF.lean @@ -0,0 +1,36 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.AuxRecursor +import Init.Lean.WHNF +import Init.Lean.Meta.Basic +import Init.Lean.Meta.LevelDefEq + +namespace Lean +namespace Meta + +def isAuxDef? (constName : Name) : MetaM Bool := +do env ← getEnv; pure (isAuxRecursor env constName || isNoConfusion env constName) + +def unfoldDefinition (e : Expr) : MetaM (Option Expr) := +Lean.WHNF.unfoldDefinitionAux getConstNoEx isAuxDef? whnf inferType isExprDefEq synthPending getLocalDecl getExprMVarAssignment e + +def whnfCore (e : Expr) : MetaM Expr := +Lean.WHNF.whnfCore getConstNoEx isAuxDef? whnf inferType isExprDefEqAux getLocalDecl getExprMVarAssignment e + +partial def whnfImpl : Expr → MetaM Expr +| e => Lean.WHNF.whnfEasyCases getLocalDecl getExprMVarAssignment e $ fun e => do + e ← whnfCore e; + e? ← unfoldDefinition e; + match e? with + | some e => whnfImpl e + | none => pure e + +@[init] def setWHNFRef : IO Unit := +whnfRef.set whnfImpl + +end Meta +end Lean diff --git a/stage0/src/Init/Lean/MetavarContext.lean b/stage0/src/Init/Lean/MetavarContext.lean new file mode 100644 index 0000000000..909abd4145 --- /dev/null +++ b/stage0/src/Init/Lean/MetavarContext.lean @@ -0,0 +1,759 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Nat +import Init.Data.Option +import Init.Control.Reader +import Init.Lean.LocalContext +import Init.Lean.MonadCache +import Init.Lean.NameGenerator + +namespace Lean + +/- +The metavariable context stores metavariable declarations and their +assignments. It is used in the elaborator, tactic framework, unifier +(aka `isDefEq`), and type class resolution (TC). First, we list all +the requirements imposed by these modules. + +- We may invoke TC while executing `isDefEq`. We need this feature to +be able to solve unification problems such as: +``` +f ?a (ringHasAdd ?s) ?x ?y =?= f Int intHasAdd n m +``` +where `(?a : Type) (?s : Ring ?a) (?x ?y : ?a)` +During `isDefEq` (i.e., unification), it will need to solve the constrain +``` +ringHasAdd ?s =?= intHasAdd +``` +We say `ringHasAdd ?s` is stuck because it cannot be reduced until we +synthesize the term `?s : Ring ?a` using TC. This can be done since we +have assigned `?a := Int` when solving `?a =?= Int`. + +- TC uses `isDefEq`, and `isDefEq` may create TC problems as shown +aaa. Thus, we may have nested TC problems. + +- `isDefEq` extends the local context when going inside binders. Thus, +the local context for nested TC may be an extension of the local +context for outer TC. + +- TC should not assign metavariables created by the elaborator, simp, +tactic framework, and outer TC problems. Reason: TC commits to the +first solution it finds. Consider the TC problem `HasCoe Nat ?x`, +where `?x` is a metavariable created by the caller. There are many +solutions to this problem (e.g., `?x := Int`, `?x := Real`, ...), +and it doesn’t make sense to commit to the first one since TC does +not know the the constraints the caller may impose on `?x` after the +TC problem is solved. +Remark: we claim it is not feasible to make the whole system backtrackable, +and allow the caller to backtrack back to TC and ask it for another solution +if the first one found did not work. We claim it would be too inefficient. + +- TC metavariables should not leak outside of TC. Reason: we want to +get rid of them after we synthesize the instance. + +- `simp` invokes `isDefEq` for matching the left-hand-side of +equations to terms in our goal. Thus, it may invoke TC indirectly. + +- In Lean3, we didn’t have to create a fresh pattern for trying to +match the left-hand-side of equations when executing `simp`. We had a +mechanism called tmp metavariables. It avoided this overhead, but it +created many problems since `simp` may indirectly call TC which may +recursively call TC. Moreover, we want to allow TC to invoke +tactics. Thus, when `simp` invokes `isDefEq`, it may indirectly invoke +a tactic and `simp` itself. The Lean3 approach assumed that +metavariables were short-lived, this is not true in Lean4, and to some +extent was also not true in Lean3 since `simp`, in principle, could +trigger an arbitrary number of nested TC problems. + +- Here are some possible call stack traces we could have in Lean3 (and Lean4). +``` +Elaborator (-> TC -> isDefEq)+ +Elaborator -> isDefEq (-> TC -> isDefEq)* +Elaborator -> simp -> isDefEq (-> TC -> isDefEq)* +``` +In Lean4, TC may also invoke tactics. + +- In Lean3 and Lean4, TC metavariables are not really short-lived. We +solve an arbitrary number of unification problems, and we may have +nested TC invocations. + +- TC metavariables do not share the same local context even in the +same invocation. In the C++ and Lean implementations we use a trick to +ensure they do: +https://github.com/leanprover/lean/blob/92826917a252a6092cffaf5fc5f1acb1f8cef379/src/library/type_context.cpp#L3583-L3594 + +- Metavariables may be natural or synthetic. Natural metavariables may +be assigned by the unification (i.e., `isDefEq`). Synthetic +metavariables are assigned by procedures (e.g., TC, tactic, or +elaborator). This distinction was not precise in Lean3 and produced +counterintuitive behavior. For example, the following hack was added +in Lean3 to work around one of these issues: +https://github.com/leanprover/lean/blob/92826917a252a6092cffaf5fc5f1acb1f8cef379/src/library/type_context.cpp#L2751 +`isDefEq` should not assign synthetic metavariables, but it must +accumulate the constraints imposed on them by unification. + +- When creating lambda/forall expressions, we need to convert/abstract +free variables and convert them to bound variables. Now, suppose we a +trying to create a lambda/forall expression by abstracting free +variables `xs` and a term `t[?m]` which contains a metavariable `?m`, +and the local context of `?m` contains `xs`. The term +``` +fun xs => t[?m] +``` +will be ill-formed if we later assign a term `s` to `?m`, and +`s` contains free variables in `xs`. We address this issue by changing +the free variable abstraction procedure. We consider two cases: `?m` +is natural, `?m` is synthetic. Assume the type of `?m` is +`A`. Then, in both cases we create an auxiliary metavariable `?n` with +type `forall xs => A`, and local context := local context of `?m` - `xs`. +In both cases, we produce the term `fun xs => t[?n xs]` + + 1- If `?m` is natural, then we assign `?m := ?n xs`, and we produce + the term `fun xs => t[?n xs]` + + 2- If `?m` is synthetic, then we mark `?n` as a synthetic variable. + However, `?n` is managed by the metavariable context itself. + We say we have a "delayed assignment" `?n xs := ?m`. + That is, after a term `s` is assigned to `?m`, and `s` + does not contain metavariables, we assign `fun xs => s` to `?n`. + +Gruesome details: + + - When we create the type `forall xs => A` for `?n`, we may + encounter the same issue if `A` contains metavariables. So, the + process above is recursive. We claim it terminates because we keep + creating new metavariables with smaller local contexts. + + - The type of variables `xs` may contain metavariables, and we must + recursively apply the process above. Again, we claim the process + terminates because the metavariables is ocurring in the types of + `xs`, they must have smaller local contexts. + + - We can only assign `fun xs => s` to `?n` in case 2, the types of + `xs` must also not contain metavariables. To be precise, it is + sufficient they do not contain metavariables with local contexts + containing any of the `xs`s. + +- We use TC for implementing coercions. Both Joe Hendrix and Reid Barton +reported a nasty limitation. In Lean3, TC will not be used if there are +metavariables in the TC problem. For example, the elaborator will not try +to synthesize `HasCoe Nat ?x`. This is good, but this constraint is too +strict for problems such as `HasCoe (Vector Bool ?n) (BV ?n)`. The coercion +exists independently of `?n`. Thus, during TC, we want `isDefEq` to throw +an exception instead of return `false` whenever it tries to assign +a metavariable owned by its caller. The idea is to sign to the caller that +it cannot solve the TC problem at this point, and more information is needed. +That is, the caller must make progress an assign its metavariables before +trying to invoke TC again. + +In Lean4, we are using a simpler design for the `MetavarContext`. + +- No distinction betwen temporary and regular metavariables. + +- Metavariables have a `depth` Nat field. + +- MetavarContext also has a `depth` field. + +- We bump the `MetavarContext` depth when we create a nested problem. + Example: Elaborator (depth = 0) -> Simplifier matcher (depth = 1) -> TC (level = 2) -> TC (level = 3) -> ... + +- When `MetavarContext` is at depth N, `isDefEq` does not assign variables from `depth < N`. + +- Metavariables from depth N+1 must be fully assigned before we return to level N. + +- New design even allows us to invoke tactics from TC. + +* Main concern +We don't have tmp metavariables anymore in Lean4. Thus, before trying to match +the left-hand-side of an equation in `simp`. We first must bump the level of the `MetavarContext`, +create fresh metavariables, then create a new pattern by replacing the free variable on the left-hand-side with +these metavariables. We are hoping to minimize this overhead by + + - Using better indexing data structures in `simp`. They should reduce the number of time `simp` must invoke `isDefEq`. + + - Implementing `isDefEqApprox` which ignores metavariables and returns only `false` or `undef`. + It is a quick filter that allows us to fail quickly and avoid the creation of new fresh metavariables, + and a new pattern. + + - Adding built-in support for arithmetic, Logical connectives, etc. Thus, we avoid a bunch of lemmas in the simp set. + + - Adding support for AC-rewriting. In Lean3, users use AC lemmas as + rewriting rules for "sorting" terms. This is inefficient, requires + a quadratic number of rewrite steps, and does not preserve the + structure of the goal. + +The temporary metavariables were also used in the "app builder" module used in Lean3. The app builder uses +`isDefEq`. So, it could, in principle, invoke an arbitrary number of nested TC problems. However, in Lean3, +all app builder uses are controlled. That is, it is mainly used to synthesize implicit arguments using +very simple unification and/or non-nested TC. So, if the "app builder" becomes a bottleneck without tmp metavars, +we may solve the issue by implementing `isDefEqCheap` that never invokes TC and uses tmp metavars. +-/ + +structure MetavarDecl := +(userName : Name := Name.anonymous) +(lctx : LocalContext) +(type : Expr) +(depth : Nat) +(synthetic : Bool) + +namespace MetavarDecl +instance : Inhabited MetavarDecl := ⟨{ lctx := arbitrary _, type := arbitrary _, depth := 0, synthetic := false }⟩ +end MetavarDecl + +/-- + A delayed assignment for a metavariable `?m`. It represents an assignment of the form + `?m := (fun fvars => val)`. The local context `lctx` provides the declarations for `fvars`. + Note that `fvars` may not be defined in the local context for `?m`. -/ +structure DelayedMetavarAssignment := +(lctx : LocalContext) +(fvars : Array Expr) +(val : Expr) + +structure MetavarContext := +(depth : Nat := 0) +(lDepth : PersistentHashMap Name Nat := {}) +(decls : PersistentHashMap Name MetavarDecl := {}) +(lAssignment : PersistentHashMap Name Level := {}) +(eAssignment : PersistentHashMap Name Expr := {}) +(dAssignment : PersistentHashMap Name DelayedMetavarAssignment := {}) + +namespace MetavarContext + +instance : Inhabited MetavarContext := ⟨{}⟩ + +@[export lean_mk_metavar_ctx] +def mkMetavarContext : Unit → MetavarContext := +fun _ => {} + +/- Low level API for adding/declaring metavariable declarations. + It is used to implement actions in the monads `MetaM`, `ElabM` and `TacticM`. + It should not be used directly since the argument `(mvarId : Name)` is assumed to be "unique". -/ +@[export lean_metavar_ctx_mk_decl] +def addExprMVarDecl (mctx : MetavarContext) (mvarId : Name) (userName : Name) (lctx : LocalContext) (type : Expr) (synthetic : Bool := false) : MetavarContext := +{ decls := mctx.decls.insert mvarId { + userName := userName, + lctx := lctx, + type := type, + depth := mctx.depth, + synthetic := synthetic }, + .. mctx } + +/- Low level API for adding/declaring universe level metavariable declarations. + It is used to implement actions in the monads `MetaM`, `ElabM` and `TacticM`. + It should not be used directly since the argument `(mvarId : Name)` is assumed to be "unique". -/ +def addLevelMVarDecl (mctx : MetavarContext) (mvarId : Name) : MetavarContext := +{ lDepth := mctx.lDepth.insert mvarId mctx.depth, + .. mctx } + +@[export lean_metavar_ctx_find_decl] +def findDecl (mctx : MetavarContext) (mvarId : Name) : Option MetavarDecl := +mctx.decls.find mvarId + +def getDecl (mctx : MetavarContext) (mvarId : Name) : MetavarDecl := +match mctx.decls.find mvarId with +| some decl => decl +| none => panic! "unknown metavariable" + +def findLevelDepth (mctx : MetavarContext) (mvarId : Name) : Option Nat := +mctx.lDepth.find mvarId + +@[export lean_metavar_ctx_assign_level] +def assignLevel (m : MetavarContext) (mvarId : Name) (val : Level) : MetavarContext := +{ lAssignment := m.lAssignment.insert mvarId val, .. m } + +@[export lean_metavar_ctx_assign_expr] +def assignExpr (m : MetavarContext) (mvarId : Name) (val : Expr) : MetavarContext := +{ eAssignment := m.eAssignment.insert mvarId val, .. m } + +@[export lean_metavar_ctx_assign_delayed] +def assignDelayed (m : MetavarContext) (mvarId : Name) (lctx : LocalContext) (fvars : Array Expr) (val : Expr) : MetavarContext := +{ dAssignment := m.dAssignment.insert mvarId { lctx := lctx, fvars := fvars, val := val }, .. m } + +@[export lean_metavar_ctx_get_level_assignment] +def getLevelAssignment (m : MetavarContext) (mvarId : Name) : Option Level := +m.lAssignment.find mvarId + +@[export lean_metavar_ctx_get_expr_assignment] +def getExprAssignment (m : MetavarContext) (mvarId : Name) : Option Expr := +m.eAssignment.find mvarId + +@[export lean_metavar_ctx_get_delayed_assignment] +def getDelayedAssignment (m : MetavarContext) (mvarId : Name) : Option DelayedMetavarAssignment := +m.dAssignment.find mvarId + +@[export lean_metavar_ctx_is_level_assigned] +def isLevelAssigned (m : MetavarContext) (mvarId : Name) : Bool := +m.lAssignment.contains mvarId + +@[export lean_metavar_ctx_is_expr_assigned] +def isExprAssigned (m : MetavarContext) (mvarId : Name) : Bool := +m.eAssignment.contains mvarId + +@[export lean_metavar_ctx_is_delayed_assigned] +def isDelayedAssigned (m : MetavarContext) (mvarId : Name) : Bool := +m.dAssignment.contains mvarId + +@[export lean_metavar_ctx_erase_delayed] +def eraseDelayed (m : MetavarContext) (mvarId : Name) : MetavarContext := +{ dAssignment := m.dAssignment.erase mvarId, .. m } + +def isLevelAssignable (mctx : MetavarContext) (mvarId : Name) : Bool := +match mctx.lDepth.find mvarId with +| some d => d == mctx.depth +| _ => panic! "unknown universe metavariable" + +def isExprAssignable (mctx : MetavarContext) (mvarId : Name) : Bool := +let decl := mctx.getDecl mvarId; +decl.depth == mctx.depth + +/-- Return true iff the given level contains an assigned metavariable. -/ +def hasAssignedLevelMVar (mctx : MetavarContext) : Level → Bool +| Level.succ lvl _ => lvl.hasMVar && hasAssignedLevelMVar lvl +| Level.max lvl₁ lvl₂ _ => (lvl₁.hasMVar && hasAssignedLevelMVar lvl₁) || (lvl₂.hasMVar && hasAssignedLevelMVar lvl₂) +| Level.imax lvl₁ lvl₂ _ => (lvl₁.hasMVar && hasAssignedLevelMVar lvl₁) || (lvl₂.hasMVar && hasAssignedLevelMVar lvl₂) +| Level.mvar mvarId _ => mctx.isLevelAssigned mvarId +| Level.zero _ => false +| Level.param _ _ => false + +/-- Return `true` iff expression contains assigned (level/expr) metavariables -/ +def hasAssignedMVar (mctx : MetavarContext) : Expr → Bool +| Expr.const _ lvls _ => lvls.any (hasAssignedLevelMVar mctx) +| Expr.sort lvl _ => hasAssignedLevelMVar mctx lvl +| Expr.app f a _ => (f.hasMVar && hasAssignedMVar f) || (a.hasMVar && hasAssignedMVar a) +| Expr.letE _ t v b _ => (t.hasMVar && hasAssignedMVar t) || (v.hasMVar && hasAssignedMVar v) || (b.hasMVar && hasAssignedMVar b) +| Expr.forallE _ d b _ => (d.hasMVar && hasAssignedMVar d) || (b.hasMVar && hasAssignedMVar b) +| Expr.lam _ d b _ => (d.hasMVar && hasAssignedMVar d) || (b.hasMVar && hasAssignedMVar b) +| Expr.fvar _ _ => false +| Expr.bvar _ _ => false +| Expr.lit _ _ => false +| Expr.mdata _ e _ => e.hasMVar && hasAssignedMVar e +| Expr.proj _ _ e _ => e.hasMVar && hasAssignedMVar e +| Expr.mvar mvarId _ => mctx.isExprAssigned mvarId +| Expr.localE _ _ _ _ => unreachable! + +/-- Return true iff the given level contains a metavariable that can be assigned. -/ +def hasAssignableLevelMVar (mctx : MetavarContext) : Level → Bool +| Level.succ lvl _ => lvl.hasMVar && hasAssignableLevelMVar lvl +| Level.max lvl₁ lvl₂ _ => (lvl₁.hasMVar && hasAssignableLevelMVar lvl₁) || (lvl₂.hasMVar && hasAssignableLevelMVar lvl₂) +| Level.imax lvl₁ lvl₂ _ => (lvl₁.hasMVar && hasAssignableLevelMVar lvl₁) || (lvl₂.hasMVar && hasAssignableLevelMVar lvl₂) +| Level.mvar mvarId _ => mctx.isLevelAssignable mvarId +| Level.zero _ => false +| Level.param _ _ => false + +partial def instantiateLevelMVars : Level → StateM MetavarContext Level +| lvl@(Level.succ lvl₁ _) => do lvl₁ ← instantiateLevelMVars lvl₁; pure (Level.updateSucc! lvl lvl₁) +| lvl@(Level.max lvl₁ lvl₂ _) => do lvl₁ ← instantiateLevelMVars lvl₁; lvl₂ ← instantiateLevelMVars lvl₂; pure (Level.updateMax! lvl lvl₁ lvl₂) +| lvl@(Level.imax lvl₁ lvl₂ _) => do lvl₁ ← instantiateLevelMVars lvl₁; lvl₂ ← instantiateLevelMVars lvl₂; pure (Level.updateIMax! lvl lvl₁ lvl₂) +| lvl@(Level.mvar mvarId _) => do + mctx ← get; + match getLevelAssignment mctx mvarId with + | some newLvl => + if !newLvl.hasMVar then pure newLvl + else do + newLvl' ← instantiateLevelMVars newLvl; + modify $ fun mctx => mctx.assignLevel mvarId newLvl'; + pure newLvl' + | none => pure lvl +| lvl => pure lvl + +namespace InstantiateExprMVars +private abbrev M := StateM (WithHashMapCache Expr Expr MetavarContext) + +@[inline] def instantiateLevelMVars (lvl : Level) : M Level := +WithHashMapCache.fromState $ MetavarContext.instantiateLevelMVars lvl + +@[inline] private def visit (f : Expr → M Expr) (e : Expr) : M Expr := +if !e.hasMVar then pure e else checkCache e f + +@[inline] private def getMCtx : M MetavarContext := +do s ← get; pure s.state + +@[inline] private def modifyCtx (f : MetavarContext → MetavarContext) : M Unit := +modify $ fun s => { state := f s.state, .. s } + +/-- + Auxiliary function for `instantiateDelayed`. + `instantiateDelayed main lctx fvars i body` is used to create `fun fvars[0, i) => body`. + It fails if one of variable declarations in `fvars` still contains unassigned metavariables. + + Pre: all expressions in `fvars` are `Expr.fvar`, and `lctx` contains their declarations. -/ +@[specialize] private def instantiateDelayedAux (main : Expr → M Expr) (lctx : LocalContext) (fvars : Array Expr) : Nat → Expr → M (Option Expr) +| 0, b => pure b +| i+1, b => do + let fvar := fvars.get! i; + match lctx.findFVar fvar with + | none => panic! "unknown free variable" + | some (LocalDecl.cdecl _ _ n ty bi) => do + ty ← visit main ty; + if ty.hasMVar then pure none + else instantiateDelayedAux i (Lean.mkLambda n bi (ty.abstractRange i fvars) b) + | some (LocalDecl.ldecl _ _ n ty val) => do + ty ← visit main ty; + if ty.hasMVar then pure none + else do + val ← visit main val; + if val.hasMVar then pure none + else + let ty := ty.abstractRange i fvars; + let val := val.abstractRange i fvars; + instantiateDelayedAux i (mkLet n ty val b) + +/-- Try to instantiate a delayed assignment. Return `none` (i.e., fail) if assignment still contains variables. -/ +@[inline] private def instantiateDelayed (main : Expr → M Expr) (mvarId : Name) : DelayedMetavarAssignment → M (Option Expr) +| { lctx := lctx, fvars := fvars, val := val } => do + newVal ← visit main val; + let fail : M (Option Expr) := do { + /- Join point for updating delayed assignment and failing -/ + modifyCtx $ fun mctx => assignDelayed mctx mvarId lctx fvars newVal; + pure none + }; + if newVal.hasMVar then fail + else do + /- Create `fun fvars => newVal`. + It fails if there is a one of the variable declarations in `fvars` still contain metavariables. -/ + newE ← instantiateDelayedAux main lctx fvars fvars.size (newVal.abstract fvars); + match newE with + | none => fail + | some newE => do + /- Succeeded. Thus, replace delayed assignment with a regular assignment. -/ + modifyCtx $ fun mctx => assignExpr (eraseDelayed mctx mvarId) mvarId newE; + pure (some newE) + +/-- instantiateExprMVars main function -/ +partial def main : Expr → M Expr +| e@(Expr.proj _ _ s _) => do s ← visit main s; pure (e.updateProj! s) +| e@(Expr.forallE _ d b _) => do d ← visit main d; b ← visit main b; pure (e.updateForallE! d b) +| e@(Expr.lam _ d b _) => do d ← visit main d; b ← visit main b; pure (e.updateLambdaE! d b) +| e@(Expr.letE _ t v b _) => do t ← visit main t; v ← visit main v; b ← visit main b; pure (e.updateLet! t v b) +| e@(Expr.const _ lvls _) => do lvls ← lvls.mapM instantiateLevelMVars; pure (e.updateConst! lvls) +| e@(Expr.sort lvl _) => do lvl ← instantiateLevelMVars lvl; pure (e.updateSort! lvl) +| e@(Expr.mdata _ b _) => do b ← visit main b; pure (e.updateMData! b) +| e@(Expr.app _ _ _) => e.withAppRev $ fun f revArgs => do + let wasMVar := f.isMVar; + f ← visit main f; + if wasMVar && f.isLambda then + -- Some of the arguments in revArgs are irrelevant after we beta reduce. + visit main (f.betaRev revArgs) + else do + revArgs ← revArgs.mapM (visit main); + pure (mkAppRev f revArgs) +| e@(Expr.mvar mvarId _) => checkCache e $ fun e => do + mctx ← getMCtx; + match mctx.getExprAssignment mvarId with + | some newE => do + newE' ← visit main newE; + modifyCtx $ fun mctx => mctx.assignExpr mvarId newE'; + pure newE' + | none => + /- A delayed assignment can be transformed into a regular assignment + as soon as all metavariables occurring in the assigned value have + been assigned. -/ + match mctx.getDelayedAssignment mvarId with + | some d => do + newE ← instantiateDelayed main mvarId d; + pure $ newE.getD e + | none => pure e +| e => pure e + +end InstantiateExprMVars + +def instantiateMVars (mctx : MetavarContext) (e : Expr) : Expr × MetavarContext := +if !e.hasMVar then (e, mctx) +else (WithHashMapCache.toState $ InstantiateExprMVars.main e).run mctx + +namespace DependsOn + +private abbrev M := StateM ExprSet + +private def visit? (e : Expr) : M Bool := +if !e.hasMVar && !e.hasFVar then + pure false +else do + s ← get; + if s.contains e then + pure false + else do + modify $ fun s => s.insert e; + pure true + +@[inline] private def visit (main : Expr → M Bool) (e : Expr) : M Bool := +condM (visit? e) (main e) (pure false) + +@[specialize] private partial def dep (mctx : MetavarContext) (p : Name → Bool) : Expr → M Bool +| e@(Expr.proj _ _ s _) => visit dep s +| e@(Expr.forallE _ d b _) => visit dep d <||> visit dep b +| e@(Expr.lam _ d b _) => visit dep d <||> visit dep b +| e@(Expr.letE _ t v b _) => visit dep t <||> visit dep v <||> visit dep b +| e@(Expr.mdata _ b _) => visit dep b +| e@(Expr.app f a _) => visit dep a <||> if f.isApp then dep f else visit dep f +| e@(Expr.mvar mvarId _) => + match mctx.getExprAssignment mvarId with + | some a => visit dep a + | none => + let lctx := (mctx.getDecl mvarId).lctx; + pure $ lctx.any $ fun decl => p decl.name +| e@(Expr.fvar fvarId _) => pure $ p fvarId +| e => pure false + +@[inline] partial def main (mctx : MetavarContext) (p : Name → Bool) (e : Expr) : M Bool := +if !e.hasFVar && !e.hasMVar then pure false else dep mctx p e + +end DependsOn + +/-- + Return `true` iff `e` depends on a free variable `x` s.t. `p x` is `true`. + For each metavariable `?m` occurring in `x` + 1- If `?m := t`, then we visit `t` looking for `x` + 2- If `?m` is unassigned, then we consider the worst case and check whether `x` is in the local context of `?m`. + This case is a "may dependency". That is, we may assign a term `t` to `?m` s.t. `t` contains `x`. -/ +@[inline] def exprDependsOn (mctx : MetavarContext) (p : Name → Bool) (e : Expr) : Bool := +(DependsOn.main mctx p e).run' {} + +/-- + Similar to `exprDependsOn`, but checks the expressions in the given local declaration + depends on a free variable `x` s.t. `p x` is `true`. -/ +@[inline] def localDeclDependsOn (mctx : MetavarContext) (p : Name → Bool) : LocalDecl → Bool +| LocalDecl.cdecl _ _ _ type _ => exprDependsOn mctx p type +| LocalDecl.ldecl _ _ _ type value => (DependsOn.main mctx p type <||> DependsOn.main mctx p value).run' {} + +namespace MkBinding + +inductive Exception +| revertFailure (mctx : MetavarContext) (lctx : LocalContext) (toRevert : Array Expr) (decl : LocalDecl) +| readOnlyMVar (mctx : MetavarContext) (mvarId : Name) + +def Exception.toString : Exception → String +| Exception.revertFailure _ lctx toRevert decl => + "failed to revert " + ++ toString (toRevert.map (fun x => "'" ++ toString (lctx.findFVar x).get!.userName ++ "'")) + ++ ", '" ++ toString decl.userName ++ "' depends on them, and it is an auxiliary declaration created by the elaborator" + ++ " (possible solution: use tactic 'clear' to remove '" ++ toString decl.userName ++ "' from local context)" +| Exception.readOnlyMVar _ mvarId => "failed to create binding due to read only metavariable " ++ toString mvarId + +instance Exception.hasToString : HasToString Exception := ⟨Exception.toString⟩ + +/-- + `MkBinding` and `elimMVarDepsAux` are mutually recursive, but `cache` is only used at `elimMVarDepsAux`. + We use a single state object for convenience. + + We have a `NameGenerator` because we need to generate fresh auxiliary metavariables. -/ +structure State := +(mctx : MetavarContext) +(ngen : NameGenerator) +(cache : HashMap Expr Expr := {}) -- + +abbrev M := EStateM Exception State + +instance : MonadHashMapCacheAdapter Expr Expr M := +{ getCache := do s ← get; pure s.cache, + modifyCache := fun f => modify $ fun s => { cache := f s.cache, .. s } } + +/-- Similar to `Expr.abstractRange`, but handles metavariables correctly. + It uses `elimMVarDeps` to ensure `e` and the type of the free variables `xs` do not + contain a metavariable `?m` s.t. local context of `?m` contains a free variable in `xs`. + + `elimMVarDeps` is defined later in this file. -/ +@[inline] private def abstractRange (elimMVarDeps : Array Expr → Expr → M Expr) (lctx : LocalContext) (xs : Array Expr) (i : Nat) (e : Expr) : M Expr := +do e ← elimMVarDeps xs e; + pure (e.abstractRange i xs) + +/-- Similar to `LocalContext.mkBinding`, but handles metavariables correctly. -/ +@[specialize] def mkBinding (isLambda : Bool) (elimMVarDeps : Array Expr → Expr → M Expr) + (lctx : LocalContext) (xs : Array Expr) (e : Expr) : M Expr := +do e ← abstractRange elimMVarDeps lctx xs xs.size e; + xs.size.foldRevM + (fun i e => + let x := xs.get! i; + match lctx.findFVar x with + | some (LocalDecl.cdecl _ _ n type bi) => do + type ← abstractRange elimMVarDeps lctx xs i type; + if isLambda then + pure $ Lean.mkLambda n bi type e + else + pure $ Lean.mkForall n bi type e + | some (LocalDecl.ldecl _ _ n type value) => do + if e.hasLooseBVar 0 then do + type ← abstractRange elimMVarDeps lctx xs i type; + value ← abstractRange elimMVarDeps lctx xs i value; + pure $ mkLet n type value e + else + pure e + | none => panic! "unknown free variable") + e + +@[inline] def mkLambda (elimMVarDeps : Array Expr → Expr → M Expr) (lctx : LocalContext) (xs : Array Expr) (b : Expr) : M Expr := +mkBinding true elimMVarDeps lctx xs b + +@[inline] def mkForall (elimMVarDeps : Array Expr → Expr → M Expr) (lctx : LocalContext) (xs : Array Expr) (b : Expr) : M Expr := +mkBinding false elimMVarDeps lctx xs b + +/-- Return the local declaration of the free variable `x` in `xs` with the smallest index -/ +private def getLocalDeclWithSmallestIdx (lctx : LocalContext) (xs : Array Expr) : LocalDecl := +let d : LocalDecl := (lctx.findFVar $ xs.get! 0).get!; +xs.foldlFrom + (fun d x => + let decl := (lctx.findFVar x).get!; + if decl.index < d.index then decl else d) + d 1 + +/-- Given `toRevert` an array of free variables s.t. `lctx` contains their declarations, + return a new array of free variables that contains `toRevert` and all free variables + in `lctx` that may depend on `toRevert`. + + Remark: the result is sorted by `LocalDecl` indices. -/ +private def collectDeps (mctx : MetavarContext) (lctx : LocalContext) (toRevert : Array Expr) : Except Exception (Array Expr) := +if toRevert.size == 0 then pure toRevert +else + let minDecl := getLocalDeclWithSmallestIdx lctx toRevert; + lctx.foldlFromM + (fun newToRevert decl => + if toRevert.any (fun x => decl.name == x.fvarId!) then + pure (newToRevert.push decl.toExpr) + else if localDeclDependsOn mctx (fun fvarId => newToRevert.any $ fun x => x.fvarId! == fvarId) decl then + if decl.binderInfo.isAuxDecl then + throw (Exception.revertFailure mctx lctx toRevert decl) + else + pure (newToRevert.push decl.toExpr) + else + pure newToRevert) + (Array.mkEmpty toRevert.size) + minDecl + +/-- Create a new `LocalContext` by removing the free variables in `toRevert` from `lctx`. + We use this function when we create auxiliary metavariables at `elimMVarDepsAux`. -/ +private def reduceLocalContext (lctx : LocalContext) (toRevert : Array Expr) : LocalContext := +toRevert.foldr + (fun x lctx => lctx.erase x.fvarId!) + lctx + +@[inline] private def visit (f : Expr → M Expr) (e : Expr) : M Expr := +if !e.hasMVar then pure e else checkCache e f + +@[inline] private def getMCtx : M MetavarContext := +do s ← get; pure s.mctx + +/-- Return free variables in `xs` that are in the local context `lctx` -/ +private def getInScope (lctx : LocalContext) (xs : Array Expr) : Array Expr := +xs.foldl + (fun scope x => + if lctx.contains x.fvarId! then + scope.push x + else + scope) + #[] + +/-- Execute `x` with an empty cache, and then restore the original cache. -/ +@[inline] private def withFreshCache {α} (x : M α) : M α := +do cache ← modifyGet $ fun s => (s.cache, { cache := {}, .. s }); + a ← x; + modify $ fun s => { cache := cache, .. s }; + pure a + +@[inline] private def mkForallAux (elimMVarDepsAux : Array Expr → Expr → M Expr) (lctx : LocalContext) (xs : Array Expr) (b : Expr) : M Expr := +mkForall + (fun xs e => + if !e.hasMVar then + pure e + else + -- The cached results at `elimMVarDepsAux` depend on `xs`. So, we must reset the cache. + withFreshCache $ elimMVarDepsAux xs e) + lctx xs b + +/-- Create an application `mvar ys` where `ys` are the free variables `xs` which are not let-declarations. + All free variables in `xs` are in the context `lctx`. -/ +private def mkMVarApp (lctx : LocalContext) (mvar : Expr) (xs : Array Expr) : Expr := +xs.foldl (fun e x => if (lctx.findFVar x).get!.isLet then e else mkApp e x) mvar + +private def mkAuxMVar (lctx : LocalContext) (type : Expr) (synthetic : Bool) : M Name := +do s ← get; + let mvarId := s.ngen.curr; + modify $ fun s => { mctx := s.mctx.addExprMVarDecl mvarId Name.anonymous lctx type synthetic, ngen := s.ngen.next, .. s }; + pure mvarId + +private partial def elimMVarDepsAux : Array Expr → Expr → M Expr +| xs, e@(Expr.proj _ _ s _) => do s ← visit (elimMVarDepsAux xs) s; pure (e.updateProj! s) +| xs, e@(Expr.forallE _ d b _) => do d ← visit (elimMVarDepsAux xs) d; b ← visit (elimMVarDepsAux xs) b; pure (e.updateForallE! d b) +| xs, e@(Expr.lam _ d b _) => do d ← visit (elimMVarDepsAux xs) d; b ← visit (elimMVarDepsAux xs) b; pure (e.updateLambdaE! d b) +| xs, e@(Expr.letE _ t v b _) => do t ← visit (elimMVarDepsAux xs) t; v ← visit (elimMVarDepsAux xs) v; b ← visit (elimMVarDepsAux xs) b; pure (e.updateLet! t v b) +| xs, e@(Expr.mdata _ b _) => do b ← visit (elimMVarDepsAux xs) b; pure (e.updateMData! b) +| xs, e@(Expr.app _ _ _) => e.withAppRev $ fun f revArgs => do + f ← visit (elimMVarDepsAux xs) f; + revArgs ← revArgs.mapM (visit (elimMVarDepsAux xs)); + pure (mkAppRev f revArgs) +| xs, e@(Expr.mvar mvarId _) => do + mctx ← getMCtx; + match mctx.getExprAssignment mvarId with + | some a => visit (elimMVarDepsAux xs) a + | none => + let mvarDecl := mctx.getDecl mvarId; + let mvarLCtx := mvarDecl.lctx; + let toRevert := getInScope mvarLCtx xs; + if toRevert.size == 0 then + pure e + else if !mctx.isExprAssignable mvarId then + throw $ Exception.readOnlyMVar mctx mvarId + else + match collectDeps mctx mvarLCtx toRevert with + | Except.error ex => throw ex + | Except.ok toRevert => do + let newMVarLCtx := reduceLocalContext mvarLCtx toRevert; + newMVarType ← mkForallAux (fun xs e => elimMVarDepsAux xs e) mvarLCtx toRevert mvarDecl.type; + newMVarId ← mkAuxMVar newMVarLCtx newMVarType mvarDecl.synthetic; + let newMVar := mkMVar newMVarId; + let result := mkMVarApp mvarLCtx newMVar toRevert; + if mvarDecl.synthetic then + modify (fun s => { mctx := assignDelayed s.mctx newMVarId mvarLCtx toRevert e, .. s }) + else + modify (fun s => { mctx := assignExpr s.mctx mvarId result, .. s }); + pure result +| xs, e => pure e + +partial def elimMVarDeps (xs : Array Expr) (e : Expr) : M Expr := +if !e.hasMVar then + pure e +else + withFreshCache $ elimMVarDepsAux xs e + +end MkBinding + +abbrev MkBindingM := ReaderT LocalContext MkBinding.M + +def mkBinding (isLambda : Bool) (xs : Array Expr) (e : Expr) : MkBindingM Expr := +fun lctx => MkBinding.mkBinding isLambda MkBinding.elimMVarDeps lctx xs e + +@[inline] def mkLambda (xs : Array Expr) (e : Expr) : MkBindingM Expr := +mkBinding true xs e + +@[inline] def mkForall (xs : Array Expr) (e : Expr) : MkBindingM Expr := +mkBinding false xs e + +/-- + `isWellFormed mctx lctx e` return true if + - All locals in `e` are declared in `lctx` + - All metavariables `?m` in `e` have a local context which is a subprefix of `lctx` or are assigned, and the assignment is well-formed. -/ +partial def isWellFormed (mctx : MetavarContext) (lctx : LocalContext) : Expr → Bool +| Expr.mdata _ e _ => isWellFormed e +| Expr.proj _ _ e _ => isWellFormed e +| e@(Expr.app f a _) => (e.hasExprMVar || e.hasFVar) && isWellFormed f && isWellFormed a +| e@(Expr.lam _ d b _) => (e.hasExprMVar || e.hasFVar) && isWellFormed d && isWellFormed b +| e@(Expr.forallE _ d b _) => (e.hasExprMVar || e.hasFVar) && isWellFormed d && isWellFormed b +| e@(Expr.letE _ t v b _) => (e.hasExprMVar || e.hasFVar) && isWellFormed t && isWellFormed v && isWellFormed b +| Expr.const _ _ _ => true +| Expr.bvar _ _ => true +| Expr.sort _ _ => true +| Expr.lit _ _ => true +| Expr.mvar mvarId _ => + let mvarDecl := mctx.getDecl mvarId; + if mvarDecl.lctx.isSubPrefixOf lctx then true + else match mctx.getExprAssignment mvarId with + | none => false + | some v => isWellFormed v +| Expr.fvar fvarId _ => lctx.contains fvarId +| Expr.localE _ _ _ _ => unreachable! + +end MetavarContext +end Lean diff --git a/stage0/src/Init/Lean/Modifiers.lean b/stage0/src/Init/Lean/Modifiers.lean new file mode 100644 index 0000000000..46ec9156cd --- /dev/null +++ b/stage0/src/Init/Lean/Modifiers.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment + +namespace Lean + +def mkProtectedExtension : IO TagDeclarationExtension := +mkTagDeclarationExtension `protected + +@[init mkProtectedExtension] +constant protectedExt : TagDeclarationExtension := arbitrary _ + +@[export lean_add_protected] +def addProtected (env : Environment) (n : Name) : Environment := +protectedExt.tag env n + +@[export lean_is_protected] +def isProtected (env : Environment) (n : Name) : Bool := +protectedExt.isTagged env n + +def mkPrivateExtension : IO (EnvExtension Nat) := +registerEnvExtension (pure 1) + +@[init mkPrivateExtension] +constant privateExt : EnvExtension Nat := arbitrary _ + +/- Private name support. + + Suppose the user marks as declaration `n` as private. Then, we create + the name: `_private.. ++ n`. + We say `_private..` is the "private prefix" + where `` comes from the environment extension `privateExt`. + + We assume that `n` is a valid user name and does not contain + `Name.num` constructors. Thus, we can easily convert from + private internal name to user given name. +-/ + +def privateHeader : Name := `_private + +@[export lean_mk_private_prefix] +def mkPrivatePrefix (env : Environment) : Environment × Name := +let idx := privateExt.getState env; +let p := mkNameNum (privateHeader ++ env.mainModule) idx; +let env := privateExt.setState env (idx+1); +(env, p) + +@[export lean_mk_private_name] +def mkPrivateName (env : Environment) (n : Name) : Environment × Name := +let (env, p) := mkPrivatePrefix env; +(env, p ++ n) + +def isPrivateName : Name → Bool +| n@(Name.str p _ _) => n == privateHeader || isPrivateName p +| Name.num p _ _ => isPrivateName p +| _ => false + +@[export lean_is_private_name] +def isPrivateNameExport (n : Name) : Bool := +isPrivateName n + +private def privateToUserNameAux : Name → Name +| Name.str p s _ => mkNameStr (privateToUserNameAux p) s +| _ => Name.anonymous + +@[export lean_private_to_user_name] +def privateToUserName (n : Name) : Option Name := +if isPrivateName n then privateToUserNameAux n +else none + +private def privatePrefixAux : Name → Name +| Name.str p _ _ => privatePrefixAux p +| n => n + +@[export lean_private_prefix] +def privatePrefix (n : Name) : Option Name := +if isPrivateName n then privatePrefixAux n +else none + +end Lean diff --git a/stage0/src/Init/Lean/MonadCache.lean b/stage0/src/Init/Lean/MonadCache.lean new file mode 100644 index 0000000000..088c16753d --- /dev/null +++ b/stage0/src/Init/Lean/MonadCache.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Control.Reader +import Init.Control.EState +import Init.Data.HashMap + +namespace Lean +/-- Interface for caching results. -/ +class MonadCache (α β : Type) (m : Type → Type) := +(findCached {} : α → m (Option β)) +(cache {} : α → β → m Unit) + +/-- If entry `a := b` is already in the cache, then return `b`. + Otherwise, execute `b ← f a`, store `a := b` in the cache and return `b`. -/ +@[inline] def checkCache {α β : Type} {m : Type → Type} [MonadCache α β m] [Monad m] (a : α) (f : α → m β) : m β := +do b? ← MonadCache.findCached a; + match b? with + | some b => pure b + | none => do + b ← f a; + MonadCache.cache a b; + pure b + +instance readerLift {α β ρ : Type} {m : Type → Type} [MonadCache α β m] : MonadCache α β (ReaderT ρ m) := +{ findCached := fun a r => MonadCache.findCached a, + cache := fun a b r => MonadCache.cache a b } + +instance exceptLift {α β ε : Type} {m : Type → Type} [MonadCache α β m] [Monad m] : MonadCache α β (ExceptT ε m) := +{ findCached := fun a => ExceptT.lift $ MonadCache.findCached a, + cache := fun a b => ExceptT.lift $ MonadCache.cache a b } + +/-- Adapter for implementing `MonadCache` interface using `HashMap`s. + We just have to specify how to extract/modify the `HashMap`. -/ +class MonadHashMapCacheAdapter (α β : Type) (m : Type → Type) [HasBeq α] [Hashable α] := +(getCache {} : m (HashMap α β)) +(modifyCache {} : (HashMap α β → HashMap α β) → m Unit) + +namespace MonadHashMapCacheAdapter + +@[inline] def findCached {α β : Type} {m : Type → Type} [HasBeq α] [Hashable α] [Monad m] [MonadHashMapCacheAdapter α β m] (a : α) : m (Option β) := +do c ← getCache; + pure (c.find a) + +@[inline] def cache {α β : Type} {m : Type → Type} [HasBeq α] [Hashable α] [MonadHashMapCacheAdapter α β m] (a : α) (b : β) : m Unit := +modifyCache $ fun s => s.insert a b + +instance {α β : Type} {m : Type → Type} [HasBeq α] [Hashable α] [Monad m] [MonadHashMapCacheAdapter α β m] : MonadCache α β m := +{ findCached := MonadHashMapCacheAdapter.findCached, + cache := MonadHashMapCacheAdapter.cache } + +end MonadHashMapCacheAdapter + +/-- Auxiliary structure for "adding" a `HashMap` to a state object. -/ +structure WithHashMapCache (α β σ : Type) [HasBeq α] [Hashable α] := +(state : σ) +(cache : HashMap α β := {}) + +namespace WithHashMapCache + +@[inline] def getCache {α β σ : Type} [HasBeq α] [Hashable α] : StateM (WithHashMapCache α β σ) (HashMap α β) := +do s ← get; pure s.cache + +@[inline] def modifyCache {α β σ : Type} [HasBeq α] [Hashable α] (f : HashMap α β → HashMap α β) : StateM (WithHashMapCache α β σ) Unit := +modify $ fun s => { cache := f s.cache, .. s } + +instance stateAdapter (α β σ : Type) [HasBeq α] [Hashable α] : MonadHashMapCacheAdapter α β (StateM (WithHashMapCache α β σ)) := +{ getCache := WithHashMapCache.getCache, + modifyCache := WithHashMapCache.modifyCache } + +@[inline] def getCacheE {α β ε σ : Type} [HasBeq α] [Hashable α] : EStateM ε (WithHashMapCache α β σ) (HashMap α β) := +do s ← get; pure s.cache + +@[inline] def modifyCacheE {α β ε σ : Type} [HasBeq α] [Hashable α] (f : HashMap α β → HashMap α β) : EStateM ε (WithHashMapCache α β σ) Unit := +modify $ fun s => { cache := f s.cache, .. s } + +instance estateAdapter (α β ε σ : Type) [HasBeq α] [Hashable α] : MonadHashMapCacheAdapter α β (EStateM ε (WithHashMapCache α β σ)) := +{ getCache := WithHashMapCache.getCacheE, + modifyCache := WithHashMapCache.modifyCacheE } + +@[inline] def fromState {α β σ δ : Type} [HasBeq α] [Hashable α] (x : StateM σ δ) : StateM (WithHashMapCache α β σ) δ := +adaptState + (fun (s : WithHashMapCache α β σ) => (s.state, s.cache)) + (fun (s : σ) (cache : HashMap α β) => { state := s, cache := cache }) + x + +@[inline] def toState {α β σ δ : Type} [HasBeq α] [Hashable α] (x : StateM (WithHashMapCache α β σ) δ) : StateM σ δ := +adaptState' + (fun (s : σ) => ({ state := s } : WithHashMapCache α β σ)) + (fun (s : WithHashMapCache α β σ) => s.state) + x + +@[inline] def fromEState {α β σ ε δ : Type} [HasBeq α] [Hashable α] (x : EStateM ε σ δ) : EStateM ε (WithHashMapCache α β σ) δ := +adaptState + (fun (s : WithHashMapCache α β σ) => (s.state, s.cache)) + (fun (s : σ) (cache : HashMap α β) => { state := s, cache := cache }) + x + +@[inline] def toEState {α β σ ε δ : Type} [HasBeq α] [Hashable α] (x : EStateM ε (WithHashMapCache α β σ) δ) : EStateM ε σ δ := +adaptState' + (fun (s : σ) => ({ state := s } : WithHashMapCache α β σ)) + (fun (s : WithHashMapCache α β σ) => s.state) + x + +end WithHashMapCache +end Lean diff --git a/stage0/src/Init/Lean/Name.lean b/stage0/src/Init/Lean/Name.lean new file mode 100644 index 0000000000..020c209925 --- /dev/null +++ b/stage0/src/Init/Lean/Name.lean @@ -0,0 +1,209 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.String.Basic +import Init.Coe +import Init.Data.UInt +import Init.Data.ToString +import Init.Data.Hashable +import Init.Data.RBMap +import Init.Data.RBTree + +namespace Lean + +inductive Name +| anonymous : Name +| str : Name → String → USize → Name +| num : Name → Nat → USize → Name + +instance Name.inhabited : Inhabited Name := +⟨Name.anonymous⟩ + +def Name.hash : Name → USize +| Name.anonymous => 1723 +| Name.str p s h => h +| Name.num p v h => h + +instance Name.hashable : Hashable Name := ⟨Name.hash⟩ + +@[export lean_name_hash] def Name.hashEx : Name → USize := Name.hash + +@[export lean_name_mk_string] +def mkNameStr (p : Name) (s : String) : Name := +Name.str p s $ mixHash (hash p) (hash s) + +@[export lean_name_mk_numeral] +def mkNameNum (p : Name) (v : Nat) : Name := +Name.num p v $ mixHash (hash p) (hash v) + +def mkNameSimple (s : String) : Name := +mkNameStr Name.anonymous s + +instance stringToName : HasCoe String Name := +⟨mkNameSimple⟩ + +namespace Name + +def getPrefix : Name → Name +| anonymous => anonymous +| str p s _ => p +| num p s _ => p + +def getNumParts : Name → Nat +| anonymous => 0 +| str p _ _ => getNumParts p + 1 +| num p _ _ => getNumParts p + 1 + +def updatePrefix : Name → Name → Name +| anonymous, newP => anonymous +| str p s _, newP => mkNameStr newP s +| num p s _, newP => mkNameNum newP s + +def components' : Name → List Name +| anonymous => [] +| str n s _ => mkNameStr anonymous s :: components' n +| num n v _ => mkNameNum anonymous v :: components' n + +def components (n : Name) : List Name := +n.components'.reverse + +@[extern "lean_name_eq"] +protected def beq : (@& Name) → (@& Name) → Bool +| anonymous, anonymous => true +| str p₁ s₁ _, str p₂ s₂ _ => s₁ == s₂ && beq p₁ p₂ +| num p₁ n₁ _, num p₂ n₂ _ => n₁ == n₂ && beq p₁ p₂ +| _, _ => false + +instance : HasBeq Name := ⟨Name.beq⟩ + +def eqStr : Name → String → Bool +| str anonymous s _, s' => s == s' +| _, _ => false + +protected def append : Name → Name → Name +| n, anonymous => n +| n, str p s _ => mkNameStr (append n p) s +| n, num p d _ => mkNameNum (append n p) d + +instance : HasAppend Name := +⟨Name.append⟩ + +def replacePrefix : Name → Name → Name → Name +| anonymous, anonymous, newP => newP +| anonymous, _, _ => anonymous +| n@(str p s _), queryP, newP => if n == queryP then newP else mkNameStr (p.replacePrefix queryP newP) s +| n@(num p s _), queryP, newP => if n == queryP then newP else mkNameNum (p.replacePrefix queryP newP) s + +def isPrefixOf : Name → Name → Bool +| p, anonymous => p == anonymous +| p, n@(num p' _ _) => p == n || isPrefixOf p p' +| p, n@(str p' _ _) => p == n || isPrefixOf p p' + +def lt : Name → Name → Bool +| anonymous, anonymous => false +| anonymous, _ => true +| num p₁ i₁ _, num p₂ i₂ _ => lt p₁ p₂ || (p₁ == p₂ && i₁ < i₂) +| num _ _ _, str _ _ _ => true +| str p₁ n₁ _, str p₂ n₂ _ => lt p₁ p₂ || (p₁ == p₂ && n₁ < n₂) +| _, _ => false + +def quickLtAux : Name → Name → Bool +| anonymous, anonymous => false +| anonymous, _ => true +| num n v _, num n' v' _ => v < v' || (v = v' && n.quickLtAux n') +| num _ _ _, str _ _ _ => true +| str n s _, str n' s' _ => s < s' || (s = s' && n.quickLtAux n') +| _, _ => false + +def quickLt (n₁ n₂ : Name) : Bool := +if n₁.hash < n₂.hash then true +else if n₁.hash > n₂.hash then false +else quickLtAux n₁ n₂ + +/- Alternative HasLt instance. -/ +@[inline] protected def hasLtQuick : HasLess Name := +⟨fun a b => Name.quickLt a b = true⟩ + +@[inline] instance : DecidableRel (@HasLess.Less Name Name.hasLtQuick) := +inferInstanceAs (DecidableRel (fun a b => Name.quickLt a b = true)) + +def toStringWithSep (sep : String) : Name → String +| anonymous => "[anonymous]" +| str anonymous s _ => s +| num anonymous v _ => toString v +| str n s _ => toStringWithSep n ++ sep ++ s +| num n v _ => toStringWithSep n ++ sep ++ repr v + +protected def toString : Name → String := +toStringWithSep "." + +instance : HasToString Name := +⟨Name.toString⟩ + +def appendAfter : Name → String → Name +| str p s _, suffix => mkNameStr p (s ++ suffix) +| n, suffix => mkNameStr n suffix + +def appendIndexAfter : Name → Nat → Name +| str p s _, idx => mkNameStr p (s ++ "_" ++ toString idx) +| n, idx => mkNameStr n ("_" ++ toString idx) + +/- The frontend does not allow user declarations to start with `_` in any of its parts. + We use name parts starting with `_` internally to create auxiliary names (e.g., `_private`). -/ +def isInternal : Name → Bool +| str p s _ => s.get 0 == '_' || isInternal p +| num p _ _ => isInternal p +| _ => false + +def isAtomic : Name → Bool +| anonymous => true +| str anonymous _ _ => true +| num anonymous _ _ => true +| _ => false + +end Name + +def NameMap (α : Type) := RBMap Name α Name.quickLt + +@[inline] def mkNameMap (α : Type) : NameMap α := mkRBMap Name α Name.quickLt + +namespace NameMap +variable {α : Type} + +instance (α : Type) : HasEmptyc (NameMap α) := ⟨mkNameMap α⟩ + +instance (α : Type) : Inhabited (NameMap α) := ⟨{}⟩ + +def insert (m : NameMap α) (n : Name) (a : α) := RBMap.insert m n a + +def contains (m : NameMap α) (n : Name) : Bool := RBMap.contains m n + +@[inline] def find (m : NameMap α) (n : Name) : Option α := RBMap.find m n + +end NameMap + +def NameSet := RBTree Name Name.quickLt + +@[inline] def mkNameSet : NameSet := mkRBTree Name Name.quickLt + +namespace NameSet + +instance : HasEmptyc NameSet := ⟨mkNameSet⟩ + +instance : Inhabited NameSet := ⟨{}⟩ + +def insert (s : NameSet) (n : Name) := RBTree.insert s n + +def contains (s : NameSet) (n : Name) : Bool := RBMap.contains s n + +end NameSet +end Lean + +open Lean + +def String.toName (s : String) : Name := +let ps := s.splitOn "."; +ps.foldl (fun n p => mkNameStr n p.trim) Name.anonymous diff --git a/stage0/src/Init/Lean/NameGenerator.lean b/stage0/src/Init/Lean/NameGenerator.lean new file mode 100644 index 0000000000..555f19661a --- /dev/null +++ b/stage0/src/Init/Lean/NameGenerator.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Name + +namespace Lean + +structure NameGenerator := +(namePrefix : Name := `_uniq) +(idx : Nat := 1) + +namespace NameGenerator + +instance : Inhabited NameGenerator := ⟨{}⟩ + +@[inline] def curr (g : NameGenerator) : Name := +mkNameNum g.namePrefix g.idx + +@[inline] def next (g : NameGenerator) : NameGenerator := +{ idx := g.idx + 1, .. g } + +@[inline] def mkChild (g : NameGenerator) : NameGenerator × NameGenerator := +({ namePrefix := mkNameNum g.namePrefix g.idx, idx := 1 }, + { idx := g.idx + 1, .. g }) + +end NameGenerator + +end Lean diff --git a/stage0/src/Init/Lean/Options.lean b/stage0/src/Init/Lean/Options.lean new file mode 100644 index 0000000000..04cd006308 --- /dev/null +++ b/stage0/src/Init/Lean/Options.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sebastian Ullrich and Leonardo de Moura +-/ +prelude +import Init.System.IO +import Init.Data.ToString +import Init.Lean.KVMap + +namespace Lean + +def Options := KVMap + +namespace Options +def empty : Options := {KVMap .} +instance : HasEmptyc Options := ⟨empty⟩ +end Options + +structure OptionDecl := +(defValue : DataValue) +(group : String := "") +(descr : String := "") + +def OptionDecls := NameMap OptionDecl + +private def initOptionDeclsRef : IO (IO.Ref OptionDecls) := +IO.mkRef (mkNameMap OptionDecl) + +@[init initOptionDeclsRef] +private constant optionDeclsRef : IO.Ref OptionDecls := arbitrary _ + +def registerOption (name : Name) (decl : OptionDecl) : IO Unit := +do decls ← optionDeclsRef.get; + when (decls.contains name) $ + throw $ IO.userError ("invalid option declaration '" ++ toString name ++ "', option already exists"); + optionDeclsRef.set $ decls.insert name decl + +def getOptionDecls : IO OptionDecls := optionDeclsRef.get + +def getOptionDecl (name : Name) : IO OptionDecl := +do decls ← getOptionDecls; + (some decl) ← pure (decls.find name) | throw $ IO.userError ("unknown option '" ++ toString name ++ "'"); + pure decl + +def getOptionDefaulValue (name : Name) : IO DataValue := +do decl ← getOptionDecl name; + pure decl.defValue + +def getOptionDescr (name : Name) : IO String := +do decl ← getOptionDecl name; + pure decl.descr + +def setOptionFromString (opts : Options) (entry : String) : IO Options := +do let ps := (entry.splitOn "=").map String.trim; + [key, val] ← pure ps | throw "invalid configuration option entry, it must be of the form ' = '"; + defValue ← getOptionDefaulValue key.toName; + match defValue with + | DataValue.ofString v => pure $ opts.setString key val + | DataValue.ofBool v => + if key == "true" then pure $ opts.setBool key true + else if key == "false" then pure $ opts.setBool key false + else throw $ IO.userError ("invalid Bool option value '" ++ val ++ "'") + | DataValue.ofName v => pure $ opts.setName key val.toName + | DataValue.ofNat v => do + unless val.isNat $ throw (IO.userError ("invalid Nat option value '" ++ val ++ "'")); + pure $ opts.setNat key val.toNat + | DataValue.ofInt v => do + unless val.isInt $ throw (IO.userError ("invalid Int option value '" ++ val ++ "'")); + pure $ opts.setInt key val.toInt + +end Lean diff --git a/stage0/src/Init/Lean/Parser.lean b/stage0/src/Init/Lean/Parser.lean new file mode 100644 index 0000000000..a1ef5626bc --- /dev/null +++ b/stage0/src/Init/Lean/Parser.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Parser.Parser +import Init.Lean.Parser.Level +import Init.Lean.Parser.Term +import Init.Lean.Parser.Command +import Init.Lean.Parser.Module diff --git a/stage0/src/Init/Lean/Parser/Command.lean b/stage0/src/Init/Lean/Parser/Command.lean new file mode 100644 index 0000000000..3906d4521d --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Command.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Parser.Term + +namespace Lean +namespace Parser + +@[init mkBuiltinParsingTablesRef] +constant builtinCommandParsingTable : IO.Ref ParsingTables := arbitrary _ + +@[init] def regBuiltinCommandParserAttr : IO Unit := +registerBuiltinParserAttribute `builtinCommandParser `Lean.Parser.builtinCommandParsingTable + +def mkCommandParserAttribute : IO ParserAttribute := +registerParserAttribute `commandParser "command" "command parser" (some builtinCommandParsingTable) + +@[init mkCommandParserAttribute] +constant commandParserAttribute : ParserAttribute := arbitrary _ + +@[inline] def commandParser {k : ParserKind} (rbp : Nat := 0) : Parser k := +{ fn := fun _ => commandParserAttribute.runParser rbp } + +namespace Command +def commentBody : Parser := +{ fn := rawFn (fun _ => finishCommentBlock 1) true } + +def docComment := parser! "/--" >> commentBody +def attrArg : Parser := ident <|> strLit <|> numLit +-- use `rawIdent` because of attribute names such as `instance` +def attrInstance := parser! rawIdent >> many attrArg +def attributes := parser! "@[" >> sepBy1 attrInstance ", " >> "]" +def «private» := parser! "private " +def «protected» := parser! "protected " +def visibility := «private» <|> «protected» +def «noncomputable» := parser! "noncomputable " +def «unsafe» := parser! "unsafe " +def «partial» := parser! "partial " +def declModifiers := parser! optional docComment >> optional «attributes» >> optional visibility >> optional «noncomputable» >> optional «unsafe» >> optional «partial» +def declId := parser! ident >> optional (".{" >> sepBy1 ident ", " >> "}") +def declSig := parser! many Term.bracktedBinder >> Term.typeSpec +def optDeclSig := parser! many Term.bracktedBinder >> Term.optType +def declValSimple := parser! " := " >> termParser +def declValEqns := parser! many1Indent Term.equation "equations must be indented" +def declVal := declValSimple <|> declValEqns +def «abbrev» := parser! "abbrev " >> declId >> optDeclSig >> declVal +def «def» := parser! "def " >> declId >> optDeclSig >> declVal +def «theorem» := parser! "theorem " >> declId >> declSig >> declVal +def «constant» := parser! "constant " >> declId >> declSig >> optional declValSimple +def «instance» := parser! "instance " >> optional declId >> declSig >> declVal +def «axiom» := parser! "axiom " >> declId >> declSig +def «example» := parser! "example " >> declSig >> declVal +def relaxedInferMod := parser! try ("{" >> "}") +def strictInferMod := parser! try ("(" >> ")") +def inferMod := relaxedInferMod <|> strictInferMod +def introRule := parser! " | " >> ident >> optional inferMod >> optDeclSig +def «inductive» := parser! "inductive " >> declId >> optDeclSig >> many introRule +def classInductive := parser! try ("class " >> "inductive ") >> declId >> optDeclSig >> many introRule +def structExplicitBinder := parser! "(" >> many ident >> optional inferMod >> optDeclSig >> optional Term.binderDefault >> ")" +def structImplicitBinder := parser! "{" >> many ident >> optional inferMod >> optDeclSig >> "}" +def structInstBinder := parser! "[" >> many ident >> optional inferMod >> optDeclSig >> "]" +def structFields := parser! many (structExplicitBinder <|> structImplicitBinder <|> structInstBinder) +def structCtor := parser! ident >> optional inferMod >> " :: " +def structureTk := parser! "structure " +def classTk := parser! "class " +def «extends» := parser! " extends " >> sepBy1 termParser ", " +def «structure» := parser! (structureTk <|> classTk) >> declId >> many Term.bracktedBinder >> optional «extends» >> Term.optType >> " := " >> optional structCtor >> structFields + +@[builtinCommandParser] def declaration := parser! +declModifiers >> («abbrev» <|> «def» <|> «theorem» <|> «constant» <|> «instance» <|> «axiom» <|> «example» <|> «inductive» <|> classInductive <|> «structure») + +@[builtinCommandParser] def «section» := parser! "section " >> optional ident +@[builtinCommandParser] def «namespace» := parser! "namespace " >> ident +@[builtinCommandParser] def «end» := parser! "end " >> optional ident +@[builtinCommandParser] def «variable» := parser! "variable " >> Term.bracktedBinder +@[builtinCommandParser] def «variables» := parser! "variables " >> many1 Term.bracktedBinder +@[builtinCommandParser] def «universe» := parser! "universe " >> ident +@[builtinCommandParser] def «universes» := parser! "universes " >> many1 ident +@[builtinCommandParser] def check := parser! "#check " >> termParser +@[builtinCommandParser] def exit := parser! "#exit" +@[builtinCommandParser] def «resolve_name» := parser! "#resolve_name " >> ident +@[builtinCommandParser] def «preterm» := parser! "#preterm " >> termParser +@[builtinCommandParser] def «elab» := parser! "#elab " >> termParser +@[builtinCommandParser] def «init_quot» := parser! "init_quot" +@[builtinCommandParser] def «set_option» := parser! "set_option " >> ident >> (symbolOrIdent "true" <|> symbolOrIdent "false" <|> strLit <|> numLit) +@[builtinCommandParser] def «attribute» := parser! optional "local " >> "attribute " >> "[" >> sepBy1 attrInstance ", " >> "]" >> many1 ident +@[builtinCommandParser] def «export» := parser! "export " >> ident >> "(" >> many1 ident >> ")" +def openHiding := parser! try (ident >> "hiding") >> many1 ident +def openRenamingItem := parser! ident >> unicodeSymbol "→" "->" >> ident +def openRenaming := parser! try (ident >> "renaming") >> sepBy1 openRenamingItem ", " +def openOnly := parser! try (ident >> "(") >> many1 ident >> ")" +def openSimple := parser! many1 ident +@[builtinCommandParser] def «open» := parser! "open " >> (openHiding <|> openRenaming <|> openOnly <|> openSimple) + +/- Lean3 command declaration commands -/ +def maxPrec := parser! symbolOrIdent "max" +def precedenceLit : Parser := numLit <|> maxPrec +def «precedence» := parser! " : " >> precedenceLit +def quotedSymbolPrec := parser! quotedSymbol >> optional «precedence» +def symbol : Parser := quotedSymbolPrec <|> unquotedSymbol +def «prefix» := parser! "prefix" +def «infix» := parser! "infix" +def «infixl» := parser! "infixl" +def «infixr» := parser! "infixr" +def «postfix» := parser! "postfix" +def mixfixKind := «prefix» <|> «infix» <|> «infixl» <|> «infixr» <|> «postfix» +@[builtinCommandParser] def «reserve» := parser! "reserve " >> mixfixKind >> quotedSymbolPrec +def mixfixSymbol := quotedSymbolPrec <|> unquotedSymbol +@[builtinCommandParser] def «mixfix» := parser! mixfixKind >> mixfixSymbol >> " := " >> termParser +def identPrec := parser! ident >> optional «precedence» +@[builtinCommandParser] def «notation» := parser! "notation" >> optional ident >> many (quotedSymbolPrec <|> identPrec) >> " := " >> termParser + +end Command +end Parser +end Lean diff --git a/stage0/src/Init/Lean/Parser/Identifier.lean b/stage0/src/Init/Lean/Parser/Identifier.lean new file mode 100644 index 0000000000..2365ae2818 --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Identifier.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Char.Basic + +namespace Lean + +def isGreek (c : Char) : Bool := +0x391 ≤ c.val && c.val ≤ 0x3dd + +def isLetterLike (c : Char) : Bool := +(0x3b1 ≤ c.val && c.val ≤ 0x3c9 && c.val ≠ 0x3bb) || -- Lower greek, but lambda +(0x391 ≤ c.val && c.val ≤ 0x3A9 && c.val ≠ 0x3A0 && c.val ≠ 0x3A3) || -- Upper greek, but Pi and Sigma +(0x3ca ≤ c.val && c.val ≤ 0x3fb) || -- Coptic letters +(0x1f00 ≤ c.val && c.val ≤ 0x1ffe) || -- Polytonic Greek Extended Character Set +(0x2100 ≤ c.val && c.val ≤ 0x214f) || -- Letter like block +(0x1d49c ≤ c.val && c.val ≤ 0x1d59f) -- Latin letters, Script, Double-struck, Fractur + +def isSubScriptAlnum (c : Char) : Bool := +(0x207f ≤ c.val && c.val ≤ 0x2089) || -- n superscript and numberic subscripts +(0x2090 ≤ c.val && c.val ≤ 0x209c) || +(0x1d62 ≤ c.val && c.val ≤ 0x1d6a) + +def isIdFirst (c : Char) : Bool := +c.isAlpha || c = '_' || isLetterLike c + +def isIdRest (c : Char) : Bool := +c.isAlphanum || c = '_' || c = '\'' || c == '!' || c == '?' || isLetterLike c || isSubScriptAlnum c + +def idBeginEscape := '«' +def idEndEscape := '»' +def isIdBeginEscape (c : Char) : Bool := +c = idBeginEscape +def isIdEndEscape (c : Char) : Bool := +c = idEndEscape + +end Lean diff --git a/stage0/src/Init/Lean/Parser/Level.lean b/stage0/src/Init/Lean/Parser/Level.lean new file mode 100644 index 0000000000..be51d670d7 --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Level.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Parser.Parser + +namespace Lean +namespace Parser + +@[init mkBuiltinParsingTablesRef] +constant builtinLevelParsingTable : IO.Ref ParsingTables := arbitrary _ + +@[init] def regBuiltinLevelParserAttr : IO Unit := +registerBuiltinParserAttribute `builtinLevelParser `Lean.Parser.builtinLevelParsingTable + +def mkLevelParserAttribute : IO ParserAttribute := +registerParserAttribute `levelParser "level" "universe level parser" (some builtinLevelParsingTable) + +@[init mkLevelParserAttribute] +constant levelParserAttribute : ParserAttribute := arbitrary _ + +@[inline] def levelParser {k : ParserKind} (rbp : Nat := 0) : Parser k := +{ fn := fun _ => levelParserAttribute.runParser rbp } + +namespace Level + +@[builtinLevelParser] def paren := parser! symbol "(" appPrec >> levelParser >> ")" +@[builtinLevelParser] def max := parser! symbolOrIdent "max" >> many1 (levelParser appPrec) +@[builtinLevelParser] def imax := parser! symbolOrIdent "imax" >> many1 (levelParser appPrec) +@[builtinLevelParser] def hole := parser! "_" +@[builtinLevelParser] def num := parser! numLit +@[builtinLevelParser] def ident := parser! ident +@[builtinLevelParser] def addLit := tparser! pushLeading >> symbol "+" (65:Nat) >> numLit + +end Level + +end Parser +end Lean diff --git a/stage0/src/Init/Lean/Parser/Module.lean b/stage0/src/Init/Lean/Parser/Module.lean new file mode 100644 index 0000000000..6ab4f01461 --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Module.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Message +import Init.Lean.Parser.Command + +namespace Lean +namespace Parser + +namespace Module +def «prelude» := parser! "prelude" +def «import» := parser! "import " >> optional "runtime" >> ident +def header := parser! optional «prelude» >> many «import» + +def updateTokens (c : ParserContext) : ParserContext := +{ tokens := match header.info.updateTokens c.tokens with + | Except.ok tables => tables + | Except.error _ => {}, -- unreachable + .. c } + +end Module + +structure ModuleParserState := +(pos : String.Pos := 0) +(recovering : Bool := false) + +instance ModuleParserState.inhabited : Inhabited ModuleParserState := +⟨{}⟩ + +private def mkErrorMessage (c : ParserContext) (pos : String.Pos) (errorMsg : String) : Message := +let pos := c.fileMap.toPosition pos; +{ fileName := c.fileName, pos := pos, data := errorMsg } + +def parseHeader (env : Environment) (c : ParserContextCore) : Syntax × ModuleParserState × MessageLog := +let c := c.toParserContext env; +let c := Module.updateTokens c; +let s := mkParserState c.input; +let s := whitespace c s; +let s := Module.header.fn (0:Nat) c s; +let stx := s.stxStack.back; +match s.errorMsg with +| some errorMsg => + let msg := mkErrorMessage c s.pos (toString errorMsg); + (stx, { pos := s.pos, recovering := true }, { MessageLog . }.add msg) +| none => + (stx, { pos := s.pos }, {}) + +private def mkEOI (pos : String.Pos) : Syntax := +let atom := mkAtom { pos := pos, trailing := "".toSubstring, leading := "".toSubstring } ""; +Syntax.node `Lean.Parser.Module.eoi #[atom] + +def isEOI (s : Syntax) : Bool := +s.isOfKind `Lean.Parser.Module.eoi + +def isExitCommand (s : Syntax) : Bool := +s.isOfKind `Lean.Parser.Command.exit + +private def consumeInput (c : ParserContext) (pos : String.Pos) : String.Pos := +let s : ParserState := { cache := initCacheForInput c.input, pos := pos }; +let s := tokenFn c s; +match s.errorMsg with +| some _ => pos + 1 +| none => s.pos + +partial def parseCommand (env : Environment) (c : ParserContextCore) : ModuleParserState → MessageLog → Syntax × ModuleParserState × MessageLog +| s@{ pos := pos, recovering := recovering }, messages => + if c.input.atEnd pos then + (mkEOI pos, s, messages) + else + let c := c.toParserContext env; + let s := { ParserState . cache := initCacheForInput c.input, pos := pos }; + let s := (commandParser : Parser).fn (0:Nat) c s; + match s.errorMsg with + | none => + let stx := s.stxStack.back; + (stx, { pos := s.pos }, messages) + | some errorMsg => + if recovering then + parseCommand { pos := consumeInput c s.pos, recovering := true } messages + else + let msg := mkErrorMessage c s.pos (toString errorMsg); + let messages := messages.add msg; + parseCommand { pos := consumeInput c s.pos, recovering := true } messages + +private partial def testModuleParserAux (env : Environment) (c : ParserContextCore) (displayStx : Bool) : ModuleParserState → MessageLog → IO Bool +| s, messages => + match parseCommand env c s messages with + | (stx, s, messages) => + if isEOI stx || isExitCommand stx then do + messages.toList.forM $ fun msg => IO.println msg; + pure (!messages.hasErrors) + else do + when displayStx (IO.println stx); + testModuleParserAux s messages + +@[export lean_test_module_parser] +def testModuleParser (env : Environment) (input : String) (fileName := "") (displayStx := false) : IO Bool := +timeit (fileName ++ " parser") $ do + let ctx := mkParserContextCore env input fileName; + let (stx, s, messages) := parseHeader env ctx; + when displayStx (IO.println stx); + testModuleParserAux env ctx displayStx s messages + +partial def parseFileAux (env : Environment) (ctx : ParserContextCore) : ModuleParserState → MessageLog → Array Syntax → IO Syntax +| state, msgs, stxs => + match parseCommand env ctx state msgs with + | (stx, state, msgs) => + if isEOI stx then + if msgs.isEmpty then + let stx := mkListNode stxs; + pure stx.updateLeading + else do + msgs.toList.forM $ fun msg => IO.println msg; + throw (IO.userError "failed to parse file") + else + parseFileAux state msgs (stxs.push stx) + +def parseFile (env : Environment) (fname : String) : IO Syntax := +do fname ← IO.realPath fname; + contents ← IO.readTextFile fname; + let ctx := mkParserContextCore env contents fname; + let (stx, state, messages) := parseHeader env ctx; + parseFileAux env ctx state messages #[stx] + +end Parser +end Lean diff --git a/stage0/src/Init/Lean/Parser/Parser.lean b/stage0/src/Init/Lean/Parser/Parser.lean new file mode 100644 index 0000000000..a3e5a6efe5 --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Parser.lean @@ -0,0 +1,1592 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Position +import Init.Lean.Syntax +import Init.Lean.ToExpr +import Init.Lean.Message +import Init.Lean.Environment +import Init.Lean.Attributes +import Init.Lean.Parser.Trie +import Init.Lean.Parser.Identifier +import Init.Lean.Compiler.InitAttr + +namespace Lean +namespace Parser + +abbrev mkAtom (info : SourceInfo) (val : String) : Syntax := +Syntax.atom info val + +abbrev mkIdent (info : SourceInfo) (rawVal : Substring) (val : Name) : Syntax := +Syntax.ident (some info) rawVal val [] + +/- Function application precedence. + In the standard lean language, only two tokens have precedence higher that `appPrec`. + - The token `.` has precedence `appPrec+1`. Thus, field accesses like `g (h x).f` are parsed as `g ((h x).f)`, + not `(g (h x)).f` + - The token `[` when not preceded with whitespace has precedence `appPrec+1`. If there is whitespace before + `[`, then its precedence is `appPrec`. Thus, `f a[i]` is parsed as `f (a[i])` where `a[i]` is an "find-like operation" + (e.g., array access, map access, etc.). `f a [i]` is parsed as `(f a) [i]` where `[i]` is a singleton collection + (e.g., a list). -/ +def appPrec : Nat := 1024 + +structure TokenConfig := +(val : String) +(lbp : Option Nat := none) +(lbpNoWs : Option Nat := none) -- optional left-binding power when there is not whitespace before the token. + +namespace TokenConfig + +def beq : TokenConfig → TokenConfig → Bool +| ⟨val₁, lbp₁, lbpnws₁⟩, ⟨val₂, lbp₂, lbpnws₂⟩ => val₁ == val₂ && lbp₁ == lbp₂ && lbpnws₁ == lbpnws₂ + +instance : HasBeq TokenConfig := +⟨beq⟩ + +def toStr : TokenConfig → String +| ⟨val, some lbp, some lbpnws⟩ => val ++ ":" ++ toString lbp ++ ":" ++ toString lbpnws +| ⟨val, some lbp, none⟩ => val ++ ":" ++ toString lbp +| ⟨val, none, some lbpnws⟩ => val ++ ":none:" ++ toString lbpnws +| ⟨val, none, none⟩ => val + +instance : HasToString TokenConfig := ⟨toStr⟩ + +end TokenConfig + +structure TokenCacheEntry := +(startPos stopPos : String.Pos := 0) +(token : Syntax := Syntax.missing) + +structure ParserCache := +(tokenCache : TokenCacheEntry := {}) + +def initCacheForInput (input : String) : ParserCache := +{ tokenCache := { startPos := input.bsize + 1 /- make sure it is not a valid position -/} } + +abbrev TokenTable := Trie TokenConfig + +abbrev SyntaxNodeKindSet := HashMap SyntaxNodeKind Unit + +structure ParserContextCore := +(input : String) +(fileName : String) +(fileMap : FileMap) +(tokens : TokenTable) + +instance ParserContextCore.inhabited : Inhabited ParserContextCore := +⟨{ input := "", fileName := "", fileMap := arbitrary _, tokens := {} }⟩ + +structure ParserContext extends ParserContextCore := +(env : Environment) + +structure Error := +(unexpected : String := "") +(expected : List String := []) + +namespace Error +instance : Inhabited Error := ⟨{}⟩ + +private def expectedToString : List String → String +| [] => "" +| [e] => e +| [e1, e2] => e1 ++ " or " ++ e2 +| e::es => e ++ ", " ++ expectedToString es + +protected def toString (e : Error) : String := +let unexpected := if e.unexpected == "" then [] else [e.unexpected]; +let expected := if e.expected == [] then [] else ["expected " ++ expectedToString e.expected]; +"; ".intercalate $ unexpected ++ expected + +instance : HasToString Error := ⟨Error.toString⟩ + +protected def beq (e₁ e₂ : Error) : Bool := +e₁.unexpected == e₂.unexpected && e₁.expected == e₂.expected + +instance : HasBeq Error := ⟨Error.beq⟩ + +def merge (e₁ e₂ : Error) : Error := +match e₂ with +| { unexpected := u, .. } => { unexpected := if u == "" then e₁.unexpected else u, expected := e₁.expected ++ e₂.expected } + +end Error + +structure ParserState := +(stxStack : Array Syntax := #[]) +(pos : String.Pos := 0) +(cache : ParserCache := {}) +(errorMsg : Option Error := none) + +namespace ParserState + +@[inline] def hasError (s : ParserState) : Bool := +s.errorMsg != none + +@[inline] def stackSize (s : ParserState) : Nat := +s.stxStack.size + +def restore (s : ParserState) (iniStackSz : Nat) (iniPos : Nat) : ParserState := +{ stxStack := s.stxStack.shrink iniStackSz, errorMsg := none, pos := iniPos, .. s} + +def setPos (s : ParserState) (pos : Nat) : ParserState := +{ pos := pos, .. s } + +def setCache (s : ParserState) (cache : ParserCache) : ParserState := +{ cache := cache, .. s } + +def pushSyntax (s : ParserState) (n : Syntax) : ParserState := +{ stxStack := s.stxStack.push n, .. s } + +def popSyntax (s : ParserState) : ParserState := +{ stxStack := s.stxStack.pop, .. s } + +def shrinkStack (s : ParserState) (iniStackSz : Nat) : ParserState := +{ stxStack := s.stxStack.shrink iniStackSz, .. s } + +def next (s : ParserState) (input : String) (pos : Nat) : ParserState := +{ pos := input.next pos, .. s } + +def toErrorMsg (ctx : ParserContext) (s : ParserState) : String := +match s.errorMsg with +| none => "" +| some msg => + let pos := ctx.fileMap.toPosition s.pos; + mkErrorStringWithPos ctx.fileName pos.line pos.column (toString msg) + +def mkNode (s : ParserState) (k : SyntaxNodeKind) (iniStackSz : Nat) : ParserState := +match s with +| ⟨stack, pos, cache, err⟩ => + if err != none && stack.size == iniStackSz then + -- If there is an error but there are no new nodes on the stack, we just return `d` + s + else + let newNode := Syntax.node k (stack.extract iniStackSz stack.size); + let stack := stack.shrink iniStackSz; + let stack := stack.push newNode; + ⟨stack, pos, cache, err⟩ + +def mkError (s : ParserState) (msg : String) : ParserState := +match s with +| ⟨stack, pos, cache, _⟩ => ⟨stack, pos, cache, some { expected := [ msg ] }⟩ + +def mkUnexpectedError (s : ParserState) (msg : String) : ParserState := +match s with +| ⟨stack, pos, cache, _⟩ => ⟨stack, pos, cache, some { unexpected := msg }⟩ + +def mkEOIError (s : ParserState) : ParserState := +s.mkUnexpectedError "end of input" + +def mkErrorAt (s : ParserState) (msg : String) (pos : String.Pos) : ParserState := +match s with +| ⟨stack, _, cache, _⟩ => ⟨stack, pos, cache, some { expected := [ msg ] }⟩ + +def mkErrorsAt (s : ParserState) (ex : List String) (pos : String.Pos) : ParserState := +match s with +| ⟨stack, _, cache, _⟩ => ⟨stack, pos, cache, some { expected := ex }⟩ + +def mkUnexpectedErrorAt (s : ParserState) (msg : String) (pos : String.Pos) : ParserState := +match s with +| ⟨stack, _, cache, _⟩ => ⟨stack, pos, cache, some { unexpected := msg }⟩ + +end ParserState + +inductive ParserKind +| leading | trailing + +export ParserKind (leading trailing) + +def ParserArg : ParserKind → Type +| ParserKind.leading => Nat +| ParserKind.trailing => Syntax + +def BasicParserFn := ParserContext → ParserState → ParserState + +def ParserFn (k : ParserKind) := ParserArg k → BasicParserFn + +instance ParserFn.inhabited (k : ParserKind) : Inhabited (ParserFn k) := ⟨fun _ _ => id⟩ + +inductive FirstTokens +| epsilon : FirstTokens +| unknown : FirstTokens +| tokens : List TokenConfig → FirstTokens +| optTokens : List TokenConfig → FirstTokens + +namespace FirstTokens + +def merge : FirstTokens → FirstTokens → FirstTokens +| epsilon, tks => tks +| tks, epsilon => tks +| tokens s₁, tokens s₂ => tokens (s₁ ++ s₂) +| optTokens s₁, optTokens s₂ => optTokens (s₁ ++ s₂) +| tokens s₁, optTokens s₂ => tokens (s₁ ++ s₂) +| optTokens s₁, tokens s₂ => tokens (s₁ ++ s₂) +| _, _ => unknown + +def seq : FirstTokens → FirstTokens → FirstTokens +| epsilon, tks => tks +| optTokens s₁, optTokens s₂ => optTokens (s₁ ++ s₂) +| optTokens s₁, tokens s₂ => tokens (s₁ ++ s₂) +| tks, _ => tks + +def toOptional : FirstTokens → FirstTokens +| tokens tks => optTokens tks +| tks => tks + +def toStr : FirstTokens → String +| epsilon => "epsilon" +| unknown => "unknown" +| tokens tks => toString tks +| optTokens tks => "?" ++ toString tks + +instance : HasToString FirstTokens := ⟨toStr⟩ + +end FirstTokens + +structure ParserInfo := +(updateTokens : TokenTable → ExceptT String Id TokenTable := fun tks => pure tks) +(updateKindSet : SyntaxNodeKindSet → SyntaxNodeKindSet := id) +(firstTokens : FirstTokens := FirstTokens.unknown) + +structure Parser (k : ParserKind := leading) := +(info : ParserInfo := {}) +(fn : ParserFn k) + +instance Parser.inhabited {k : ParserKind} : Inhabited (Parser k) := +⟨{ fn := fun _ _ s => s }⟩ + +abbrev TrailingParser := Parser trailing + +@[noinline] def epsilonInfo : ParserInfo := +{ firstTokens := FirstTokens.epsilon } + +@[inline] def pushLeadingFn : ParserFn trailing := +fun a c s => s.pushSyntax a + +@[inline] def pushLeading : TrailingParser := +{ info := epsilonInfo, + fn := pushLeadingFn } + +@[inline] def checkLeadingFn (p : Syntax → Bool) : ParserFn trailing := +fun a c s => + if p a then s + else s.mkUnexpectedError "invalid leading token" + +@[inline] def checkLeading (p : Syntax → Bool) : TrailingParser := +{ info := epsilonInfo, + fn := checkLeadingFn p } + +@[inline] def andthenAux (p q : BasicParserFn) : BasicParserFn := +fun c s => + let s := p c s; + if s.hasError then s else q c s + +@[inline] def andthenFn {k : ParserKind} (p q : ParserFn k) : ParserFn k := +fun a c s => andthenAux (p a) (q a) c s + +@[noinline] def andthenInfo (p q : ParserInfo) : ParserInfo := +{ updateTokens := fun tks => q.updateTokens tks >>= p.updateTokens, + updateKindSet := p.updateKindSet ∘ q.updateKindSet, + firstTokens := p.firstTokens.seq q.firstTokens } + +@[inline] def andthen {k : ParserKind} (p q : Parser k) : Parser k := +{ info := andthenInfo p.info q.info, + fn := andthenFn p.fn q.fn } + +instance hashAndthen {k : ParserKind} : HasAndthen (Parser k) := +⟨andthen⟩ + +@[inline] def nodeFn {k : ParserKind} (n : SyntaxNodeKind) (p : ParserFn k) : ParserFn k +| a, c, s => + let iniSz := s.stackSize; + let s := p a c s; + s.mkNode n iniSz + +@[noinline] def nodeInfo (n : SyntaxNodeKind) (p : ParserInfo) : ParserInfo := +{ updateTokens := p.updateTokens, + updateKindSet := fun s => s.insert n (), + firstTokens := p.firstTokens } + +@[inline] def node {k : ParserKind} (n : SyntaxNodeKind) (p : Parser k) : Parser k := +{ info := nodeInfo n p.info, + /- Remark: the compiler currently does not eta-expand structure fields. + So, we force it here to trigger inlining at `node` combinators. -/ + fn := nodeFn n p.fn } + +@[inline] def leadingNode (n : SyntaxNodeKind) (p : Parser leading) : Parser := +node n p + +@[inline] def trailingNode (n : SyntaxNodeKind) (p : Parser trailing) : TrailingParser := +node n p + +def mergeOrElseErrors (s : ParserState) (error1 : Error) (iniPos : Nat) : ParserState := +match s with +| ⟨stack, pos, cache, some error2⟩ => + if pos == iniPos then ⟨stack, pos, cache, some (error1.merge error2)⟩ + else s +| other => other + +@[inline] def orelseFn {k : ParserKind} (p q : ParserFn k) : ParserFn k +| a, c, s => + let iniSz := s.stackSize; + let iniPos := s.pos; + let s := p a c s; + match s.errorMsg with + | some errorMsg => + if s.pos == iniPos then + mergeOrElseErrors (q a c (s.restore iniSz iniPos)) errorMsg iniPos + else + s + | none => s + +@[noinline] def orelseInfo (p q : ParserInfo) : ParserInfo := +{ updateTokens := fun tks => q.updateTokens tks >>= p.updateTokens, + updateKindSet := p.updateKindSet ∘ q.updateKindSet, + firstTokens := p.firstTokens.merge q.firstTokens } + +@[inline] def orelse {k : ParserKind} (p q : Parser k) : Parser k := +{ info := orelseInfo p.info q.info, + fn := orelseFn p.fn q.fn } + +instance hashOrelse {k : ParserKind} : HasOrelse (Parser k) := +⟨orelse⟩ + +@[noinline] def noFirstTokenInfo (info : ParserInfo) : ParserInfo := +{ updateTokens := info.updateTokens, + updateKindSet := info.updateKindSet } + +@[inline] def tryFn {k : ParserKind} (p : ParserFn k ) : ParserFn k +| a, c, s => + let iniSz := s.stackSize; + let iniPos := s.pos; + match p a c s with + | ⟨stack, _, cache, some msg⟩ => ⟨stack.shrink iniSz, iniPos, cache, some msg⟩ + | other => other + +@[inline] def try {k : ParserKind} (p : Parser k) : Parser k := +{ info := p.info, + fn := tryFn p.fn } + +@[inline] def optionalFn {k : ParserKind} (p : ParserFn k) : ParserFn k := +fun a c s => + let iniSz := s.stackSize; + let iniPos := s.pos; + let s := p a c s; + let s := if s.hasError && s.pos == iniPos then s.restore iniSz iniPos else s; + s.mkNode nullKind iniSz + +@[noinline] def optionaInfo (p : ParserInfo) : ParserInfo := +{ updateTokens := p.updateTokens, + updateKindSet := p.updateKindSet, + firstTokens := p.firstTokens.toOptional } + +@[inline] def optional {k : ParserKind} (p : Parser k) : Parser k := +{ info := optionaInfo p.info, + fn := optionalFn p.fn } + +@[inline] def lookaheadFn {k : ParserKind} (p : ParserFn k) : ParserFn k := +fun a c s => + let iniSz := s.stackSize; + let iniPos := s.pos; + let s := p a c s; + if s.hasError then s else s.restore iniSz iniPos + +@[inline] def lookahead {k : ParserKind} (p : Parser k) : Parser k := +{ info := p.info, + fn := lookaheadFn p.fn } + +@[specialize] partial def manyAux {k : ParserKind} (p : ParserFn k) : ParserFn k +| a, c, s => + let iniSz := s.stackSize; + let iniPos := s.pos; + let s := p a c s; + if s.hasError then + if iniPos == s.pos then s.restore iniSz iniPos else s + else if iniPos == s.pos then s.mkUnexpectedError "invalid 'many' parser combinator application, parser did not consume anything" + else manyAux a c s + +@[inline] def manyFn {k : ParserKind} (p : ParserFn k) : ParserFn k := +fun a c s => + let iniSz := s.stackSize; + let s := manyAux p a c s; + s.mkNode nullKind iniSz + +@[inline] def many {k : ParserKind} (p : Parser k) : Parser k := +{ info := noFirstTokenInfo p.info, + fn := manyFn p.fn } + +@[inline] def many1Fn {k : ParserKind} (p : ParserFn k) : ParserFn k := +fun a c s => + let iniSz := s.stackSize; + let s := andthenFn p (manyAux p) a c s; + s.mkNode nullKind iniSz + +@[inline] def many1 {k : ParserKind} (p : Parser k) : Parser k := +{ info := p.info, + fn := many1Fn p.fn } + +@[specialize] private partial def sepByFnAux {k : ParserKind} (p : ParserFn k) (sep : ParserFn k) (allowTrailingSep : Bool) (iniSz : Nat) : Bool → ParserFn k +| pOpt, a, c, s => + let sz := s.stackSize; + let pos := s.pos; + let s := p a c s; + if s.hasError then + if pOpt then + let s := s.restore sz pos; + s.mkNode nullKind iniSz + else + -- append `Syntax.missing` to make clear that List is incomplete + let s := s.pushSyntax Syntax.missing; + s.mkNode nullKind iniSz + else + let sz := s.stackSize; + let pos := s.pos; + let s := sep a c s; + if s.hasError then + let s := s.restore sz pos; + s.mkNode nullKind iniSz + else + sepByFnAux allowTrailingSep a c s + +@[specialize] def sepByFn {k : ParserKind} (allowTrailingSep : Bool) (p : ParserFn k) (sep : ParserFn k) : ParserFn k +| a, c, s => + let iniSz := s.stackSize; + sepByFnAux p sep allowTrailingSep iniSz true a c s + +@[specialize] def sepBy1Fn {k : ParserKind} (allowTrailingSep : Bool) (p : ParserFn k) (sep : ParserFn k) : ParserFn k +| a, c, s => + let iniSz := s.stackSize; + sepByFnAux p sep allowTrailingSep iniSz false a c s + +@[noinline] def sepByInfo (p sep : ParserInfo) : ParserInfo := +{ updateTokens := fun tks => p.updateTokens tks >>= sep.updateTokens, + updateKindSet := p.updateKindSet ∘ sep.updateKindSet } + +@[noinline] def sepBy1Info (p sep : ParserInfo) : ParserInfo := +{ updateTokens := fun tks => p.updateTokens tks >>= sep.updateTokens, + updateKindSet := p.updateKindSet ∘ sep.updateKindSet, + firstTokens := p.firstTokens } + +@[inline] def sepBy {k : ParserKind} (p sep : Parser k) (allowTrailingSep : Bool := false) : Parser k := +{ info := sepByInfo p.info sep.info, + fn := sepByFn allowTrailingSep p.fn sep.fn } + +@[inline] def sepBy1 {k : ParserKind} (p sep : Parser k) (allowTrailingSep : Bool := false) : Parser k := +{ info := sepBy1Info p.info sep.info, + fn := sepBy1Fn allowTrailingSep p.fn sep.fn } + +@[specialize] partial def satisfyFn (p : Char → Bool) (errorMsg : String := "unexpected character") : BasicParserFn +| c, s => + let i := s.pos; + if c.input.atEnd i then s.mkEOIError + else if p (c.input.get i) then s.next c.input i + else s.mkUnexpectedError errorMsg + +@[specialize] partial def takeUntilFn (p : Char → Bool) : BasicParserFn +| c, s => + let i := s.pos; + if c.input.atEnd i then s + else if p (c.input.get i) then s + else takeUntilFn c (s.next c.input i) + +@[specialize] def takeWhileFn (p : Char → Bool) : BasicParserFn := +takeUntilFn (fun c => !p c) + +@[inline] def takeWhile1Fn (p : Char → Bool) (errorMsg : String) : BasicParserFn := +andthenAux (satisfyFn p errorMsg) (takeWhileFn p) + +partial def finishCommentBlock : Nat → BasicParserFn +| nesting, c, s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + let i := input.next i; + if curr == '-' then + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + if curr == '/' then -- "-/" end of comment + if nesting == 1 then s.next input i + else finishCommentBlock (nesting-1) c (s.next input i) + else + finishCommentBlock nesting c (s.next input i) + else if curr == '/' then + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + if curr == '-' then finishCommentBlock (nesting+1) c (s.next input i) + else finishCommentBlock nesting c (s.setPos i) + else finishCommentBlock nesting c (s.setPos i) + +/- Consume whitespace and comments -/ +partial def whitespace : BasicParserFn +| c, s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s + else + let curr := input.get i; + if curr.isWhitespace then whitespace c (s.next input i) + else if curr == '-' then + let i := input.next i; + let curr := input.get i; + if curr == '-' then andthenAux (takeUntilFn (fun c => c = '\n')) whitespace c (s.next input i) + else s + else if curr == '/' then + let i := input.next i; + let curr := input.get i; + if curr == '-' then + let i := input.next i; + let curr := input.get i; + if curr == '-' then s -- "/--" doc comment is an actual token + else andthenAux (finishCommentBlock 1) whitespace c (s.next input i) + else s + else s + +def mkEmptySubstringAt (s : String) (p : Nat) : Substring := +{str := s, startPos := p, stopPos := p } + +private def rawAux {k : ParserKind} (startPos : Nat) (trailingWs : Bool) : ParserFn k +| a, c, s => + let input := c.input; + let stopPos := s.pos; + let leading := mkEmptySubstringAt input startPos; + let val := input.extract startPos stopPos; + if trailingWs then + let s := whitespace c s; + let stopPos' := s.pos; + let trailing := { Substring . str := input, startPos := stopPos, stopPos := stopPos' }; + let atom := mkAtom { leading := leading, pos := startPos, trailing := trailing } val; + s.pushSyntax atom + else + let trailing := mkEmptySubstringAt input stopPos; + let atom := mkAtom { leading := leading, pos := startPos, trailing := trailing } val; + s.pushSyntax atom + +/-- Match an arbitrary Parser and return the consumed String in a `Syntax.atom`. -/ +@[inline] def rawFn {k : ParserKind} (p : ParserFn k) (trailingWs := false) : ParserFn k +| a, c, s => + let startPos := s.pos; + let s := p a c s; + if s.hasError then s else rawAux startPos trailingWs a c s + +@[inline] def chFn {k : ParserKind} (c : Char) (trailingWs := false) : ParserFn k := +rawFn (fun _ => satisfyFn (fun d => c == d) ("'" ++ toString c ++ "'")) trailingWs + +def rawCh {k : ParserKind} (c : Char) (trailingWs := false) : Parser k := +{ fn := chFn c trailingWs } + +def hexDigitFn : BasicParserFn +| c, s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + let i := input.next i; + if curr.isDigit || ('a' <= curr && curr <= 'f') || ('A' <= curr && curr <= 'F') then s.setPos i + else s.mkUnexpectedError "invalid hexadecimal numeral" + +def quotedCharFn : BasicParserFn +| c, s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + if curr == '\\' || curr == '\"' || curr == '\'' || curr == 'n' || curr == 't' then + s.next input i + else if curr == 'x' then + andthenAux hexDigitFn hexDigitFn c (s.next input i) + else if curr == 'u' then + andthenAux hexDigitFn (andthenAux hexDigitFn (andthenAux hexDigitFn hexDigitFn)) c (s.next input i) + else + s.mkUnexpectedError "invalid escape sequence" + +/-- Push `(Syntax.node tk )` into syntax stack -/ +def mkNodeToken (n : SyntaxNodeKind) (startPos : Nat) : BasicParserFn := +fun c s => +let input := c.input; +let stopPos := s.pos; +let leading := mkEmptySubstringAt input startPos; +let val := input.extract startPos stopPos; +let s := whitespace c s; +let wsStopPos := s.pos; +let trailing := { Substring . str := input, startPos := stopPos, stopPos := wsStopPos }; +let info := { SourceInfo . leading := leading, pos := startPos, trailing := trailing }; +s.pushSyntax (mkStxLit n val (some info)) + +def charLitFnAux (startPos : Nat) : BasicParserFn +| c, s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + let s := s.setPos (input.next i); + let s := if curr == '\\' then quotedCharFn c s else s; + if s.hasError then s + else + let i := s.pos; + let curr := input.get i; + let s := s.setPos (input.next i); + if curr == '\'' then mkNodeToken charLitKind startPos c s + else s.mkUnexpectedError "missing end of character literal" + +partial def strLitFnAux (startPos : Nat) : BasicParserFn +| c, s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + let s := s.setPos (input.next i); + if curr == '\"' then + mkNodeToken strLitKind startPos c s + else if curr == '\\' then andthenAux quotedCharFn strLitFnAux c s + else strLitFnAux c s + +def decimalNumberFn (startPos : Nat) : BasicParserFn := +fun c s => + let s := takeWhileFn (fun c => c.isDigit) c s; + let input := c.input; + let i := s.pos; + let curr := input.get i; + let s := + /- TODO(Leo): should we use a different kind for numerals containing decimal points? -/ + if curr == '.' then + let i := input.next i; + let curr := input.get i; + if curr.isDigit then + takeWhileFn (fun c => c.isDigit) c (s.setPos i) + else s + else s; + mkNodeToken numLitKind startPos c s + +def binNumberFn (startPos : Nat) : BasicParserFn := +fun c s => + let s := takeWhile1Fn (fun c => c == '0' || c == '1') "binary number" c s; + mkNodeToken numLitKind startPos c s + +def octalNumberFn (startPos : Nat) : BasicParserFn := +fun c s => + let s := takeWhile1Fn (fun c => '0' ≤ c && c ≤ '7') "octal number" c s; + mkNodeToken numLitKind startPos c s + +def hexNumberFn (startPos : Nat) : BasicParserFn := +fun c s => + let s := takeWhile1Fn (fun c => ('0' ≤ c && c ≤ '9') || ('a' ≤ c && c ≤ 'f') || ('A' ≤ c && c ≤ 'F')) "hexadecimal number" c s; + mkNodeToken numLitKind startPos c s + +def numberFnAux : BasicParserFn := +fun c s => + let input := c.input; + let startPos := s.pos; + if input.atEnd startPos then s.mkEOIError + else + let curr := input.get startPos; + if curr == '0' then + let i := input.next startPos; + let curr := input.get i; + if curr == 'b' || curr == 'B' then + binNumberFn startPos c (s.next input i) + else if curr == 'o' || curr == 'O' then + octalNumberFn startPos c (s.next input i) + else if curr == 'x' || curr == 'X' then + hexNumberFn startPos c (s.next input i) + else + decimalNumberFn startPos c (s.setPos i) + else if curr.isDigit then + decimalNumberFn startPos c (s.next input startPos) + else + s.mkError "numeral" + +def isIdCont : String → ParserState → Bool +| input, s => + let i := s.pos; + let curr := input.get i; + if curr == '.' then + let i := input.next i; + if input.atEnd i then + false + else + let curr := input.get i; + isIdFirst curr || isIdBeginEscape curr + else + false + +private def isToken (idStartPos idStopPos : Nat) (tk : Option TokenConfig) : Bool := +match tk with +| none => false +| some tk => + -- if a token is both a symbol and a valid identifier (i.e. a keyword), + -- we want it to be recognized as a symbol + tk.val.bsize ≥ idStopPos - idStartPos + +def mkTokenAndFixPos (startPos : Nat) (tk : Option TokenConfig) : BasicParserFn := +fun c s => +match tk with +| none => s.mkErrorAt "token" startPos +| some tk => + let input := c.input; + let leading := mkEmptySubstringAt input startPos; + let val := tk.val; + let stopPos := startPos + val.bsize; + let s := s.setPos stopPos; + let s := whitespace c s; + let wsStopPos := s.pos; + let trailing := { Substring . str := input, startPos := stopPos, stopPos := wsStopPos }; + let atom := mkAtom { leading := leading, pos := startPos, trailing := trailing } val; + s.pushSyntax atom + +def mkIdResult (startPos : Nat) (tk : Option TokenConfig) (val : Name) : BasicParserFn := +fun c s => +let stopPos := s.pos; +if isToken startPos stopPos tk then + mkTokenAndFixPos startPos tk c s +else + let input := c.input; + let rawVal := { Substring . str := input, startPos := startPos, stopPos := stopPos }; + let s := whitespace c s; + let trailingStopPos := s.pos; + let leading := mkEmptySubstringAt input startPos; + let trailing := { Substring . str := input, startPos := stopPos, stopPos := trailingStopPos }; + let info := { SourceInfo . leading := leading, trailing := trailing, pos := startPos }; + let atom := mkIdent info rawVal val; + s.pushSyntax atom + +partial def identFnAux (startPos : Nat) (tk : Option TokenConfig) : Name → BasicParserFn +| r, c, s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else + let curr := input.get i; + if isIdBeginEscape curr then + let startPart := input.next i; + let s := takeUntilFn isIdEndEscape c (s.setPos startPart); + let stopPart := s.pos; + let s := satisfyFn isIdEndEscape "missing end of escaped identifier" c s; + if s.hasError then s + else + let r := mkNameStr r (input.extract startPart stopPart); + if isIdCont input s then + let s := s.next input s.pos; + identFnAux r c s + else + mkIdResult startPos tk r c s + else if isIdFirst curr then + let startPart := i; + let s := takeWhileFn isIdRest c (s.next input i); + let stopPart := s.pos; + let r := mkNameStr r (input.extract startPart stopPart); + if isIdCont input s then + let s := s.next input s.pos; + identFnAux r c s + else + mkIdResult startPos tk r c s + else + mkTokenAndFixPos startPos tk c s + +private def tokenFnAux : BasicParserFn +| c, s => + let input := c.input; + let i := s.pos; + let curr := input.get i; + if curr == '\"' then + strLitFnAux i c (s.next input i) + else if curr == '\'' then + charLitFnAux i c (s.next input i) + else if curr.isDigit then + numberFnAux c s + else + let (_, tk) := c.tokens.matchPrefix input i; + identFnAux i tk Name.anonymous c s + +private def updateCache (startPos : Nat) (s : ParserState) : ParserState := +match s with +| ⟨stack, pos, cache, none⟩ => + if stack.size == 0 then s + else + let tk := stack.back; + ⟨stack, pos, { tokenCache := { startPos := startPos, stopPos := pos, token := tk } }, none⟩ +| other => other + +def tokenFn : BasicParserFn := +fun c s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else + let tkc := s.cache.tokenCache; + if tkc.startPos == i then + let s := s.pushSyntax tkc.token; + s.setPos tkc.stopPos + else + let s := tokenFnAux c s; + updateCache i s + +def peekToken (c : ParserContext) (s : ParserState) : ParserState × Option Syntax := +let iniSz := s.stackSize; +let iniPos := s.pos; +let s := tokenFn c s; +if s.hasError then (s.restore iniSz iniPos, none) +else + let stx := s.stxStack.back; + (s.restore iniSz iniPos, some stx) + +/- Treat keywords as identifiers. -/ +def rawIdentFn : BasicParserFn := +fun c s => + let input := c.input; + let i := s.pos; + if input.atEnd i then s.mkEOIError + else identFnAux i none Name.anonymous c s + +@[inline] def satisfySymbolFn (p : String → Bool) (expected : List String) : BasicParserFn := +fun c s => + let startPos := s.pos; + let s := tokenFn c s; + if s.hasError then + s.mkErrorsAt expected startPos + else + match s.stxStack.back with + | Syntax.atom _ sym => if p sym then s else s.mkErrorsAt expected startPos + | _ => s.mkErrorsAt expected startPos + +@[inline] def symbolFnAux (sym : String) (errorMsg : String) : BasicParserFn := +satisfySymbolFn (fun s => s == sym) [errorMsg] + +def insertToken (sym : String) (lbp : Option Nat) (tks : TokenTable) : ExceptT String Id TokenTable := +if sym == "" then throw "invalid empty symbol" +else match tks.find sym, lbp with +| none, _ => pure (tks.insert sym { val := sym, lbp := lbp }) +| some _, none => pure tks +| some tk, some newLbp => + match tk.lbp with + | none => pure (tks.insert sym { lbp := lbp, .. tk }) + | some oldLbp => if newLbp == oldLbp then pure tks else throw ("precedence mismatch for '" ++ toString sym ++ "', previous: " ++ toString oldLbp ++ ", new: " ++ toString newLbp) + +def symbolInfo (sym : String) (lbp : Option Nat) : ParserInfo := +{ updateTokens := insertToken sym lbp, + firstTokens := FirstTokens.tokens [ { val := sym, lbp := lbp } ] } + +@[inline] def symbolFn {k : ParserKind} (sym : String) : ParserFn k := +fun _ => symbolFnAux sym ("'" ++ sym ++ "'") + +@[inline] def symbolAux {k : ParserKind} (sym : String) (lbp : Option Nat := none) : Parser k := +let sym := sym.trim; +{ info := symbolInfo sym lbp, + fn := symbolFn sym } + +@[inline] def symbol {k : ParserKind} (sym : String) (lbp : Nat) : Parser k := +symbolAux sym lbp + +/-- Check if the following token is the symbol _or_ identifier `sym`. Useful for + parsing local tokens that have not been added to the token table (but may have + been so by some unrelated code). + + For example, the universe `max` Function is parsed using this combinator so that + it can still be used as an identifier outside of universes (but registering it + as a token in a Term Syntax would not break the universe Parser). -/ +def symbolOrIdentFnAux (sym : String) (errorMsg : String) : BasicParserFn := +fun c s => + let startPos := s.pos; + let s := tokenFn c s; + if s.hasError then s.mkErrorAt errorMsg startPos + else + match s.stxStack.back with + | Syntax.atom _ sym' => + if sym == sym' then s else s.mkErrorAt errorMsg startPos + | Syntax.ident info rawVal _ _ => + if sym == rawVal.toString then + let s := s.popSyntax; + s.pushSyntax (Syntax.atom info sym) + else + s.mkErrorAt errorMsg startPos + | _ => s.mkErrorAt errorMsg startPos + +@[inline] def symbolOrIdentFn (sym : String) : BasicParserFn := +symbolOrIdentFnAux sym ("'" ++ sym ++ "'") + +def symbolOrIdentInfo (sym : String) : ParserInfo := +{ firstTokens := FirstTokens.tokens [ { val := sym }, { val := "ident" } ] } + +@[inline] def symbolOrIdent {k : ParserKind} (sym : String) : Parser k := +let sym := sym.trim; +{ info := symbolOrIdentInfo sym, + fn := fun _ => symbolOrIdentFn sym } + +partial def strAux (sym : String) (errorMsg : String) : Nat → BasicParserFn +| j, c, s => + if sym.atEnd j then s + else + let i := s.pos; + let input := c.input; + if input.atEnd i || sym.get j != input.get i then s.mkError errorMsg + else strAux (sym.next j) c (s.next input i) + +def checkTailWs (prev : Syntax) : Bool := +match prev.getTailInfo with +| some info => info.trailing.stopPos > info.trailing.startPos +| none => false + +def checkWsBeforeFn (errorMsg : String) : BasicParserFn := +fun c s => + let prev := s.stxStack.back; + if checkTailWs prev then s else s.mkError errorMsg + +def checkWsBefore {k : ParserKind} (errorMsg : String) : Parser k := +{ info := epsilonInfo, + fn := fun _ => checkWsBeforeFn errorMsg } + +def checkTailNoWs (prev : Syntax) : Bool := +match prev.getTailInfo with +| some info => info.trailing.stopPos == info.trailing.startPos +| none => false + +def checkNoWsBeforeFn (errorMsg : String) : BasicParserFn := +fun c s => + let prev := s.stxStack.back; + if checkTailNoWs prev then s else s.mkError errorMsg + +def checkNoWsBefore {k : ParserKind} (errorMsg : String) : Parser k := +{ info := epsilonInfo, + fn := fun _ => checkNoWsBeforeFn errorMsg } + +def insertNoWsToken (sym : String) (lbpNoWs : Option Nat) (tks : TokenTable) : ExceptT String Id TokenTable := +if sym == "" then throw "invalid empty symbol" +else match tks.find sym, lbpNoWs with +| none, _ => pure (tks.insert sym { val := sym, lbpNoWs := lbpNoWs }) +| some _, none => pure tks +| some tk, some newLbp => + match tk.lbpNoWs with + | none => pure (tks.insert sym { lbpNoWs := lbpNoWs, .. tk }) + | some oldLbp => if newLbp == oldLbp then pure tks else throw ("(no whitespace) precedence mismatch for '" ++ toString sym ++ "', previous: " ++ toString oldLbp ++ ", new: " ++ toString newLbp) + +def symbolNoWsInfo (sym : String) (lbpNoWs : Option Nat) : ParserInfo := +{ updateTokens := insertNoWsToken sym lbpNoWs, + firstTokens := FirstTokens.tokens [ { val := sym, lbpNoWs := lbpNoWs } ] } + +@[inline] def symbolNoWsFnAux (sym : String) (errorMsg : String) : ParserFn trailing := +fun left c s => + if checkTailNoWs left then + let startPos := s.pos; + let input := c.input; + let s := strAux sym errorMsg 0 c s; + if s.hasError then s + else + let leading := mkEmptySubstringAt input startPos; + let stopPos := startPos + sym.bsize; + let trailing := mkEmptySubstringAt input stopPos; + let atom := mkAtom { leading := leading, pos := startPos, trailing := trailing } sym; + s.pushSyntax atom + else + s.mkError errorMsg + +@[inline] def symbolNoWsFn (sym : String) : ParserFn trailing := +symbolNoWsFnAux sym ("'" ++ sym ++ "' without whitespaces around it") + +/- Similar to `symbol`, but succeeds only if there is no space whitespace after leading term and after `sym`. -/ +@[inline] def symbolNoWsAux (sym : String) (lbp : Option Nat) : TrailingParser := +let sym := sym.trim; +{ info := symbolNoWsInfo sym lbp, + fn := symbolNoWsFn sym } + +@[inline] def symbolNoWs (sym : String) (lbp : Nat) : TrailingParser := +symbolNoWsAux sym lbp + +def unicodeSymbolFnAux (sym asciiSym : String) (expected : List String) : BasicParserFn := +satisfySymbolFn (fun s => s == sym || s == asciiSym) expected + +def unicodeSymbolInfo (sym asciiSym : String) (lbp : Option Nat) : ParserInfo := +{ updateTokens := fun tks => insertToken sym lbp tks >>= insertToken asciiSym lbp, + firstTokens := FirstTokens.tokens [ { val := sym, lbp := lbp }, { val := asciiSym, lbp := lbp } ] } + +@[inline] def unicodeSymbolFn {k : ParserKind} (sym asciiSym : String) : ParserFn k := +fun _ => unicodeSymbolFnAux sym asciiSym ["'" ++ sym ++ "', '" ++ asciiSym ++ "'"] + +@[inline] def unicodeSymbol {k : ParserKind} (sym asciiSym : String) (lbp : Option Nat := none) : Parser k := +let sym := sym.trim; +let asciiSym := asciiSym.trim; +{ info := unicodeSymbolInfo sym asciiSym lbp, + fn := unicodeSymbolFn sym asciiSym } + +def unicodeSymbolCheckPrecFnAux (sym asciiSym : String) (lbp : Nat) (expected : List String) (precErrorMsg : String) : ParserFn leading := +fun (rbp : Nat) c s => + if rbp > lbp then s.mkUnexpectedError precErrorMsg + else satisfySymbolFn (fun s => s == sym || s == asciiSym) expected c s + +@[inline] def unicodeSymbolCheckPrecFn (sym asciiSym : String) (lbp : Nat) : ParserFn leading := +unicodeSymbolCheckPrecFnAux sym asciiSym lbp + ["'" ++ sym ++ "'", "'" ++ asciiSym ++ "'"] + ("found '" ++ sym ++ "' as expected, but brackets are needed") -- improve error message + +@[inline] def unicodeSymbolCheckPrec (sym asciiSym : String) (lbp : Nat) : Parser leading := +let sym := sym.trim; +let asciiSym := asciiSym.trim; +{ info := unicodeSymbolInfo sym asciiSym lbp, + fn := unicodeSymbolCheckPrecFn sym asciiSym lbp } + +def mkAtomicInfo (k : String) : ParserInfo := +{ firstTokens := FirstTokens.tokens [ { val := k } ] } + +def numLitFn {k : ParserKind} : ParserFn k := +fun _ c s => + let iniPos := s.pos; + let s := tokenFn c s; + if s.hasError || !(s.stxStack.back.isOfKind numLitKind) then s.mkErrorAt "numeral" iniPos else s + +@[inline] def numLit {k : ParserKind} : Parser k := +{ fn := numLitFn, + info := mkAtomicInfo "numLit" } + +def strLitFn {k : ParserKind} : ParserFn k := +fun _ c s => + let iniPos := s.pos; + let s := tokenFn c s; + if s.hasError || !(s.stxStack.back.isOfKind strLitKind) then s.mkErrorAt "string literal" iniPos else s + +@[inline] def strLit {k : ParserKind} : Parser k := +{ fn := strLitFn, + info := mkAtomicInfo "strLit" } + +def charLitFn {k : ParserKind} : ParserFn k := +fun _ c s => + let iniPos := s.pos; + let s := tokenFn c s; + if s.hasError || !(s.stxStack.back.isOfKind charLitKind) then s.mkErrorAt "character literal" iniPos else s + +@[inline] def charLit {k : ParserKind} : Parser k := +{ fn := charLitFn, + info := mkAtomicInfo "charLit" } + +def identFn {k : ParserKind} : ParserFn k := +fun _ c s => + let iniPos := s.pos; + let s := tokenFn c s; + if s.hasError || !(s.stxStack.back.isIdent) then s.mkErrorAt "identifier" iniPos else s + +@[inline] def ident {k : ParserKind} : Parser k := +{ fn := identFn, + info := mkAtomicInfo "ident" } + +@[inline] def rawIdent {k : ParserKind} : Parser k := +{ fn := fun _ => rawIdentFn } + +def quotedSymbolFn {k : ParserKind} : ParserFn k := +nodeFn `quotedSymbol (andthenFn (andthenFn (chFn '`') (rawFn (fun _ => takeUntilFn (fun c => c == '`')))) (chFn '`' true)) + +def quotedSymbol {k : ParserKind} : Parser k := +{ fn := quotedSymbolFn } + +def unquotedSymbolFn {k : ParserKind} : ParserFn k := +fun _ c s => + let iniPos := s.pos; + let s := tokenFn c s; + if s.hasError || s.stxStack.back.isIdent || s.stxStack.back.isOfKind strLitKind || s.stxStack.back.isOfKind charLitKind || s.stxStack.back.isOfKind numLitKind then + s.mkErrorAt "symbol" iniPos + else + s + +def unquotedSymbol {k : ParserKind} : Parser k := +{ fn := unquotedSymbolFn } + +def fieldIdxFn : BasicParserFn := +fun c s => + let iniPos := s.pos; + let curr := c.input.get iniPos; + if curr.isDigit && curr != '0' then + let s := takeWhileFn (fun c => c.isDigit) c s; + mkNodeToken fieldIdxKind iniPos c s + else + s.mkErrorAt "field index" iniPos + +@[inline] def fieldIdx {k : ParserKind} : Parser k := +{ fn := fun _ => fieldIdxFn, + info := mkAtomicInfo "fieldIdx" } + +instance string2basic {k : ParserKind} : HasCoe String (Parser k) := +⟨symbolAux⟩ + +namespace ParserState + +def keepNewError (s : ParserState) (oldStackSize : Nat) : ParserState := +match s with +| ⟨stack, pos, cache, err⟩ => ⟨stack.shrink oldStackSize, pos, cache, err⟩ + +def keepPrevError (s : ParserState) (oldStackSize : Nat) (oldStopPos : String.Pos) (oldError : Option Error) : ParserState := +match s with +| ⟨stack, _, cache, _⟩ => ⟨stack.shrink oldStackSize, oldStopPos, cache, oldError⟩ + +def mergeErrors (s : ParserState) (oldStackSize : Nat) (oldError : Error) : ParserState := +match s with +| ⟨stack, pos, cache, some err⟩ => + if oldError == err then s + else ⟨stack.shrink oldStackSize, pos, cache, some (oldError.merge err)⟩ +| other => other + +def mkLongestNodeAlt (s : ParserState) (startSize : Nat) : ParserState := +match s with +| ⟨stack, pos, cache, _⟩ => + if stack.size == startSize then ⟨stack.push Syntax.missing, pos, cache, none⟩ -- parser did not create any node, then we just add `Syntax.missing` + else if stack.size == startSize + 1 then s + else + -- parser created more than one node, combine them into a single node + let node := Syntax.node nullKind (stack.extract startSize stack.size); + let stack := stack.shrink startSize; + ⟨stack.push node, pos, cache, none⟩ + +def keepLatest (s : ParserState) (startStackSize : Nat) : ParserState := +match s with +| ⟨stack, pos, cache, _⟩ => + let node := stack.back; + let stack := stack.shrink startStackSize; + let stack := stack.push node; + ⟨stack, pos, cache, none⟩ + +def replaceLongest (s : ParserState) (startStackSize : Nat) (prevStackSize : Nat) : ParserState := +let s := s.mkLongestNodeAlt prevStackSize; +s.keepLatest startStackSize + +end ParserState + +def longestMatchStep {k : ParserKind} (startSize : Nat) (startPos : String.Pos) (p : ParserFn k) : ParserFn k := +fun a c s => +let prevErrorMsg := s.errorMsg; +let prevStopPos := s.pos; +let prevSize := s.stackSize; +let s := s.restore prevSize startPos; +let s := p a c s; +match prevErrorMsg, s.errorMsg with +| none, none => -- both succeeded + if s.pos > prevStopPos then s.replaceLongest startSize prevSize -- replace + else if s.pos < prevStopPos then s.restore prevSize prevStopPos -- keep prev + else s.mkLongestNodeAlt prevSize -- keep both +| none, some _ => -- prev succeeded, current failed + s.restore prevSize prevStopPos +| some oldError, some _ => -- both failed + if s.pos > prevStopPos then s.keepNewError prevSize + else if s.pos < prevStopPos then s.keepPrevError prevSize prevStopPos prevErrorMsg + else s.mergeErrors prevSize oldError +| some _, none => -- prev failed, current succeeded + s.mkLongestNodeAlt startSize + +def longestMatchMkResult (startSize : Nat) (s : ParserState) : ParserState := +if !s.hasError && s.stackSize > startSize + 1 then s.mkNode choiceKind startSize else s + +def longestMatchFnAux {k : ParserKind} (startSize : Nat) (startPos : String.Pos) : List (Parser k) → ParserFn k +| [] => fun _ _ s => longestMatchMkResult startSize s +| p::ps => fun a c s => + let s := longestMatchStep startSize startPos p.fn a c s; + longestMatchFnAux ps a c s + +def longestMatchFn₁ {k : ParserKind} (p : ParserFn k) : ParserFn k := +fun a c s => +let startSize := s.stackSize; +let s := p a c s; +if s.hasError then s else s.mkLongestNodeAlt startSize + +def longestMatchFn {k : ParserKind} : List (Parser k) → ParserFn k +| [] => fun _ _ s => s.mkError "longestMatch: empty list" +| [p] => longestMatchFn₁ p.fn +| p::ps => fun a c s => + let startSize := s.stackSize; + let startPos := s.pos; + let s := p.fn a c s; + if s.hasError then + let s := s.shrinkStack startSize; + longestMatchFnAux startSize startPos ps a c s + else + let s := s.mkLongestNodeAlt startSize; + longestMatchFnAux startSize startPos ps a c s + +def anyOfFn {k : ParserKind} : List (Parser k) → ParserFn k +| [], _, _, s => s.mkError "anyOf: empty list" +| [p], a, c, s => p.fn a c s +| p::ps, a, c, s => orelseFn p.fn (anyOfFn ps) a c s + +@[inline] def checkColGeFn (col : Nat) (errorMsg : String) : BasicParserFn := +fun c s => + let pos := c.fileMap.toPosition s.pos; + if pos.column ≥ col then s + else s.mkError errorMsg + +@[inline] def checkColGe {k : ParserKind} (col : Nat) (errorMsg : String) : Parser k := +{ fn := fun _ => checkColGeFn col errorMsg } + +@[inline] def withPosition {k : ParserKind} (p : Position → Parser k) : Parser k := +{ info := (p { line := 1, column := 0 }).info, + fn := fun a c s => + let pos := c.fileMap.toPosition s.pos; + (p pos).fn a c s } + +@[inline] def many1Indent {k : ParserKind} (p : Parser k) (errorMsg : String) : Parser k := +withPosition $ fun pos => many1 (checkColGe pos.column errorMsg >> p) + +/-- A multimap indexed by tokens. Used for indexing parsers by their leading token. -/ +def TokenMap (α : Type) := RBMap Name (List α) Name.quickLt + +namespace TokenMap + +def insert {α : Type} (map : TokenMap α) (k : Name) (v : α) : TokenMap α := +match map.find k with +| none => map.insert k [v] +| some vs => map.insert k (v::vs) + +instance {α : Type} : Inhabited (TokenMap α) := ⟨RBMap.empty⟩ + +instance {α : Type} : HasEmptyc (TokenMap α) := ⟨RBMap.empty⟩ + +end TokenMap + +structure ParsingTables := +(leadingTable : TokenMap Parser := {}) +(trailingTable : TokenMap TrailingParser := {}) +(trailingParsers : List TrailingParser := []) -- for supporting parsers such as function application + +instance ParsingTables.inhabited : Inhabited ParsingTables := ⟨{}⟩ + +def currLbp (left : Syntax) (c : ParserContext) (s : ParserState) : ParserState × Nat := +let (s, stx) := peekToken c s; +match stx with +| some (Syntax.atom _ sym) => + match c.tokens.matchPrefix sym 0 with + | (_, some tk) => match tk.lbp, tk.lbpNoWs with + | some lbp, none => (s, lbp) + | none, some lbpNoWs => (s, lbpNoWs) + | some lbp, some lbpNoWs => if checkTailNoWs left then (s, lbpNoWs) else (s, lbp) + | none, none => (s, 0) + | _ => (s, 0) +| some (Syntax.ident _ _ _ _) => (s, appPrec) +-- TODO(Leo): add support for associating lbp with syntax node kinds. +| some (Syntax.node k _) => if k == numLitKind || k == charLitKind || k == strLitKind || k == fieldIdxKind then (s, appPrec) else (s, 0) +| _ => (s, 0) + +def indexed {α : Type} (map : TokenMap α) (c : ParserContext) (s : ParserState) : ParserState × List α := +let (s, stx) := peekToken c s; +let find (n : Name) : ParserState × List α := + match map.find n with + | some as => (s, as) + | _ => (s, []); +match stx with +| some (Syntax.atom _ sym) => find (mkNameSimple sym) +| some (Syntax.ident _ _ _ _) => find `ident +| some (Syntax.node k _) => find k +| _ => (s, []) + +private def mkResult (s : ParserState) (iniSz : Nat) : ParserState := +if s.stackSize == iniSz + 1 then s +else s.mkNode nullKind iniSz -- throw error instead? + +def leadingParser (kind : String) (tables : ParsingTables) : ParserFn leading := +fun a c s => + let iniSz := s.stackSize; + let (s, ps) := indexed tables.leadingTable c s; + if ps.isEmpty then + s.mkError kind + else + let s := longestMatchFn ps a c s; + mkResult s iniSz + +def trailingLoopStep (tables : ParsingTables) (ps : List (Parser trailing)) : ParserFn trailing := +fun left c s => + orelseFn (longestMatchFn ps) (anyOfFn tables.trailingParsers) left c s + +partial def trailingLoop (tables : ParsingTables) (rbp : Nat) (c : ParserContext) : Syntax → ParserState → ParserState +| left, s => + let (s, lbp) := currLbp left c s; + if rbp ≥ lbp then s.pushSyntax left + else + let iniSz := s.stackSize; + let (s, ps) := indexed tables.trailingTable c s; + if ps.isEmpty && tables.trailingParsers.isEmpty then + s.pushSyntax left -- no available trailing parser + else + let s := trailingLoopStep tables ps left c s; + if s.hasError then s + else + let s := mkResult s iniSz; + let left := s.stxStack.back; + let s := s.popSyntax; + trailingLoop left s + +def prattParser (kind : String) (tables : ParsingTables) : ParserFn leading := +fun rbp c s => + let s := leadingParser kind tables rbp c s; + if s.hasError then s + else + let left := s.stxStack.back; + let s := s.popSyntax; + trailingLoop tables rbp c left s + +def mkBuiltinTokenTable : IO (IO.Ref TokenTable) := +IO.mkRef {} + +@[init mkBuiltinTokenTable] +constant builtinTokenTable : IO.Ref TokenTable := arbitrary _ + +def mkImportedTokenTable (es : Array (Array TokenConfig)) : IO TokenTable := +do table ← builtinTokenTable.get; + -- TODO: add `es` to `table` + pure table + +/- We use a TokenTable attribute to make sure they are scoped. + Users do not directly use this attribute. They use them indirectly when + they use parser attributes. -/ +structure TokenTableAttribute := +(attr : AttributeImpl) +(ext : PersistentEnvExtension TokenConfig TokenTable) + +instance TokenTableAttribute.inhabited : Inhabited TokenTableAttribute := ⟨{ attr := arbitrary _, ext := arbitrary _ }⟩ + +section +set_option compiler.extract_closed false +def mkTokenTableAttribute : IO TokenTableAttribute := +do ext : PersistentEnvExtension TokenConfig TokenTable ← registerPersistentEnvExtension { + name := `_tokens_, + addImportedFn := fun es => mkImportedTokenTable es, + addEntryFn := fun (s : TokenTable) _ => s, -- TODO + exportEntriesFn := fun _ => #[], -- TODO + statsFn := fun _ => fmt "token table attribute" -- TODO + }; + let attrImpl : AttributeImpl := { + name := `_tokens_, + descr := "internal token table attribute", + add := fun env decl args persistent => pure env -- TODO + }; + pure { ext := ext, attr := attrImpl } +end + +@[init mkTokenTableAttribute] +constant tokenTableAttribute : TokenTableAttribute := arbitrary _ + +/- Global table with all SyntaxNodeKind's -/ +def mkSyntaxNodeKindSetRef : IO (IO.Ref SyntaxNodeKindSet) := IO.mkRef {} +@[init mkSyntaxNodeKindSetRef] +constant syntaxNodeKindSetRef : IO.Ref SyntaxNodeKindSet := arbitrary _ + +def updateSyntaxNodeKinds (pinfo : ParserInfo) : IO Unit := +syntaxNodeKindSetRef.modify pinfo.updateKindSet + +def isValidSyntaxNodeKind (k : SyntaxNodeKind) : IO Bool := +do s ← syntaxNodeKindSetRef.get; + pure $ s.contains k + +def getSyntaxNodeKinds : IO (List SyntaxNodeKind) := +do s ← syntaxNodeKindSetRef.get; + pure $ s.fold (fun ks k _ => k::ks) [] + +def mkParserContextCore (env : Environment) (input : String) (fileName : String) : ParserContextCore := +{ input := input, + fileName := fileName, + fileMap := input.toFileMap, + tokens := tokenTableAttribute.ext.getState env } + +@[inline] def ParserContextCore.toParserContext (env : Environment) (ctx : ParserContextCore) : ParserContext := +{ env := env, toParserContextCore := ctx } + +def mkParserContext (env : Environment) (input : String) (fileName : String) : ParserContext := +(mkParserContextCore env input fileName).toParserContext env + +def mkParserState (input : String) : ParserState := +{ cache := initCacheForInput input } + +def runParser (env : Environment) (tables : ParsingTables) (input : String) (fileName := "") (kind := "
") : Except String Syntax := +let c := mkParserContext env input fileName; +let s := mkParserState input; +let s := whitespace c s; +let s := prattParser kind tables (0 : Nat) c s; +if s.hasError then + Except.error (s.toErrorMsg c) +else + Except.ok s.stxStack.back + +def mkBuiltinParsingTablesRef : IO (IO.Ref ParsingTables) := +IO.mkRef {} + +private def updateTokens (info : ParserInfo) (declName : Name) : IO Unit := +do tokens ← builtinTokenTable.swap {}; + match info.updateTokens tokens with + | Except.ok newTokens => builtinTokenTable.set newTokens + | Except.error msg => throw (IO.userError ("invalid builtin parser '" ++ toString declName ++ "', " ++ msg)) + +def addBuiltinLeadingParser (tablesRef : IO.Ref ParsingTables) (declName : Name) (p : Parser) : IO Unit := +do tables ← tablesRef.get; + tablesRef.reset; + updateTokens p.info declName; + updateSyntaxNodeKinds p.info; + let addTokens (tks : List TokenConfig) : IO Unit := + let tks := tks.map $ fun tk => mkNameSimple tk.val; + tablesRef.set $ tks.eraseDups.foldl (fun (tables : ParsingTables) tk => { leadingTable := tables.leadingTable.insert tk p, .. tables }) tables; + match p.info.firstTokens with + | FirstTokens.tokens tks => addTokens tks + | FirstTokens.optTokens tks => addTokens tks + | _ => throw (IO.userError ("invalid builtin parser '" ++ toString declName ++ "', initial token is not statically known")) + +def addBuiltinTrailingParser (tablesRef : IO.Ref ParsingTables) (declName : Name) (p : TrailingParser) : IO Unit := +do tables ← tablesRef.get; + tablesRef.reset; + updateTokens p.info declName; + updateSyntaxNodeKinds p.info; + let addTokens (tks : List TokenConfig) : IO Unit := + let tks := tks.map $ fun tk => mkNameSimple tk.val; + tablesRef.set $ tks.eraseDups.foldl (fun (tables : ParsingTables) tk => { trailingTable := tables.trailingTable.insert tk p, .. tables }) tables; + match p.info.firstTokens with + | FirstTokens.tokens tks => addTokens tks + | FirstTokens.optTokens tks => addTokens tks + | _ => tablesRef.set { trailingParsers := p :: tables.trailingParsers, .. tables } + +def declareBuiltinParser (env : Environment) (addFnName : Name) (refDeclName : Name) (declName : Name) : IO Environment := +let name := `_regBuiltinParser ++ declName; +let type := mkApp (mkConst `IO) (mkConst `Unit); +let val := mkCAppN addFnName #[mkConst refDeclName, toExpr declName, mkConst declName]; +let decl := Declaration.defnDecl { name := name, lparams := [], type := type, value := val, hints := ReducibilityHints.opaque, isUnsafe := false }; +match env.addAndCompile {} decl with +-- TODO: pretty print error +| Except.error _ => throw (IO.userError ("failed to emit registration code for builtin parser '" ++ toString declName ++ "'")) +| Except.ok env => IO.ofExcept (setInitAttr env name) + +def declareLeadingBuiltinParser (env : Environment) (refDeclName : Name) (declName : Name) : IO Environment := +declareBuiltinParser env `Lean.Parser.addBuiltinLeadingParser refDeclName declName + +def declareTrailingBuiltinParser (env : Environment) (refDeclName : Name) (declName : Name) : IO Environment := +declareBuiltinParser env `Lean.Parser.addBuiltinTrailingParser refDeclName declName + +/- +The parsing tables for builtin parsers are "stored" in the extracted source code. +-/ +def registerBuiltinParserAttribute (attrName : Name) (refDeclName : Name) : IO Unit := +registerAttribute { + name := attrName, + descr := "Builtin parser", + add := fun env declName args persistent => do { + unless args.isMissing $ throw (IO.userError ("invalid attribute '" ++ toString attrName ++ "', unexpected argument")); + unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString attrName ++ "', must be persistent")); + match env.find declName with + | none => throw "unknown declaration" + | some decl => + match decl.type with + | Expr.const `Lean.Parser.TrailingParser _ _ => + declareTrailingBuiltinParser env refDeclName declName + | Expr.app (Expr.const `Lean.Parser.Parser _ _) (Expr.const `Lean.Parser.ParserKind.leading _ _) _ => + declareLeadingBuiltinParser env refDeclName declName + | _ => + throw (IO.userError ("unexpected parser type at '" ++ toString declName ++ "' (`Parser` or `TrailingParser` expected")) + }, + applicationTime := AttributeApplicationTime.afterCompilation +} + +@[noinline] unsafe def runBuiltinParserUnsafe (kind : String) (ref : IO.Ref ParsingTables) : ParserFn leading := +fun a c s => +match unsafeIO (do tables ← ref.get; pure $ prattParser kind tables a c s) with +| Except.ok s => s +| _ => s.mkError "failed to access builtin reference" + +@[implementedBy runBuiltinParserUnsafe] +constant runBuiltinParser (kind : String) (ref : IO.Ref ParsingTables) : ParserFn leading := arbitrary _ + +inductive ParserAttributeEntry +| leading (n : Name) +| trailing (n : Name) + +structure ParserAttribute := +(attr : AttributeImpl) +(ext : PersistentEnvExtension ParserAttributeEntry ParsingTables) +(kind : String) + +instance ParserAttribute.inhabited : Inhabited ParserAttribute := ⟨{ attr := arbitrary _, ext := arbitrary _, kind := "" }⟩ + +/- +This is just the basic skeleton where we create an +extensible/scoped parser attribute that is optionally initialized with +a builtin parser attribute. + +The current implementation just uses the bultin parser. +We still need to: +- Add a ParserDescr type, and write an interpreter for it. +- Add support for scoped parser extensions. +-/ +def registerParserAttribute (attrName : Name) (kind : String) (descr : String) (builtinTable : Option (IO.Ref ParsingTables) := none) : IO ParserAttribute := +do ext : PersistentEnvExtension ParserAttributeEntry ParsingTables ← registerPersistentEnvExtension { + name := attrName, + addImportedFn := fun es => do + table ← match builtinTable with + | some table => table.get + | none => pure {}; + -- TODO: populate table with `es` + pure table, + addEntryFn := fun (s : ParsingTables) _ => s, -- TODO + exportEntriesFn := fun _ => #[], -- TODO + statsFn := fun _ => fmt "parser attribute" -- TODO + }; + let attrImpl : AttributeImpl := { + name := attrName, + descr := descr, + add := fun env decl args persistent => pure env -- TODO + }; + pure { ext := ext, attr := attrImpl, kind := kind } + +namespace ParserAttribute + +def runParser (attr : ParserAttribute) : ParserFn leading := +fun a c s => + let tables : ParsingTables := attr.ext.getState c.env; + prattParser attr.kind tables a c s + +end ParserAttribute + +end Parser + +namespace Syntax + +def isNone {α} (stx : Syntax α) : Bool := +stx.ifNode (fun n => n.getKind == nullKind && n.getNumArgs == 0) (fun n => false) + +def getOptional {α} (s : Syntax α) : Option (Syntax α) := +s.ifNode + (fun n => if n.getKind == nullKind && n.getNumArgs == 1 then some (n.getArg 0) else none) + (fun _ => none) + +def getOptionalIdent {α} (stx : Syntax α) : Option Name := +match stx.getOptional with +| some stx => some stx.getId +| none => none + +section +variables {α β : Type} {m : Type → Type} [Monad m] + +@[specialize] partial def mfoldArgsAux (delta : Nat) (s : Array (Syntax α)) (f : Syntax α → β → m β) : Nat → β → m β +| i, b => + if h : i < s.size then do + let curr := s.get ⟨i, h⟩; + b ← f curr b; + mfoldArgsAux (i+delta) b + else + pure b + +@[inline] def mfoldArgs (s : Syntax α) (f : Syntax α → β → m β) (b : β) : m β := +mfoldArgsAux 1 s.getArgs f 0 b + +@[inline] def foldArgs (s : Syntax α) (f : Syntax α → β → β) (b : β) : β := +Id.run (s.mfoldArgs f b) + +@[inline] def mforArgs (s : Syntax α) (f : Syntax α → m Unit) : m Unit := +s.mfoldArgs (fun s _ => f s) () + +@[inline] def mfoldSepArgs (s : Syntax α) (f : Syntax α → β → m β) (b : β) : m β := +mfoldArgsAux 2 s.getArgs f 0 b + +@[inline] def foldSepArgs (s : Syntax α) (f : Syntax α → β → β) (b : β) : β := +Id.run (s.mfoldSepArgs f b) + +@[inline] def mforSepArgs (s : Syntax α) (f : Syntax α → m Unit) : m Unit := +s.mfoldSepArgs (fun s _ => f s) () + +end + +end Syntax +end Lean diff --git a/stage0/src/Init/Lean/Parser/Term.lean b/stage0/src/Init/Lean/Parser/Term.lean new file mode 100644 index 0000000000..2e47f465b5 --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Term.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Lean.Parser.Parser +import Init.Lean.Parser.Level + +namespace Lean +namespace Parser + +@[init mkBuiltinParsingTablesRef] +constant builtinTermParsingTable : IO.Ref ParsingTables := arbitrary _ + +@[init] def regBuiltinTermParserAttr : IO Unit := +registerBuiltinParserAttribute `builtinTermParser `Lean.Parser.builtinTermParsingTable + +def mkTermParserAttribute : IO ParserAttribute := +registerParserAttribute `termParser "term" "term parser" (some builtinTermParsingTable) + +@[init mkTermParserAttribute] +constant termParserAttribute : ParserAttribute := arbitrary _ + +@[inline] def termParser {k : ParserKind} (rbp : Nat := 0) : Parser k := +{ fn := fun _ => termParserAttribute.runParser rbp } + +namespace Term +/- Helper functions for defining simple parsers -/ + +def unicodeInfixR (sym : String) (asciiSym : String) (lbp : Nat) : TrailingParser := +pushLeading >> unicodeSymbol sym asciiSym lbp >> termParser (lbp - 1) + +def infixR (sym : String) (lbp : Nat) : TrailingParser := +pushLeading >> symbol sym lbp >> termParser (lbp - 1) + +def unicodeInfixL (sym : String) (asciiSym : String) (lbp : Nat) : TrailingParser := +pushLeading >> unicodeSymbol sym asciiSym lbp >> termParser lbp + +def infixL (sym : String) (lbp : Nat) : TrailingParser := +pushLeading >> symbol sym lbp >> termParser lbp + +/- Builting parsers -/ +def explicitUniv := parser! ".{" >> sepBy1 levelParser ", " >> "}" +def namedPattern := parser! checkNoWsBefore "no space before '@'" >> "@" >> termParser appPrec +@[builtinTermParser] def id := parser! ident >> optional (explicitUniv <|> namedPattern) +@[builtinTermParser] def num : Parser := numLit +@[builtinTermParser] def str : Parser := strLit +@[builtinTermParser] def char : Parser := charLit +@[builtinTermParser] def type := parser! symbol "Type" appPrec +@[builtinTermParser] def sort := parser! symbol "Sort" appPrec +@[builtinTermParser] def prop := parser! symbol "Prop" appPrec +@[builtinTermParser] def hole := parser! symbol "_" appPrec +@[builtinTermParser] def «sorry» := parser! symbol "sorry" appPrec +@[builtinTermParser] def cdot := parser! symbol "·" appPrec +@[builtinTermParser] def emptyC := parser! symbol "∅" appPrec +def typeAscription := parser! " : " >> termParser +def tupleTail := parser! ", " >> sepBy1 termParser ", " +def parenSpecial : Parser := optional (tupleTail <|> typeAscription) +@[builtinTermParser] def paren := parser! symbol "(" appPrec >> optional (termParser >> parenSpecial) >> ")" +@[builtinTermParser] def anonymousCtor := parser! symbol "⟨" appPrec >> sepBy termParser ", " >> "⟩" +def optIdent : Parser := optional (try (ident >> " : ")) +@[builtinTermParser] def «if» := parser! "if " >> optIdent >> termParser >> " then " >> termParser >> " else " >> termParser +def fromTerm := parser! " from " >> termParser +def haveAssign := parser! " := " >> termParser +@[builtinTermParser] def «have» := parser! "have " >> optIdent >> termParser >> (haveAssign <|> fromTerm) >> "; " >> termParser +@[builtinTermParser] def «suffices» := parser! "suffices " >> optIdent >> termParser >> fromTerm >> "; " >> termParser +@[builtinTermParser] def «show» := parser! "show " >> termParser >> fromTerm +@[builtinTermParser] def «fun» := parser! unicodeSymbol "λ" "fun" >> many1 (termParser appPrec) >> unicodeSymbol "⇒" "=>" >> termParser +def structInstField := parser! ident >> " := " >> termParser +def structInstSource := parser! ".." >> optional termParser +@[builtinTermParser] def structInst := parser! symbol "{" appPrec >> optional (try (ident >> " . ")) >> sepBy (structInstField <|> structInstSource) ", " true >> "}" +def typeSpec := parser! " : " >> termParser +def optType : Parser := optional typeSpec +@[builtinTermParser] def subtype := parser! "{" >> ident >> optType >> " // " >> termParser >> "}" +@[builtinTermParser] def listLit := parser! symbol "[" appPrec >> sepBy termParser "," true >> "]" +@[builtinTermParser] def arrayLit := parser! symbol "#[" appPrec >> sepBy termParser "," true >> "]" +@[builtinTermParser] def explicit := parser! symbol "@" appPrec >> id +@[builtinTermParser] def inaccessible := parser! symbol ".(" appPrec >> termParser >> ")" +def binderIdent : Parser := ident <|> hole +def binderType (requireType := false) : Parser := if requireType then " : " >> termParser else optional (" : " >> termParser) +def binderDefault := parser! " := " >> termParser +def binderTactic := parser! " . " >> termParser +def explicitBinder (requireType := false) := parser! "(" >> many1 binderIdent >> binderType requireType >> optional (binderDefault <|> binderTactic) >> ")" +def implicitBinder (requireType := false) := parser! "{" >> many1 binderIdent >> binderType requireType >> "}" +def instBinder := parser! "[" >> optIdent >> termParser >> "]" +def bracktedBinder (requireType := false) := explicitBinder requireType <|> implicitBinder requireType <|> instBinder +@[builtinTermParser] def depArrow := parser! bracktedBinder true >> unicodeSymbolCheckPrec " → " " -> " 25 >> termParser +def simpleBinder := parser! many1 binderIdent +@[builtinTermParser] def «forall» := parser! unicodeSymbol "∀" "forall" >> many1 (simpleBinder <|> bracktedBinder) >> ", " >> termParser +def matchAlt := parser! " | " >> sepBy1 termParser ", " >> unicodeSymbol "⇒" "=>" >> termParser +@[builtinTermParser] def «match» := parser! "match " >> sepBy1 termParser ", " >> optType >> " with " >> many1Indent matchAlt "'match' alternatives must be indented" +@[builtinTermParser] def «nomatch» := parser! "nomatch " >> termParser +@[builtinTermParser] def «parser!» := parser! "parser! " >> termParser +@[builtinTermParser] def «tparser!» := parser! "tparser! " >> termParser +@[builtinTermParser] def borrowed := parser! symbol "@&" appPrec >> termParser (appPrec - 1) +@[builtinTermParser] def quotedName := parser! symbol "`" appPrec >> rawIdent + +/- Remark: we use `checkWsBefore` to ensure `let x[i] := e; b` is not parsed as `let x [i] := e; b` where `[i]` is an `instBinder`. -/ +def letIdLhs : Parser := ident >> checkWsBefore "expected space before binders" >> many bracktedBinder >> optType +def letIdDecl := parser! try (letIdLhs >> " := ") >> termParser +def equation := matchAlt +def letEqns := parser! try (letIdLhs >> lookahead " | ") >> many1Indent equation "equations must be indented" +def letPatDecl := parser! termParser >> optType >> " := " >> termParser +def letDecl := try letIdDecl <|> letEqns <|> letPatDecl +@[builtinTermParser] def «let» := parser! "let " >> letDecl >> "; " >> termParser +def leftArrow : Parser := unicodeSymbol " ← " " <- " +def doLet := parser! "let " >> letDecl +def doId := parser! try (ident >> optType >> leftArrow) >> termParser +def doPat := parser! try (termParser >> leftArrow) >> termParser >> optional (" | " >> termParser) +def doExpr := parser! termParser +def doElem := doLet <|> doId <|> doPat <|> doExpr +def doSeq := parser! sepBy1 doElem "; " +def bracketedDoSeq := parser! "{" >> doSeq >> "}" +@[builtinTermParser] def «do» := parser! "do " >> (bracketedDoSeq <|> doSeq) + +@[builtinTermParser] def not := parser! symbol "¬" 40 >> termParser 40 +@[builtinTermParser] def bnot := parser! symbol "!" 40 >> termParser 40 +@[builtinTermParser] def uminus := parser! "-" >> termParser 100 + +def namedArgument := tparser! try ("(" >> ident >> " := ") >> termParser >> ")" +@[builtinTermParser] def app := tparser! pushLeading >> (namedArgument <|> termParser appPrec) +def checkIsSort := checkLeading (fun leading => leading.isOfKind `Lean.Parser.Term.type || leading.isOfKind `Lean.Parser.Term.sort) +@[builtinTermParser] def sortApp := tparser! checkIsSort >> pushLeading >> levelParser appPrec +@[builtinTermParser] def proj := tparser! pushLeading >> symbolNoWs "." (appPrec+1) >> (fieldIdx <|> ident) +@[builtinTermParser] def arrow := tparser! unicodeInfixR " → " " -> " 25 +@[builtinTermParser] def arrayRef := tparser! pushLeading >> symbolNoWs "[" (appPrec+1) >> termParser >>"]" + +@[builtinTermParser] def dollar := tparser! infixR " $ " 1 +@[builtinTermParser] def fcomp := tparser! infixR " ∘ " 90 + +@[builtinTermParser] def prod := tparser! infixR " × " 35 + +@[builtinTermParser] def add := tparser! infixL " + " 65 +@[builtinTermParser] def sub := tparser! infixL " - " 65 +@[builtinTermParser] def mul := tparser! infixL " * " 70 +@[builtinTermParser] def div := tparser! infixL " / " 70 +@[builtinTermParser] def mod := tparser! infixL " % " 70 +@[builtinTermParser] def modN := tparser! infixL " %ₙ " 70 +@[builtinTermParser] def pow := tparser! infixR " ^ " 80 + +@[builtinTermParser] def le := tparser! unicodeInfixL " ≤ " " <= " 50 +@[builtinTermParser] def ge := tparser! unicodeInfixL " ≥ " " >= " 50 +@[builtinTermParser] def lt := tparser! infixL " < " 50 +@[builtinTermParser] def gt := tparser! infixL " > " 50 +@[builtinTermParser] def eq := tparser! infixL " = " 50 +@[builtinTermParser] def ne := tparser! infixL " ≠ " 50 +@[builtinTermParser] def beq := tparser! infixL " == " 50 +@[builtinTermParser] def bne := tparser! infixL " != " 50 +@[builtinTermParser] def heq := tparser! unicodeInfixL " ≅ " " ~= " 50 +@[builtinTermParser] def equiv := tparser! infixL " ≈ " 50 + +@[builtinTermParser] def subst := tparser! infixR " ▸ " 75 + +@[builtinTermParser] def and := tparser! unicodeInfixR " ∧ " " /\\ " 35 +@[builtinTermParser] def or := tparser! unicodeInfixR " ∨ " " \\/ " 30 +@[builtinTermParser] def iff := tparser! unicodeInfixL " ↔ " " <-> " 20 + +@[builtinTermParser] def band := tparser! infixL " && " 35 +@[builtinTermParser] def bor := tparser! infixL " || " 30 + +@[builtinTermParser] def append := tparser! infixL " ++ " 65 +@[builtinTermParser] def cons := tparser! infixR " :: " 67 + +@[builtinTermParser] def orelse := tparser! infixR " <|> " 2 +@[builtinTermParser] def orM := tparser! infixR " <||> " 30 +@[builtinTermParser] def andM := tparser! infixR " <&&> " 35 +@[builtinTermParser] def andthen := tparser! infixR " >> " 60 +@[builtinTermParser] def bind := tparser! infixR " >>= " 55 +@[builtinTermParser] def mapRev := tparser! infixR " <&> " 100 +@[builtinTermParser] def seq := tparser! infixL " <*> " 60 +@[builtinTermParser] def seqLeft := tparser! infixL " <* " 60 +@[builtinTermParser] def seqRight := tparser! infixR " *> " 60 +@[builtinTermParser] def map := tparser! infixR " <$> " 100 +@[builtinTermParser] def mapConst := tparser! infixR " <$ " 100 +@[builtinTermParser] def mapConstRev := tparser! infixR " $> " 100 + +end Term + +def mkAppStx {α} (fn : Syntax α) (args : List (Syntax α)) : Syntax α := +args.foldl (fun fn arg => Syntax.node `Lean.Parser.Term.app #[fn, arg]) fn + +end Parser +end Lean diff --git a/stage0/src/Init/Lean/Parser/Transform.lean b/stage0/src/Init/Lean/Parser/Transform.lean new file mode 100644 index 0000000000..d0bf65ae25 --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Transform.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +import Init.Lean.Parser.Parser + +namespace Lean +namespace Syntax + +def manyToSepBy (stx : Syntax) (sepTk : String) : Syntax := +match stx with +| node k args => + let args := args.foldlFrom (fun (newArgs : Array Syntax) arg => + let prevArg := newArgs.back; + match prevArg.getTailInfo with + | some info => + let prevArg := prevArg.setTailInfo info.truncateTrailing; + let newArgs := newArgs.set! (newArgs.size - 1) prevArg; + let newArgs := newArgs.push (atom info sepTk); + newArgs.push arg + | none => + let newArgs := newArgs.push (atom none sepTk); + newArgs.push arg) + #[args.get! 0] + 1; + node k args +| stx => stx + +def removeParen (stx : Syntax) : Syntax := +stx.ifNodeKind `Lean.Parser.Term.paren + (fun stx => + let body := stx.getArg 1; + if body.getNumArgs != 2 then stx.val + else if (body.getArg 1).isNone then + let body := body.getArg 0; + match stx.getArg 2, body.getTailInfo with + | atom (some info) ")", some bodyInfo => + let bodyInfoTrail := bodyInfo.trailing.toString ++ " "; -- add whithespaces for removed parentheses + let bodyInfoTrail := bodyInfoTrail ++ info.trailing.toString; -- add close paren trailing spaces + body.setTailInfo (some { trailing := bodyInfoTrail.toSubstring, .. bodyInfo }) + | _, _ => stx.val + else stx.val) + (fun _ => stx) + +end Syntax +end Lean diff --git a/stage0/src/Init/Lean/Parser/Trie.lean b/stage0/src/Init/Lean/Parser/Trie.lean new file mode 100644 index 0000000000..f1e0963793 --- /dev/null +++ b/stage0/src/Init/Lean/Parser/Trie.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sebastian Ullrich, Leonardo de Moura + +Trie for tokenizing the Lean language +-/ +prelude +import Init.Data.RBMap +import Init.Lean.Format + +namespace Lean +namespace Parser + +inductive Trie (α : Type) +| Node : Option α → RBNode Char (fun _ => Trie) → Trie + +namespace Trie +variables {α : Type} + +def empty : Trie α := +⟨none, RBNode.leaf⟩ + +instance : HasEmptyc (Trie α) := +⟨empty⟩ + +instance : Inhabited (Trie α) := +⟨Node none RBNode.leaf⟩ + +private partial def insertEmptyAux (s : String) (val : α) : String.Pos → Trie α +| i => match s.atEnd i with + | true => Trie.Node (some val) RBNode.leaf + | false => + let c := s.get i; + let t := insertEmptyAux (s.next i); + Trie.Node none (RBNode.singleton c t) + +private partial def insertAux (s : String) (val : α) : Trie α → String.Pos → Trie α +| Trie.Node v m, i => + match s.atEnd i with + | true => Trie.Node (some val) m -- overrides old value + | false => + let c := s.get i; + let i := s.next i; + let t := match RBNode.find Char.lt m c with + | none => insertEmptyAux s val i + | some t => insertAux t i; + Trie.Node v (RBNode.insert Char.lt m c t) + +def insert (t : Trie α) (s : String) (val : α) : Trie α := +insertAux s val t 0 + +private partial def findAux (s : String) : Trie α → String.Pos → Option α +| Trie.Node val m, i => + match s.atEnd i with + | true => val + | false => + let c := s.get i; + let i := s.next i; + match RBNode.find Char.lt m c with + | none => none + | some t => findAux t i + +def find (t : Trie α) (s : String) : Option α := +findAux s t 0 + +private def updtAcc (v : Option α) (i : String.Pos) (acc : String.Pos × Option α) : String.Pos × Option α := +match v, acc with +| some v, (j, w) => (i, some v) -- we pattern match on `acc` to enable memory reuse +| none, acc => acc + +private partial def matchPrefixAux (s : String) : Trie α → String.Pos → (String.Pos × Option α) → String.Pos × Option α +| Trie.Node v m, i, acc => + match s.atEnd i with + | true => updtAcc v i acc + | false => + let acc := updtAcc v i acc; + let c := s.get i; + let i := s.next i; + match RBNode.find Char.lt m c with + | some t => matchPrefixAux t i acc + | none => acc + +def matchPrefix (s : String) (t : Trie α) (i : String.Pos) : String.Pos × Option α := +matchPrefixAux s t i (i, none) + +private partial def toStringAux {α : Type} : Trie α → List Format +| Trie.Node val map => map.fold (fun Fs c t => + format (repr c) :: (Format.group $ Format.nest 2 $ flip Format.joinSep Format.line $ toStringAux t) :: Fs) [] + +instance {α : Type} : HasToString (Trie α) := +⟨fun t => (flip Format.joinSep Format.line $ toStringAux t).pretty⟩ +end Trie + +end Parser +end Lean diff --git a/stage0/src/Init/Lean/Path.lean b/stage0/src/Init/Lean/Path.lean new file mode 100644 index 0000000000..dee7bbce67 --- /dev/null +++ b/stage0/src/Init/Lean/Path.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich + +Management of the Lean search path (`LEAN_PATH`), which is a list of +`pkg=path` mappings from package name to root path. An import `A.B.C` +given an `A=path` entry resolves to `path/B/C.olean`. A package-only +import `A` is normalized to `A.Default`. For the input file, we also +need the reverse direction of finding a (unique) module path from a +file path. +-/ +prelude +import Init.System.IO +import Init.System.FilePath +import Init.Data.Array +import Init.Data.List.Control +import Init.Lean.Name +import Init.Data.HashMap +import Init.Data.Nat.Control + +namespace Lean +open System.FilePath (pathSeparator extSeparator) +private def pathSep : String := toString pathSeparator + +def realPathNormalized (fname : String) : IO String := +do fname ← IO.realPath fname; + pure (System.FilePath.normalizePath fname) + +abbrev SearchPath := HashMap String String + +def mkSearchPathRef : IO (IO.Ref SearchPath) := +IO.mkRef ∅ + +@[init mkSearchPathRef] +constant searchPathRef : IO.Ref SearchPath := arbitrary _ + +def parseSearchPath (path : String) (sp : SearchPath := ∅) : IO SearchPath := do + let ps := System.FilePath.splitSearchPath path; + sp ← ps.foldlM (fun (sp : SearchPath) s => match s.splitOn "=" with + | [pkg, path] => pure $ sp.insert pkg path + | _ => throw $ IO.userError $ "ill-formed search path entry '" ++ s ++ "', should be of form 'pkg=path'") + sp; + pure sp + +def getBuiltinSearchPath : IO SearchPath := +do appDir ← IO.appDir; + let libDir := appDir ++ pathSep ++ ".." ++ pathSep ++ "library" ++ pathSep ++ "Init"; + libDirExists ← IO.isDir libDir; + if libDirExists then do + path ← realPathNormalized libDir; + pure $ HashMap.empty.insert "Init" path + else do + let installedLibDir := appDir ++ pathSep ++ ".." ++ pathSep ++ "lib" ++ pathSep ++ "lean" ++ pathSep ++ "library" ++ pathSep ++ "Init"; + installedLibDirExists ← IO.isDir installedLibDir; + if installedLibDirExists then do + path ← realPathNormalized installedLibDir; + pure $ HashMap.empty.insert "Init" path + else + pure ∅ + +def addSearchPathFromEnv (sp : SearchPath) : IO SearchPath := +do val ← IO.getEnv "LEAN_PATH"; + match val with + | none => pure sp + | some val => parseSearchPath val sp + +@[export lean_init_search_path] +def initSearchPath (path : Option String := "") : IO Unit := +match path with +| some path => parseSearchPath path >>= searchPathRef.set +| none => do + sp ← getBuiltinSearchPath; + sp ← addSearchPathFromEnv sp; + searchPathRef.set sp + +def modPathToFilePath : Name → String +| Name.str Name.anonymous h _ => h +| Name.str p h _ => modPathToFilePath p ++ pathSep ++ h +| Name.anonymous => "" +| Name.num p _ _ => panic! "ill-formed import" + +/- Given `A.B.C, return ("A", `B.C). -/ +def splitAtRoot : Name → String × Name +| Name.str Name.anonymous s _ => (s, Name.anonymous) +| Name.str n s _ => + let (pkg, path) := splitAtRoot n; + (pkg, mkNameStr path s) +| _ => panic! "ill-formed import" + +def findOLean (mod : Name) : IO String := +do sp ← searchPathRef.get; + let (pkg, path) := splitAtRoot mod; + some root ← pure $ sp.find pkg + | throw $ IO.userError $ "unknown package '" ++ pkg ++ "'"; + let fname := root ++ pathSep ++ modPathToFilePath path ++ ".olean"; + pure fname + +def findAtSearchPath (fname : String) : IO (Option (String × String)) := +do fname ← realPathNormalized fname; + sp ← searchPathRef.get; + results ← sp.foldM (fun results pkg path => do + path ← realPathNormalized path; + pure $ if String.isPrefixOf path fname then (pkg, path) :: results else results) []; + match results with + | [res] => pure res + | [] => pure none + | _ => throw (IO.userError ("file '" ++ fname ++ "' is contained in multiple packages: " ++ ", ".intercalate (results.map Prod.fst))) + +@[export lean_module_name_of_file] +def moduleNameOfFileName (fname : String) : IO (Option Name) := +do some (pkg, path) ← findAtSearchPath fname + | pure none; + fname ← realPathNormalized fname; + let fnameSuffix := fname.drop path.length; + let fnameSuffix := if fnameSuffix.get 0 == pathSeparator then fnameSuffix.drop 1 else fnameSuffix; + some extPos ← pure (fnameSuffix.revPosOf '.') + | throw (IO.userError ("failed to convert file '" ++ fname ++ "' to module name, extension is missing")); + let modNameStr := fnameSuffix.extract 0 extPos; + let extStr := fnameSuffix.extract (extPos + 1) fnameSuffix.bsize; + let parts := modNameStr.splitOn pathSep; + let modName := parts.foldl mkNameStr pkg; + pure modName + +-- normalize `A` to `A.Default` +@[export lean_normalize_module_name] +def normalizeModuleName : Name → Name +| Name.str Name.anonymous pkg _ => mkNameSimple pkg ++ "Default" +| m => m + +end Lean diff --git a/stage0/src/Init/Lean/Position.lean b/stage0/src/Init/Lean/Position.lean new file mode 100644 index 0000000000..e6f164e052 --- /dev/null +++ b/stage0/src/Init/Lean/Position.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Data.Nat +import Init.Data.RBMap +import Init.Lean.Format + +namespace Lean + +structure Position := +(line : Nat) +(column : Nat) + +namespace Position +instance : DecidableEq Position := +{decEq := fun ⟨l₁, c₁⟩ ⟨l₂, c₂⟩ => + if h₁ : l₁ = l₂ then + if h₂ : c₁ = c₂ then isTrue (Eq.recOn h₁ (Eq.recOn h₂ rfl)) + else isFalse (fun contra => Position.noConfusion contra (fun e₁ e₂ => absurd e₂ h₂)) + else isFalse (fun contra => Position.noConfusion contra (fun e₁ e₂ => absurd e₁ h₁))} + +protected def lt : Position → Position → Bool +| ⟨l₁, c₁⟩, ⟨l₂, c₂⟩ => (l₁, c₁) < (l₂, c₂) + +instance : HasFormat Position := +⟨fun ⟨l, c⟩ => "⟨" ++ fmt l ++ ", " ++ fmt c ++ "⟩"⟩ + +instance : HasToString Position := +⟨fun ⟨l, c⟩ => "⟨" ++ toString l ++ ", " ++ toString c ++ "⟩"⟩ + +instance : Inhabited Position := ⟨⟨1, 0⟩⟩ +end Position + +structure FileMap := +(source : String) +(positions : Array String.Pos) +(lines : Array Nat) + +namespace FileMap + +instance : Inhabited FileMap := +⟨{ source := "", positions := #[], lines := #[] }⟩ + +private partial def ofStringAux (s : String) : String.Pos → Nat → Array String.Pos → Array Nat → FileMap +| i, line, ps, lines => + if s.atEnd i then { source := s, positions := ps.push i, lines := lines.push line } + else + let c := s.get i; + let i := s.next i; + if c == '\n' then ofStringAux i (line+1) (ps.push i) (lines.push (line+1)) + else ofStringAux i line ps lines + +def ofString (s : String) : FileMap := +ofStringAux s 0 1 (#[0]) (#[1]) + +private partial def toColumnAux (str : String) (lineBeginPos : String.Pos) (pos : String.Pos) : String.Pos → Nat → Nat +| i, c => + if i == pos || str.atEnd i then c + else toColumnAux (str.next i) (c+1) + +/- Remark: `pos` is in `[ps.get b, ps.get e]` and `b < e` -/ +private partial def toPositionAux (str : String) (ps : Array Nat) (lines : Array Nat) (pos : String.Pos) : Nat → Nat → Position +| b, e => + let posB := ps.get! b; + if e == b + 1 then { line := lines.get! b, column := toColumnAux str posB pos posB 0 } + else + let m := (b + e) / 2; + let posM := ps.get! m; + if pos == posM then { line := lines.get! m, column := 0 } + else if pos > posM then toPositionAux m e + else toPositionAux b m + +def toPosition : FileMap → String.Pos → Position +| { source := str, positions := ps, lines := lines }, pos => toPositionAux str ps lines pos 0 (ps.size-1) + +end FileMap +end Lean + +def String.toFileMap (s : String) : Lean.FileMap := +Lean.FileMap.ofString s diff --git a/stage0/src/Init/Lean/ProjFns.lean b/stage0/src/Init/Lean/ProjFns.lean new file mode 100644 index 0000000000..b55ba1e1f9 --- /dev/null +++ b/stage0/src/Init/Lean/ProjFns.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment + +namespace Lean + +/- Given a structure `S`, Lean automatically creates an auxiliary definition (projection function) + for each field. This structure caches information about these auxiliary definitions. -/ +structure ProjectionFunctionInfo := +(ctorName : Name) -- Constructor associated with the auxiliary projection function. +(nparams : Nat) -- Number of parameters in the structure +(i : Nat) -- The field index associated with the auxiliary projection function. +(fromClass : Bool) -- `true` if the structure is a class + +instance ProjectionFunctionInfo.inhabited : Inhabited ProjectionFunctionInfo := +⟨{ ctorName := arbitrary _, nparams := arbitrary _, i := 0, fromClass := false }⟩ + +def mkProjectionFnInfoExtension : IO (SimplePersistentEnvExtension (Name × ProjectionFunctionInfo) (NameMap ProjectionFunctionInfo)) := +registerSimplePersistentEnvExtension { + name := `projinfo, + addImportedFn := fun as => {}, + addEntryFn := fun s p => s.insert p.1 p.2, + toArrayFn := fun es => es.toArray.qsort (fun a b => Name.quickLt a.1 b.1) +} + +@[init mkProjectionFnInfoExtension] +constant projectionFnInfoExt : SimplePersistentEnvExtension (Name × ProjectionFunctionInfo) (NameMap ProjectionFunctionInfo) := arbitrary _ + +@[export lean_add_projection_info] +def addProjectionFnInfo (env : Environment) (projName : Name) (ctorName : Name) (nparams : Nat) (i : Nat) (fromClass : Bool) : Environment := +projectionFnInfoExt.addEntry env (projName, { ctorName := ctorName, nparams := nparams, i := i, fromClass := fromClass }) + +namespace Environment + +@[export lean_get_projection_info] +def getProjectionFnInfo (env : Environment) (projName : Name) : Option ProjectionFunctionInfo := +match env.getModuleIdxFor projName with +| some modIdx => + match (projectionFnInfoExt.getModuleEntries env modIdx).binSearch (projName, arbitrary _) (fun a b => Name.quickLt a.1 b.1) with + | some e => some e.2 + | none => none +| none => (projectionFnInfoExt.getState env).find projName + +def isProjectionFn (env : Environment) (n : Name) : Bool := +match env.getModuleIdxFor n with +| some modIdx => (projectionFnInfoExt.getModuleEntries env modIdx).binSearchContains (n, arbitrary _) (fun a b => Name.quickLt a.1 b.1) +| none => (projectionFnInfoExt.getState env).contains n + +end Environment +end Lean diff --git a/stage0/src/Init/Lean/ReducibilityAttrs.lean b/stage0/src/Init/Lean/ReducibilityAttrs.lean new file mode 100644 index 0000000000..8c31216802 --- /dev/null +++ b/stage0/src/Init/Lean/ReducibilityAttrs.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Attributes + +namespace Lean + +inductive ReducibilityStatus +| reducible | semireducible | irreducible + +instance ReducibilityStatus.inhabited : Inhabited ReducibilityStatus := ⟨ReducibilityStatus.semireducible⟩ + +def mkReducibilityAttrs : IO (EnumAttributes ReducibilityStatus) := +registerEnumAttributes `reducibility + [(`reducible, "reducible", ReducibilityStatus.reducible), + (`semireducible, "semireducible", ReducibilityStatus.semireducible), + (`irreducible, "irreducible", ReducibilityStatus.irreducible)] + +@[init mkReducibilityAttrs] +constant reducibilityAttrs : EnumAttributes ReducibilityStatus := arbitrary _ + +@[export lean_get_reducibility_status] +def getReducibilityStatus (env : Environment) (n : Name) : ReducibilityStatus := +match reducibilityAttrs.getValue env n with +| some s => s +| none => ReducibilityStatus.semireducible + +@[export lean_set_reducibility_status] +def setReducibilityStatus (env : Environment) (n : Name) (s : ReducibilityStatus) : Environment := +match reducibilityAttrs.setValue env n s with +| Except.ok env => env +| _ => env -- TODO(Leo): we should extend EnumAttributes.setValue in the future and ensure it never fails + +def isReducible (env : Environment) (n : Name) : Bool := +match getReducibilityStatus env n with +| ReducibilityStatus.reducible => true +| _ => false + +end Lean diff --git a/stage0/src/Init/Lean/Runtime.lean b/stage0/src/Init/Lean/Runtime.lean new file mode 100644 index 0000000000..27714be9a7 --- /dev/null +++ b/stage0/src/Init/Lean/Runtime.lean @@ -0,0 +1,23 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Core + +namespace Lean + +@[extern "lean_closure_max_args"] +constant closureMaxArgsFn : Unit → Nat := arbitrary _ + +@[extern "lean_max_small_nat"] +constant maxSmallNatFn : Unit → Nat := arbitrary _ + +def closureMaxArgs : Nat := +closureMaxArgsFn () + +def maxSmallNat : Nat := +maxSmallNatFn () + +end Lean diff --git a/stage0/src/Init/Lean/SMap.lean b/stage0/src/Init/Lean/SMap.lean new file mode 100644 index 0000000000..4037777561 --- /dev/null +++ b/stage0/src/Init/Lean/SMap.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.HashMap +import Init.Data.PersistentHashMap +universes u v w w' + +namespace Lean + +/- Staged map for implementing the Environment. The idea is to store + imported entries into a hashtable and local entries into a persistent hashtable. + + Hypotheses: + - The number of entries (i.e., declarations) coming from imported files is much bigger than + the number of entries in the current file. + - HashMap is faster than PersistentHashMap. + - When we are reading imported files, we have exclusive access to the map, and efficient + destructive updates are performed. + + Remarks: + - We never remove declarations from the Environment. In principle, we could support + deletion by using `(PHashMap α (Option β))` where the value `none` would indicate + that an entry was "removed" from the hashtable. + - We do not need additional bookkeeping for extracting the local entries. +-/ +structure SMap (α : Type u) (β : Type v) [HasBeq α] [Hashable α] := +(stage₁ : Bool := true) +(map₁ : HashMap α β := {}) +(map₂ : PHashMap α β := {}) + +namespace SMap +variables {α : Type u} {β : Type v} [HasBeq α] [Hashable α] + +instance : Inhabited (SMap α β) := ⟨{}⟩ + +def empty : SMap α β := {} +instance : HasEmptyc (SMap α β) := ⟨SMap.empty⟩ + +@[specialize] def insert : SMap α β → α → β → SMap α β +| ⟨true, m₁, m₂⟩, k, v => ⟨true, m₁.insert k v, m₂⟩ +| ⟨false, m₁, m₂⟩, k, v => ⟨false, m₁, m₂.insert k v⟩ + +@[specialize] def find : SMap α β → α → Option β +| ⟨true, m₁, _⟩, k => m₁.find k +| ⟨false, m₁, m₂⟩, k => (m₂.find k).orelse (m₁.find k) + +@[inline] def findD (m : SMap α β) (a : α) (b₀ : β) : β := +(m.find a).getD b₀ + +@[inline] def find! [Inhabited β] (m : SMap α β) (a : α) : β := +match m.find a with +| some b => b +| none => panic! "key is not in the map" + +@[specialize] def contains : SMap α β → α → Bool +| ⟨true, m₁, _⟩, k => m₁.contains k +| ⟨false, m₁, m₂⟩, k => m₁.contains k || m₂.contains k + +/- Similar to `find`, but searches for result in the hashmap first. + So, the result is correct only if we never "overwrite" `map₁` entries using `map₂`. -/ +@[specialize] def find' : SMap α β → α → Option β +| ⟨true, m₁, _⟩, k => m₁.find k +| ⟨false, m₁, m₂⟩, k => (m₁.find k).orelse (m₂.find k) + +/- Move from stage 1 into stage 2. -/ +def switch (m : SMap α β) : SMap α β := +if m.stage₁ then { stage₁ := false, .. m } else m + +@[inline] def foldStage2 {σ : Type w} (f : σ → α → β → σ) (s : σ) (m : SMap α β) : σ := +m.map₂.foldl f s + +def size (m : SMap α β) : Nat := +m.map₁.size + m.map₂.size + +def stageSizes (m : SMap α β) : Nat × Nat := +(m.map₁.size, m.map₂.size) + +def numBuckets (m : SMap α β) : Nat := +m.map₁.numBuckets + +end SMap +end Lean diff --git a/stage0/src/Init/Lean/Scopes.lean b/stage0/src/Init/Lean/Scopes.lean new file mode 100644 index 0000000000..ca2cda91a4 --- /dev/null +++ b/stage0/src/Init/Lean/Scopes.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Environment + +namespace Lean + +/- Scope management + +TODO: delete after we delete parser implemented in C++. +We have decided to store scope information at ElabState +-/ + +structure ScopeManagerState := +(allNamespaces : NameSet := {}) +/- Stack of namespaces for each each open namespace and section -/ +(namespaces : List Name := []) +/- Stack of namespace/section headers -/ +(headers : List Name := []) +(isNamespace : List Bool := []) + +namespace ScopeManagerState + +instance : Inhabited ScopeManagerState := ⟨{}⟩ + +def saveNamespace (s : ScopeManagerState) (n : Name) : ScopeManagerState := +{ allNamespaces := s.allNamespaces.insert n, .. s } + +end ScopeManagerState + +def regScopeManagerExtension : IO (SimplePersistentEnvExtension Name ScopeManagerState) := +registerSimplePersistentEnvExtension { + name := `scopes, + addImportedFn := fun as => mkStateFromImportedEntries ScopeManagerState.saveNamespace {} as, + addEntryFn := fun s n => { allNamespaces := s.allNamespaces.insert n, .. s }, +} + +@[init regScopeManagerExtension] +constant scopeManagerExt : SimplePersistentEnvExtension Name ScopeManagerState := arbitrary _ + +namespace Environment + +@[export lean_get_namespaces] +def getNamespaces (env : Environment) : List Name := +(scopeManagerExt.getState env).namespaces + +def getNamespaceSet (env : Environment) : NameSet := +(scopeManagerExt.getState env).allNamespaces + +@[export lean_is_namespace] +def isNamespace (env : Environment) (n : Name) : Bool := +env.getNamespaceSet.contains n + +@[export lean_in_section] +def inSection (env : Environment) : Bool := +match (scopeManagerExt.getState env).isNamespace with +| (b::_) => !b +| _ => false + +@[export lean_has_open_scopes] +def hasOpenScopes (env : Environment) : Bool := +!env.getNamespaces.isEmpty + +@[export lean_get_namespace] +def getNamespace (env : Environment) : Name := +match env.getNamespaces with +| (n::_) => n +| _ => Name.anonymous + +@[export lean_get_scope_header] +def getScopeHeader (env : Environment) : Name := +match (scopeManagerExt.getState env).headers with +| (n::_) => n +| _ => Name.anonymous + +@[export lean_to_valid_namespace] +def toValidNamespace (env : Environment) (n : Name) : Option Name := +let s := scopeManagerExt.getState env; +if s.allNamespaces.contains n then some n +else s.namespaces.foldl + (fun r ns => match r with + | some _ => r + | none => + let c := ns ++ n; + if s.allNamespaces.contains c then some c else none) + none + +def registerNamespaceAux (env : Environment) (n : Name) : Environment := +if env.getNamespaceSet.contains n then env else scopeManagerExt.addEntry env n + +@[export lean_register_namespace] +def registerNamespace : Environment → Name → Environment +| env, n@(Name.str p _ _) => registerNamespace (registerNamespaceAux env n) p +| env, _ => env + +def pushScopeCore (env : Environment) (header : Name) (isNamespace : Bool) : Environment := +let ns := env.getNamespace; +let newNs := if isNamespace then ns ++ header else ns; +let env := env.registerNamespaceAux newNs; +let env := scopeManagerExt.modifyState env $ fun s => + { headers := header :: s.headers, + namespaces := newNs :: s.namespaces, + isNamespace := isNamespace :: s.isNamespace, + .. s }; +env + +def popScopeCore (env : Environment) : Environment := +if env.getNamespaces.isEmpty then env +else scopeManagerExt.modifyState env $ fun s => + { headers := s.headers.tail!, + namespaces := s.namespaces.tail!, + isNamespace := s.isNamespace.tail!, + .. s } + +end Environment +end Lean diff --git a/stage0/src/Init/Lean/Syntax.lean b/stage0/src/Init/Lean/Syntax.lean new file mode 100644 index 0000000000..60e9d1eb35 --- /dev/null +++ b/stage0/src/Init/Lean/Syntax.lean @@ -0,0 +1,487 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sebastian Ullrich, Leonardo de Moura +-/ +prelude +import Init.Lean.Name +import Init.Lean.Format +import Init.Data.Array + +namespace Lean +structure SourceInfo := +/- Will be inferred after parsing by `Syntax.updateLeading`. During parsing, + it is not at all clear what the preceding token was, especially with backtracking. -/ +(leading : Substring) +(pos : String.Pos) +(trailing : Substring) + +namespace SourceInfo + +def updateTrailing (info : SourceInfo) (trailing : Substring) : SourceInfo := +{ trailing := trailing, .. info } + +def truncateTrailing (info : SourceInfo) : SourceInfo := +{ trailing := { stopPos := info.trailing.startPos, .. info.trailing }, .. info } + +/- Update `info₁.trailing.stopPos` to `info₂.trailing.stopPos` -/ +def appendToTrailing (info₁ info₂ : SourceInfo) : SourceInfo := +{ trailing := { stopPos := info₂.trailing.stopPos, .. info₁.trailing }, .. info₁ } + +/- Update `info₁.leading.startPos` to `info₂.leading.startPos` -/ +def appendToLeading (info₁ info₂ : SourceInfo) : SourceInfo := +{ leading := { startPos := info₂.leading.startPos, .. info₁.leading }, .. info₁ } + +end SourceInfo + +/- Node kind generation -/ + +abbrev SyntaxNodeKind := Name + +@[matchPattern] def choiceKind : SyntaxNodeKind := `choice +@[matchPattern] def nullKind : SyntaxNodeKind := `null +def strLitKind : SyntaxNodeKind := `strLit +def charLitKind : SyntaxNodeKind := `charLit +def numLitKind : SyntaxNodeKind := `numLit +def fieldIdxKind : SyntaxNodeKind := `fieldIdx + +/- Syntax AST -/ + +inductive Syntax (α : Type := Empty) +| missing {} : Syntax +| node (kind : SyntaxNodeKind) (args : Array Syntax) : Syntax +| atom {} (info : Option SourceInfo) (val : String) : Syntax +| ident {} (info : Option SourceInfo) (rawVal : Substring) (val : Name) (preresolved : List (Nat × Name)) : Syntax +| other : α → Syntax + +instance stxInh {α} : Inhabited (Syntax α) := +⟨Syntax.missing⟩ + +def Syntax.isMissing {α} : Syntax α → Bool +| Syntax.missing => true +| _ => false + +inductive IsNode {α} : Syntax α → Prop +| mk (kind : SyntaxNodeKind) (args : Array (Syntax α)) : IsNode (Syntax.node kind args) + +def SyntaxNode (α : Type := Empty) : Type := {s : Syntax α // IsNode s } + +def unreachIsNodeMissing {α β} (h : IsNode (@Syntax.missing α)) : β := False.elim (nomatch h) +def unreachIsNodeAtom {α β} {info val} (h : IsNode (@Syntax.atom α info val)) : β := False.elim (nomatch h) +def unreachIsNodeIdent {α β info rawVal val preresolved} (h : IsNode (@Syntax.ident α info rawVal val preresolved)) : β := False.elim (nomatch h) +def unreachIsNodeOther {α β} {a : α} (h : IsNode (Syntax.other a)) : β := False.elim (nomatch h) + +namespace SyntaxNode + +@[inline] def getKind {α} (n : SyntaxNode α) : SyntaxNodeKind := +match n with +| ⟨Syntax.node k args, _⟩ => k +| ⟨Syntax.missing, h⟩ => unreachIsNodeMissing h +| ⟨Syntax.atom _ _, h⟩ => unreachIsNodeAtom h +| ⟨Syntax.ident _ _ _ _, h⟩ => unreachIsNodeIdent h +| ⟨Syntax.other _ , h⟩ => unreachIsNodeOther h + +@[inline] def withArgs {α β} (n : SyntaxNode α) (fn : Array (Syntax α) → β) : β := +match n with +| ⟨Syntax.node _ args, _⟩ => fn args +| ⟨Syntax.missing, h⟩ => unreachIsNodeMissing h +| ⟨Syntax.atom _ _, h⟩ => unreachIsNodeAtom h +| ⟨Syntax.ident _ _ _ _, h⟩ => unreachIsNodeIdent h +| ⟨Syntax.other _ , h⟩ => unreachIsNodeOther h + +@[inline] def getNumArgs {α} (n : SyntaxNode α) : Nat := +withArgs n $ fun args => args.size + +@[inline] def getArg {α} (n : SyntaxNode α) (i : Nat) : Syntax α := +withArgs n $ fun args => args.get! i + +@[inline] def getArgs {α} (n : SyntaxNode α) : Array (Syntax α) := +withArgs n $ fun args => args + +@[inline] def modifyArgs {α} (n : SyntaxNode α) (fn : Array (Syntax α) → Array (Syntax α)) : Syntax α := +match n with +| ⟨Syntax.node kind args, _⟩ => Syntax.node kind (fn args) +| ⟨Syntax.missing, h⟩ => unreachIsNodeMissing h +| ⟨Syntax.atom _ _, h⟩ => unreachIsNodeAtom h +| ⟨Syntax.ident _ _ _ _, h⟩ => unreachIsNodeIdent h +| ⟨Syntax.other _, h⟩ => unreachIsNodeOther h + +end SyntaxNode + +namespace Syntax +/- TODO: remove `@[extern]` when compiler can perform the following optimization automatically -/ +@[extern c inline "#2"] +partial def lift (α) : Syntax → Syntax α +| atom info val => atom info val +| node k args => node k $ args.map lift +| missing => missing +| ident info rawVal val pre => ident info rawVal val pre +| other o => False.elim (nomatch o) + +def setAtomVal {α} : Syntax α → String → Syntax α +| atom info _, v => (atom info v) +| stx, _ => stx + +@[inline] def ifNode {α β} (stx : Syntax α) (hyes : SyntaxNode α → β) (hno : Unit → β) : β := +match stx with +| Syntax.node k args => hyes ⟨Syntax.node k args, IsNode.mk k args⟩ +| _ => hno () + +@[inline] def ifNodeKind {α β} (stx : Syntax α) (kind : SyntaxNodeKind) (hyes : SyntaxNode α → β) (hno : Unit → β) : β := +match stx with +| Syntax.node k args => if k == kind then hyes ⟨Syntax.node k args, IsNode.mk k args⟩ else hno () +| _ => hno () + +def isIdent {α} : Syntax α → Bool +| ident _ _ _ _ => true +| _ => false + +def getId {α} : Syntax α → Name +| ident _ _ val _ => val +| _ => Name.anonymous + +def isOfKind {α} : Syntax α → SyntaxNodeKind → Bool +| node kind _, k => k == kind +| _, _ => false + +def asNode {α} : Syntax α → SyntaxNode α +| Syntax.node kind args => ⟨Syntax.node kind args, IsNode.mk kind args⟩ +| _ => ⟨Syntax.node nullKind #[], IsNode.mk nullKind #[]⟩ + +def getNumArgs {α} (stx : Syntax α) : Nat := +stx.asNode.getNumArgs + +def getArgs {α} (stx : Syntax α) : Array (Syntax α) := +stx.asNode.getArgs + +def getArg {α} (stx : Syntax α) (i : Nat) : Syntax α := +stx.asNode.getArg i + +def setArgs {α} (stx : Syntax α) (args : Array (Syntax α)) : Syntax α := +match stx with +| node k _ => node k args +| stx => stx + +@[inline] def modifyArgs {α} (stx : Syntax α) (fn : Array (Syntax α) → Array (Syntax α)) : Syntax α := +match stx with +| node k args => node k (fn args) +| stx => stx + +def setArg {α} (stx : Syntax α) (i : Nat) (arg : Syntax α) : Syntax α := +match stx with +| node k args => node k (args.set! i arg) +| stx => stx + +@[inline] def modifyArg {α} (stx : Syntax α) (i : Nat) (fn : Syntax α → Syntax α) : Syntax α := +match stx with +| node k args => node k (args.modify i fn) +| stx => stx + +def getIdAt {α} (stx : Syntax α) (i : Nat) : Name := +(stx.getArg i).getId + +def getKind {α} (stx : Syntax α) : SyntaxNodeKind := +stx.asNode.getKind + +@[specialize] partial def mreplace {α} {m : Type → Type} [Monad m] (fn : Syntax α → m (Option (Syntax α))) : Syntax α → m (Syntax α) +| stx@(node kind args) => do + o ← fn stx; + match o with + | some stx => pure stx + | none => do args ← args.mapM mreplace; pure (node kind args) +| stx => do o ← fn stx; pure $ o.getD stx + +@[specialize] partial def mrewriteBottomUp {α} {m : Type → Type} [Monad m] (fn : Syntax α → m (Syntax α)) : Syntax α → m (Syntax α) +| node kind args => do + args ← args.mapM mrewriteBottomUp; + fn (node kind args) +| stx => fn stx + +@[inline] def rewriteBottomUp {α} (fn : Syntax α → Syntax α) (stx : Syntax α) : Syntax α := +Id.run $ stx.mrewriteBottomUp fn + +private def updateInfo : SourceInfo → String.Pos → SourceInfo +| {leading := {str := s, startPos := _, stopPos := _}, pos := pos, trailing := trailing}, last => + {leading := {str := s, startPos := last, stopPos := pos}, pos := pos, trailing := trailing} + +/- Remark: the State `String.Pos` is the `SourceInfo.trailing.stopPos` of the previous token, + or the beginning of the String. -/ +@[inline] +private def updateLeadingAux {α} : Syntax α → StateM String.Pos (Option (Syntax α)) +| atom (some info) val => do + last ← get; + set info.trailing.stopPos; + let newInfo := updateInfo info last; + pure $ some (atom (some newInfo) val) +| ident (some info) rawVal val pre => do + last ← get; + set info.trailing.stopPos; + let newInfo := updateInfo info last; + pure $ some (ident (some newInfo) rawVal val pre) +| _ => pure none + +/-- Set `SourceInfo.leading` according to the trailing stop of the preceding token. + The Result is a round-tripping Syntax tree IF, in the input Syntax tree, + * all leading stops, atom contents, and trailing starts are correct + * trailing stops are between the trailing start and the next leading stop. + + Remark: after parsing all `SourceInfo.leading` fields are Empty. + The Syntax argument is the output produced by the Parser for `source`. + This Function "fixes" the `source.leanding` field. + + Note that, the `SourceInfo.trailing` fields are correct. + The implementation of this Function relies on this property. -/ +def updateLeading {α} : Syntax α → Syntax α := +fun stx => (mreplace updateLeadingAux stx).run' 0 + +partial def updateTrailing {α} (trailing : Substring) : Syntax α → Syntax α +| Syntax.atom (some info) val => Syntax.atom (some (info.updateTrailing trailing)) val +| Syntax.ident (some info) rawVal val pre => Syntax.ident (some (info.updateTrailing trailing)) rawVal val pre +| n@(Syntax.node k args) => + if args.size == 0 then n + else + let i := args.size - 1; + let last := updateTrailing (args.get! i); + let args := args.set! i last; + Syntax.node k args +| s => s + +/-- Retrieve the left-most leaf's info in the Syntax tree. -/ +partial def getHeadInfo {α} : Syntax α → Option SourceInfo +| atom info _ => info +| ident info _ _ _ => info +| node _ args => args.find? getHeadInfo +| _ => none + +def getPos {α} (stx : Syntax α) : Option String.Pos := +SourceInfo.pos <$> stx.getHeadInfo + +partial def getTailInfo {α} : Syntax α → Option SourceInfo +| atom info _ => info +| ident info _ _ _ => info +| node _ args => args.findRev? getTailInfo +| _ => none + +@[specialize] private partial def updateLast {α} [Inhabited α] (a : Array α) (f : α → Option α) : Nat → Option (Array α) +| i => + if i == 0 then none + else + let i := i - 1; + let v := a.get! i; + match f v with + | some v => some $ a.set! i v + | none => updateLast i + +partial def setTailInfoAux {α} (info : Option SourceInfo) : Syntax α → Option (Syntax α) +| atom _ val => some $ atom info val +| ident _ rawVal val pre => some $ ident info rawVal val pre +| node k args => + match updateLast args setTailInfoAux args.size with + | some args => some $ node k args + | none => none +| stx => none + +def setTailInfo {α} (stx : Syntax α) (info : Option SourceInfo) : Syntax α := +match setTailInfoAux info stx with +| some stx => stx +| none => stx + +private def reprintLeaf : Option SourceInfo → String → String +| none, val => val +| some info, val => info.leading.toString ++ val ++ info.trailing.toString + +partial def reprint {α} : Syntax α → Option String +| atom info val => reprintLeaf info val +| ident info rawVal _ _ => reprintLeaf info rawVal.toString +| node kind args => + if kind == choiceKind then + if args.size == 0 then failure + else do + s ← reprint (args.get! 0); + args.foldlFromM (fun s stx => do s' ← reprint stx; guard (s == s'); pure s) s 1 + else args.foldlM (fun r stx => do s ← reprint stx; pure $ r ++ s) "" +| _ => "" + +open Lean.Format + +protected partial def formatStx {α} : Syntax α → Format +| atom info val => format $ repr val +| ident _ _ val pre => format "`" ++ format val +| node kind args => + if kind == `Lean.Parser.noKind then + sbracket $ joinSep (args.toList.map formatStx) line + else + let shorterName := kind.replacePrefix `Lean.Parser Name.anonymous; + paren $ joinSep ((format shorterName) :: args.toList.map formatStx) line +| missing => "" +| other _ => "" + +instance {α} : HasFormat (Syntax α) := ⟨Syntax.formatStx⟩ +instance {α} : HasToString (Syntax α) := ⟨toString ∘ format⟩ + +end Syntax + +namespace SyntaxNode + +@[inline] def getIdAt {α} (n : SyntaxNode α) (i : Nat) : Name := +(n.getArg i).getId + +end SyntaxNode + +/- Helper functions for creating Syntax objects using C++ -/ + +@[export lean_mk_syntax_atom] +def mkSimpleAtomCore (val : String) : Syntax := +Syntax.atom none val + +@[export lean_mk_syntax_ident] +def mkSimpleIdent (val : Name) : Syntax := +Syntax.ident none (toString val).toSubstring val [] + +@[export lean_mk_syntax_list] +def mkListNode (args : Array Syntax) : Syntax := +Syntax.node nullKind args + +def mkAtom {α} (val : String) : Syntax α := +Syntax.atom none val + +@[inline] def mkNode {α} (k : SyntaxNodeKind) (args : List (Syntax α)) : Syntax α := +Syntax.node k args.toArray + +@[inline] def mkNullNode {α} (args : List (Syntax α)) : Syntax α := +Syntax.node nullKind args.toArray + +def mkOptionalNode {α} (arg : Option (Syntax α)) : Syntax α := +match arg with +| some arg => Syntax.node nullKind #[arg] +| none => Syntax.node nullKind #[] + +/- Helper functions for creating string and numeric literals -/ + +def mkStxLit (kind : SyntaxNodeKind) (val : String) (info : Option SourceInfo := none) : Syntax := +let atom : Syntax := Syntax.atom info val; +Syntax.node kind #[atom] + +def mkStxStrLit (val : String) (info : Option SourceInfo := none) : Syntax := +mkStxLit strLitKind val info + +def mkStxNumLit (val : String) (info : Option SourceInfo := none) : Syntax := +mkStxLit numLitKind val info + +@[export lean_mk_syntax_str_lit] +def mkStxStrLitAux (val : String) : Syntax := +mkStxStrLit val + +@[export lean_mk_syntax_num_lit] +def mkStxNumLitAux (val : Nat) : Syntax := +mkStxNumLit (toString val) + +namespace Syntax + +def isStrLit {α} : Syntax α → Option String +| Syntax.node k args => + if k == strLitKind && args.size == 1 then + match args.get! 0 with + | (Syntax.atom _ val) => some val + | _ => none + else + none +| _ => none + +/- Recall that we don't have special Syntax constructors for storing numeric atoms. + The idea is to have an extensible approach where embedded DSLs may have new kind of atoms and/or + different ways of representing them. So, our atoms contain just the parsed string. + The main Lean parser uses the kind `numLitKind` for storing natural numbers that can be encoded + in binary, octal, decimal and hexadecimal format. `isNatLit` implements a "decoder" + for Syntax objects representing these numerals. -/ + +private partial def decodeBinLitAux (s : String) : Nat → Nat → Option Nat +| i, val => + if s.atEnd i then some val + else + let c := s.get i; + if c == '0' then decodeBinLitAux (s.next i) (2*val) + else if c == '1' then decodeBinLitAux (s.next i) (2*val + 1) + else none + +private partial def decodeOctalLitAux (s : String) : Nat → Nat → Option Nat +| i, val => + if s.atEnd i then some val + else + let c := s.get i; + if '0' ≤ c && c ≤ '7' then decodeOctalLitAux (s.next i) (8*val + c.toNat - '0'.toNat) + else none + +private partial def decodeHexLitAux (s : String) : Nat → Nat → Option Nat +| i, val => + if s.atEnd i then some val + else + let c := s.get i; + if '0' ≤ c && c ≤ '9' then decodeHexLitAux (s.next i) (16*val + c.toNat - '0'.toNat) + else if 'a' ≤ c && c ≤ 'f' then decodeHexLitAux (s.next i) (16*val + 10 + c.toNat - 'a'.toNat) + else if 'A' ≤ c && c ≤ 'F' then decodeHexLitAux (s.next i) (16*val + 10 + c.toNat - 'A'.toNat) + else none + +private partial def decodeDecimalLitAux (s : String) : Nat → Nat → Option Nat +| i, val => + if s.atEnd i then some val + else + let c := s.get i; + if '0' ≤ c && c ≤ '9' then decodeDecimalLitAux (s.next i) (10*val + c.toNat - '0'.toNat) + else none + +private def decodeNatLitVal (s : String) : Option Nat := +let len := s.length; +if len == 0 then none +else + let c := s.get 0; + if c == '0' then + if len == 1 then some 0 + else + let c := s.get 1; + if c == 'x' || c == 'X' then decodeHexLitAux s 2 0 + else if c == 'b' || c == 'B' then decodeBinLitAux s 2 0 + else if c == 'o' || c == 'O' then decodeOctalLitAux s 2 0 + else if c.isDigit then decodeDecimalLitAux s 0 0 + else none + else if c.isDigit then decodeDecimalLitAux s 0 0 + else none + +def isNatLitAux {α} (nodeKind : SyntaxNodeKind) : Syntax α → Option Nat +| Syntax.node k args => + if k == nodeKind && args.size == 1 then + match args.get! 0 with + | (Syntax.atom _ val) => decodeNatLitVal val + | _ => none + else + none +| _ => none + +def isNatLit {α} (s : Syntax α) : Option Nat := +isNatLitAux numLitKind s + +def isFieldIdx {α} (s : Syntax α) : Option Nat := +isNatLitAux fieldIdxKind s + +def isIdOrAtom {α} : Syntax α → Option String +| Syntax.atom _ val => some val +| Syntax.ident _ rawVal _ _ => some rawVal.toString +| _ => none + +def toNat {α} (stx : Syntax α) : Nat := +match stx.isNatLit with +| some val => val +| none => 0 + +end Syntax + +/-- Create an identifier using `SourceInfo` from `src` -/ +def mkIdentFrom {α} (src : Syntax α) (val : Name) : Syntax α := +let info := src.getHeadInfo; +Syntax.ident info (toString val).toSubstring val [] + +def mkAtomFrom {α} (src : Syntax α) (val : String) : Syntax α := +let info := src.getHeadInfo; +Syntax.atom info val + +end Lean diff --git a/stage0/src/Init/Lean/ToExpr.lean b/stage0/src/Init/Lean/ToExpr.lean new file mode 100644 index 0000000000..1743884798 --- /dev/null +++ b/stage0/src/Init/Lean/ToExpr.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Expr +universe u + +namespace Lean + +class ToExpr (α : Type u) := +(toExpr : α → Expr) + +export ToExpr (toExpr) + +instance exprToExpr : ToExpr Expr := ⟨id⟩ + +instance natToExpr : ToExpr Nat := ⟨mkNatLit⟩ + +instance strToExpr : ToExpr String := ⟨mkStrLit⟩ + +def nameToExprAux : Name → Expr +| Name.anonymous => mkConst `Lean.Name.anonymous +| Name.str p s _ => mkCAppB `Lean.mkNameStr (nameToExprAux p) (toExpr s) +| Name.num p n _ => mkCAppB `Lean.mkNameNum (nameToExprAux p) (toExpr n) + +instance nameToExpr : ToExpr Name := ⟨nameToExprAux⟩ + +end Lean diff --git a/stage0/src/Init/Lean/Trace.lean b/stage0/src/Init/Lean/Trace.lean new file mode 100644 index 0000000000..f4188cb966 --- /dev/null +++ b/stage0/src/Init/Lean/Trace.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sebastian Ullrich, Leonardo de Moura +-/ +prelude +import Init.Lean.Message +universe u + +namespace Lean + +class MonadTracer (m : Type → Type u) := +(traceCtx {α} : Name → m α → m α) +(trace {} : Name → (Unit → MessageData) → m PUnit) + +class MonadTracerAdapter (m : Type → Type) := +(isTracingEnabledFor {} : Name → m Bool) +(enableTracing {} : Bool → m Bool) +(getTraces {} : m (Array MessageData)) +(modifyTraces {} : (Array MessageData → Array MessageData) → m Unit) + +namespace MonadTracerAdapter + +section +variables {m : Type → Type} +variables [Monad m] [MonadTracerAdapter m] +variables {α : Type} + +private def addNode (oldTraces : Array MessageData) (cls : Name) : m Unit := +modifyTraces $ fun traces => + let d := MessageData.tagged cls (MessageData.node traces); + oldTraces.push d + +private def getResetTraces : m (Array MessageData) := +do oldTraces ← getTraces; + modifyTraces $ fun _ => #[]; + pure oldTraces + +private def addTrace (cls : Name) (msg : MessageData) : m Unit := +modifyTraces $ fun traces => traces.push (MessageData.tagged cls msg) + +@[inline] protected def trace (cls : Name) (msg : Unit → MessageData) : m Unit := +whenM (isTracingEnabledFor cls) (addTrace cls (msg ())) + +@[inline] def traceCtx (cls : Name) (ctx : m α) : m α := +do b ← isTracingEnabledFor cls; + if !b then do old ← enableTracing false; a ← ctx; enableTracing old; pure a + else do + oldCurrTraces ← getResetTraces; + a ← ctx; + addNode oldCurrTraces cls; + pure a + +end + +section +variables {ε : Type} {m : Type → Type} +variables [MonadExcept ε m] [Monad m] [MonadTracerAdapter m] +variables {α : Type} + +/- Version of `traceCtx` with exception handling support. -/ +@[inline] protected def traceCtxExcept (cls : Name) (ctx : m α) : m α := +do b ← isTracingEnabledFor cls; + if !b then do + old ← enableTracing false; + catch + (do a ← ctx; enableTracing old; pure a) + (fun e => do enableTracing old; throw e) + else do + oldCurrTraces ← getResetTraces; + catch + (do a ← ctx; addNode oldCurrTraces cls; pure a) + (fun e => do addNode oldCurrTraces cls; throw e) +end + +end MonadTracerAdapter + +instance monadTracerAdapter {m : Type → Type} [Monad m] [MonadTracerAdapter m] : MonadTracer m := +{ traceCtx := @MonadTracerAdapter.traceCtx _ _ _, + trace := @MonadTracerAdapter.trace _ _ _ } + +instance monadTracerAdapterExcept {ε : Type} {m : Type → Type} [Monad m] [MonadExcept ε m] [MonadTracerAdapter m] : MonadTracer m := +{ traceCtx := @MonadTracerAdapter.traceCtxExcept _ _ _ _ _, + trace := @MonadTracerAdapter.trace _ _ _ } + +structure TraceState := +(enabled : Bool := true) +(traces : Array MessageData := #[]) + +namespace TraceState + +instance : Inhabited TraceState := ⟨{}⟩ + +instance : HasFormat TraceState := ⟨fun s => Format.joinArraySep s.traces Format.line⟩ + +instance : HasToString TraceState := ⟨toString ∘ fmt⟩ + +end TraceState + +class SimpleMonadTracerAdapter (m : Type → Type) := +(getOptions {} : m Options) +(modifyTraceState {} : (TraceState → TraceState) → m Unit) +(getTraceState {} : m TraceState) + +namespace SimpleMonadTracerAdapter +variables {m : Type → Type} [Monad m] [SimpleMonadTracerAdapter m] + +private def checkTraceOptionAux (opts : Options) : Name → Bool +| n@(Name.str p _ _) => opts.getBool n || (!opts.contains n && checkTraceOptionAux p) +| _ => false + +private def checkTraceOption (optName : Name) : m Bool := +do opts ← getOptions; + if opts.isEmpty then pure false + else pure $ checkTraceOptionAux opts optName + +@[inline] def isTracingEnabledFor (cls : Name) : m Bool := +do s ← getTraceState; + if !s.enabled then pure false + else checkTraceOption (`trace ++ cls) + +@[inline] def enableTracing (b : Bool) : m Bool := +do s ← getTraceState; + let oldEnabled := s.enabled; + modifyTraceState $ fun s => { enabled := b, .. s }; + pure oldEnabled + +@[inline] def getTraces : m (Array MessageData) := +do s ← getTraceState; pure s.traces + +@[inline] def modifyTraces (f : Array MessageData → Array MessageData) : m Unit := +modifyTraceState $ fun s => { traces := f s.traces, .. s } + +end SimpleMonadTracerAdapter + +instance simpleMonadTracerAdapter {m : Type → Type} [SimpleMonadTracerAdapter m] [Monad m] : MonadTracerAdapter m := +{ isTracingEnabledFor := @SimpleMonadTracerAdapter.isTracingEnabledFor _ _ _, + enableTracing := @SimpleMonadTracerAdapter.enableTracing _ _ _, + getTraces := @SimpleMonadTracerAdapter.getTraces _ _ _, + modifyTraces := @SimpleMonadTracerAdapter.modifyTraces _ _ _ } + +export MonadTracer (traceCtx trace) + +/- +Recipe for adding tracing support for a monad `M`. + +1- Define the instance `SimpleMonadTracerAdapter M` by showing how to retrieve `Options` and + get/modify `TraceState` object. + +2- The `Options` control whether tracing commands are ignored or not. + +3- The macro `trace! ` adds the trace message `` if `` is activate and tracing is enabled. + +4- We activate the tracing class `` by setting option `trace.` to true. If a prefix `p` of `trace.` is + set to true, and there isn't a longer prefix `p'` set to false, then `` is also considered active. + +5- `traceCtx ` groups all messages generated by `` into a single `MessageData.node`. + If ` is not activate, then (all) tracing is disabled while executing ``. This feature is + useful for the following scenario: + a) We have a tactic called `mysimp` which uses trace class `mysimp`. + b) `mysimp invokes the unifier module which uses trace class `unify`. + c) In the beginning of `mysimp`, we use `traceCtx`. + In this scenario, by not enabling `mysimp` we also disable the `unify` trace messages produced + by executing `mysimp`. +-/ + +end Lean diff --git a/stage0/src/Init/Lean/TypeClass.lean b/stage0/src/Init/Lean/TypeClass.lean new file mode 100644 index 0000000000..5173fe1068 --- /dev/null +++ b/stage0/src/Init/Lean/TypeClass.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam, Leonardo de Moura +-/ +prelude +import Init.Lean.TypeClass.Basic diff --git a/stage0/src/Init/Lean/TypeClass/Basic.lean b/stage0/src/Init/Lean/TypeClass/Basic.lean new file mode 100644 index 0000000000..4586e87754 --- /dev/null +++ b/stage0/src/Init/Lean/TypeClass/Basic.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam, Leonardo de Moura +-/ +prelude +import Init.Lean.Environment +import Init.Lean.TypeClass.Synth + +namespace Lean +namespace TypeClass + +/- Entry point for the `#synth` command used for testing. -/ +@[export lean_typeclass_synth_command] +def synthCommand (env : Environment) (goalType : Expr) : ExceptT String Id Expr := +match (synth goalType).run { env := env } with +| EStateM.Result.ok val _ => pure val +| EStateM.Result.error msg _ => throw msg + +end TypeClass +end Lean diff --git a/stage0/src/Init/Lean/TypeClass/Context.lean b/stage0/src/Init/Lean/TypeClass/Context.lean new file mode 100644 index 0000000000..b9a0b6177d --- /dev/null +++ b/stage0/src/Init/Lean/TypeClass/Context.lean @@ -0,0 +1,351 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam + +Custom unifier for tabled typeclass resolution. + +Note: this file will be removed once the unifier is implemented in Lean. +-/ +prelude +import Init.Data.Nat +import Init.Data.PersistentArray +import Init.Lean.Expr +import Init.Lean.MetavarContext + +namespace Lean +namespace TypeClass + +structure Context : Type := +(uVals : PersistentArray (Option Level) := PersistentArray.empty) +(eTypes : PersistentArray Expr := PersistentArray.empty) +(eVals : PersistentArray (Option Expr) := PersistentArray.empty) + +instance Context.Inhabited : Inhabited Context := ⟨{}⟩ + +structure ContextFail : Type := +(msg : String) + +abbrev ContextFn : Type → Type := EStateM ContextFail Context + +namespace Context + +def metaPrefix : Name := +`_tc_meta + +def alphaMetaPrefix : Name := +`_tc_alpha + +-- Expressions + +def eMetaIdx : Expr → Option Nat +| Expr.mvar (Name.num n idx _) _ => guard (n == metaPrefix) *> pure idx +| _ => none + +def eIsMeta (e : Expr) : Bool := (eMetaIdx e).toBool + +def eNewMeta (type : Expr) : StateM Context Expr := +do ctx ← get; + let idx := ctx.eTypes.size; + set { eTypes := ctx.eTypes.push type, eVals := ctx.eVals.push none, .. ctx }; + pure $ mkMVar (mkNameNum metaPrefix idx) + +def eLookupIdx (idx : Nat) : StateM Context (Option Expr) := +do ctx ← get; pure $ ctx.eVals.get! idx + +partial def eShallowInstantiate : Expr → StateM Context Expr +| e => + match eMetaIdx e with + | some idx => get >>= λ ctx => + match ctx.eVals.get! idx with + | none => pure e + | some v => eShallowInstantiate v + | none => pure e + +def eInferIdx (idx : Nat) : StateM Context Expr := +do ctx ← get; pure $ ctx.eTypes.get! idx + +def eInfer (ctx : Context) (mvar : Expr) : Expr := +match eMetaIdx mvar with +| some idx => ctx.eTypes.get! idx +| none => panic! "eInfer called on non-(tmp-)mvar" + +def eAssignIdx (idx : Nat) (e : Expr) : StateM Context Unit := +modify $ λ ctx => { eVals := ctx.eVals.set idx (some e) .. ctx } + +def eAssign (mvar : Expr) (e : Expr) : StateM Context Unit := +match eMetaIdx mvar with +| some idx => modify $ λ ctx => { eVals := ctx.eVals.set idx (some e) .. ctx } +| _ => panic! "eAssign called on non-(tmp-)mvar" + +partial def eFind (f : Expr → Bool) : Expr → Bool +| e => + if f e + then true + else + match e with + | Expr.app f a _ => eFind f || eFind a + | Expr.forallE _ d b _ => eFind d || eFind b + | _ => false + +def eOccursIn (t₀ : Expr) (e : Expr) : Bool := +eFind (λ t => t == t₀) e + +def eHasETmpMVar (e : Expr) : Bool := +eFind eIsMeta e + +-- Levels + +def uMetaIdx : Level → Option Nat +| Level.mvar (Name.num n idx _) _ => guard (n == metaPrefix) *> pure idx +| _ => none + +def uIsMeta (l : Level) : Bool := (uMetaIdx l).toBool + +def uNewMeta : StateM Context Level := +do ctx ← get; + let idx := ctx.uVals.size; + set { uVals := ctx.uVals.push none, .. ctx }; + pure $ mkLevelMVar (mkNameNum metaPrefix idx) + +def uLookupIdx (idx : Nat) : StateM Context (Option Level) := +do ctx ← get; pure $ ctx.uVals.get! idx + +partial def uShallowInstantiate : Level → StateM Context Level +| l => + match uMetaIdx l with + | some idx => get >>= λ ctx => + match ctx.uVals.get! idx with + | none => pure l + | some v => uShallowInstantiate v + | none => pure l + +def uAssignIdx (idx : Nat) (l : Level) : StateM Context Unit := +modify $ λ ctx => { uVals := ctx.uVals.set idx (some l) .. ctx } + +def uAssign (umvar : Level) (l : Level) : StateM Context Unit := +match uMetaIdx umvar with +| some idx => modify $ λ ctx => { uVals := ctx.uVals.set idx (some l) .. ctx } +| _ => panic! "uassign called on non-(tmp-)mvar" + +partial def uFind (f : Level → Bool) : Level → Bool +| l => + if f l + then true + else + match l with + | Level.succ l _ => uFind l + | Level.max l₁ l₂ _ => uFind l₁ || uFind l₂ + | Level.imax l₁ l₂ _ => uFind l₁ || uFind l₂ + | _ => false + +def uOccursIn (l₀ : Level) (l : Level) : Bool := +uFind (λ l => l == l₀) l + +def uHasTmpMVar (l : Level) : Bool := +uFind uIsMeta l + +partial def uUnify : Level → Level → EStateM String Context Unit +| l₁, l₂ => do + l₁ ← EStateM.fromStateM $ uShallowInstantiate l₁; + l₂ ← EStateM.fromStateM $ uShallowInstantiate l₂; + if uIsMeta l₂ && !(uIsMeta l₁) + then uUnify l₂ l₁ + else + match l₁, l₂ with + | Level.zero _, Level.zero _ => pure () + | Level.param p₁ _, Level.param p₂ _ => when (p₁ != p₂) $ throw "Level.param clash" + | Level.succ l₁ _, Level.succ l₂ _ => uUnify l₁ l₂ + | Level.max l₁₁ l₁₂ _, Level.max l₂₁ l₂₂ _ => uUnify l₁₁ l₂₁ *> uUnify l₁₂ l₂₂ + | Level.imax l₁₁ l₁₂ _, Level.imax l₂₁ l₂₂ _ => uUnify l₁₁ l₂₁ *> uUnify l₁₂ l₂₂ + | Level.mvar _ _, _ => + match uMetaIdx l₁ with + | none => when (!(l₁ == l₂)) $ throw "Level.mvar clash" + | some idx => do when (uOccursIn l₁ l₂) $ throw "occurs"; + EStateM.fromStateM $ uAssignIdx idx l₂ + | _, _ => throw $ "lUnify: " ++ toString l₁ ++ " !=?= " ++ toString l₂ + +partial def uInstantiate (ctx : Context) : Level → Level +| l => if (!l.hasMVar) + then l + else + match uMetaIdx l with + | some idx => match (Context.uLookupIdx idx).run' ctx with + | some t => uInstantiate t + | none => l + | none => + match l with + | Level.succ l _ => mkLevelSucc $ uInstantiate l + | Level.max l₁ l₂ _ => mkLevelMax (uInstantiate l₁) (uInstantiate l₂) + | Level.imax l₁ l₂ _ => mkLevelIMax (uInstantiate l₁) (uInstantiate l₂) + | _ => l + +-- Expressions and Levels + +def eHasTmpMVar (e : Expr) : Bool := +if e.hasMVar +then eFind (λ t => eIsMeta t || (t.isConst && t.constLevels!.any uHasTmpMVar)) e +else false + +partial def slowWhnfApp (args : Array Expr) : Expr → Nat → Expr +| f@(Expr.lam _ d b _), i => + if h : i < args.size then + slowWhnfApp (b.instantiate1 (args.get ⟨i, h⟩)) (i+1) + else + f +| f, i => + if h : i < args.size then + slowWhnfApp (mkApp f (args.get ⟨i, h⟩)) (i+1) + else + f + +partial def slowWhnf : Expr → Expr +| e => if e.isApp then slowWhnfApp e.getAppArgs (slowWhnf e.getAppFn) 0 else e + +partial def eUnify : Expr → Expr → EStateM String Context Unit +| e₁, e₂ => + if !e₁.hasMVar && !e₂.hasMVar + then unless (e₁ == e₂) $ throw $ "eUnify: " ++ toString e₁ ++ " !=?= " ++ toString e₂ + else do + e₁ ← slowWhnf <$> (EStateM.fromStateM $ eShallowInstantiate e₁); + e₂ ← slowWhnf <$> (EStateM.fromStateM $ eShallowInstantiate e₂); + if e₁.isMVar && e₂.isMVar && e₁ == e₂ then pure () + else if eIsMeta e₂ && !(eIsMeta e₁) then eUnify e₂ e₁ + else if e₁.isBVar && e₂.isBVar && e₁.bvarIdx! == e₂.bvarIdx! then pure () + else if e₁.isFVar && e₂.isFVar && e₁.fvarId! == e₂.fvarId! then pure () + else if e₁.isConst && e₂.isConst && e₁.constName! == e₂.constName! then + List.forM₂ uUnify e₁.constLevels! e₂.constLevels! + else if e₁.isApp && e₂.isApp && e₁.getAppNumArgs == e₂.getAppNumArgs then do + let args₁ := e₁.getAppArgs; + let args₂ := e₂.getAppArgs; + eUnify e₁.getAppFn e₂.getAppFn; + args₁.size.forM $ fun i => eUnify (args₁.get! i) (args₂.get! i) + else if e₁.isForall && e₂.isForall then do + eUnify e₁.bindingDomain! e₂.bindingDomain!; + eUnify e₁.bindingBody! e₂.bindingBody! + else if eIsMeta e₁ && !(eOccursIn e₂ e₁) then + match eMetaIdx e₁ with + | some idx => EStateM.fromStateM $ eAssignIdx idx e₂ + | none => panic! "UNREACHABLE" + else + throw $ "eUnify: " ++ toString e₁ ++ " !=?= " ++ toString e₂ + +partial def eInstantiate (ctx : Context) : Expr → Expr +| e => + if !e.hasMVar -- conservative check (includes regular mvars as well) + then e + else + match e with + | Expr.forallE n d b c => mkForall n c.binderInfo (eInstantiate d) (eInstantiate b) + | Expr.lam n d b c => mkLambda n c.binderInfo (eInstantiate d) (eInstantiate b) + | Expr.const n ls _ => mkConst n (ls.map $ uInstantiate ctx) + | Expr.app e₁ e₂ _ => mkApp (eInstantiate e₁) (eInstantiate e₂) + | _ => + match eMetaIdx e with + | none => e + | some idx => do + match (eLookupIdx idx).run' ctx with + | some t => eInstantiate t + | none => e + +-- AlphaNormalization + +structure MetaNormData (α : Type) : Type := +(ctx : α) +(eRenameMap : RBMap Nat Nat (λ n₁ n₂ => n₁ < n₂) := mkRBMap _ _ _) +(uRenameMap : RBMap Nat Nat (λ n₁ n₂ => n₁ < n₂) := mkRBMap _ _ _) + +structure MetaNormFuncs (α : Type) : Type := +(uNewMeta : Nat → StateM (MetaNormData α) Level) +(uMkMeta : Nat → StateM (MetaNormData α) Level) +(eNewMeta : Nat → StateM (MetaNormData α) Expr) +(eMkMeta : Nat → StateM (MetaNormData α) Expr) + +partial def uMetaNormalizeCore {α : Type} (fs : MetaNormFuncs α) : Level → StateM (MetaNormData α) Level +| l => + if !l.hasMVar then pure l else + match l with + | Level.zero _ => pure l + | Level.param _ _ => pure l + | Level.succ l _ => do l ← uMetaNormalizeCore l; + pure $ mkLevelSucc l + | Level.max l₁ l₂ _ => do l₁ ← uMetaNormalizeCore l₁; + l₂ ← uMetaNormalizeCore l₂; + pure $ mkLevelMax l₁ l₂ + | Level.imax l₁ l₂ _ => do l₁ ← uMetaNormalizeCore l₁; + l₂ ← uMetaNormalizeCore l₂; + pure $ mkLevelIMax l₁ l₂ + | Level.mvar m _ => + match uMetaIdx l with + | none => pure l + | some idx => do + lookupStatus ← get >>= λ ϕ => pure $ ϕ.uRenameMap.find idx; + match lookupStatus with + | none => fs.uNewMeta idx + | some idx => fs.uMkMeta idx + +partial def eMetaNormalizeCore {α : Type} (fs : MetaNormFuncs α) : Expr → StateM (MetaNormData α) Expr +| e => + if e.isConst then do + ls ← e.constLevels!.mapM (uMetaNormalizeCore fs); + pure $ Expr.updateConst! e ls + else if e.isFVar then pure e + else if !e.hasMVar then pure e + else match e with + | Expr.app f a _ => do + f ← eMetaNormalizeCore f; + a ← eMetaNormalizeCore a; + pure $ mkApp f a + | Expr.forallE n d b c => do + d ← eMetaNormalizeCore d; + b ← eMetaNormalizeCore b; + pure $ mkForall n c.binderInfo d b + | _ => + match eMetaIdx e with + | none => pure e + | some idx => do + lookupStatus ← get >>= λ ϕ => pure $ ϕ.eRenameMap.find idx; + match lookupStatus with + | none => fs.eNewMeta idx + | some idx => fs.eMkMeta idx + +def αNorm (e : Expr) : Expr := +let fs : MetaNormFuncs Unit := { + uNewMeta := λ idx => do { + l ← get >>= λ ϕ => pure $ mkLevelMVar (mkNameNum alphaMetaPrefix ϕ.uRenameMap.size); + modify $ λ ϕ => { uRenameMap := ϕ.uRenameMap.insert idx ϕ.uRenameMap.size .. ϕ }; + pure l }, + uMkMeta := λ idx => pure $ mkLevelMVar (mkNameNum alphaMetaPrefix idx), + eNewMeta := λ idx => do { + e ← get >>= λ ϕ => pure $ mkMVar (mkNameNum alphaMetaPrefix ϕ.eRenameMap.size); + modify $ λ ϕ => { eRenameMap := ϕ.eRenameMap.insert idx ϕ.eRenameMap.size .. ϕ }; + pure e }, + eMkMeta := λ idx => pure $ mkMVar (mkNameNum alphaMetaPrefix idx) +}; +(eMetaNormalizeCore fs e).run' { ctx := () } + +def internalize (oldCtx : Context) (val type : Expr) (newCtx : Context) : Expr × Expr × Context := +let fs : MetaNormFuncs (Context × Context) := { + uNewMeta := λ idx => do { + (oldCtx, newCtx) ← get >>= λ ϕ => pure ϕ.ctx; + (l, newCtx) ← pure $ StateT.run Context.uNewMeta newCtx; + match Context.uMetaIdx l with + | some newIdx => modify $ λ ϕ => { ctx := (oldCtx, newCtx), uRenameMap := ϕ.uRenameMap.insert idx newIdx, .. ϕ } + | none => panic "unreachable"; + pure l }, + uMkMeta := λ idx => pure $ mkLevelMVar (mkNameNum metaPrefix idx), + eNewMeta := λ idx => do { + (oldCtx, newCtx) ← get >>= λ ϕ => pure ϕ.ctx; + (e, newCtx) ← pure $ StateT.run (Context.eNewMeta $ oldCtx.eTypes.get! idx) newCtx; + match Context.eMetaIdx e with + | some newIdx => modify $ λ ϕ => { ctx := (oldCtx, newCtx), eRenameMap := ϕ.eRenameMap.insert idx newIdx, .. ϕ } + | none => panic "unreachable"; + pure e }, + eMkMeta := λ idx => pure $ mkMVar (mkNameNum metaPrefix idx) +}; +match (do newType ← eMetaNormalizeCore fs type; newVal ← eMetaNormalizeCore fs val; pure (newVal, newType)).run { ctx := (oldCtx, newCtx) } with +| ((newVal, newType), ϕ) => (newVal, newType, ϕ.ctx.2) + +end Context +end TypeClass +end Lean diff --git a/stage0/src/Init/Lean/TypeClass/Synth.lean b/stage0/src/Init/Lean/TypeClass/Synth.lean new file mode 100644 index 0000000000..0c5afd35cd --- /dev/null +++ b/stage0/src/Init/Lean/TypeClass/Synth.lean @@ -0,0 +1,326 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam + +Typeclass synthesis using tabled resolution. + +Note: this file will be need to be updated once the unifier is implemented in Lean. +-/ +prelude +import Init.Lean.Expr +import Init.Lean.Environment +import Init.Lean.Class +import Init.Lean.MetavarContext +import Init.Lean.TypeClass.Context +import Init.Data.PersistentHashMap +import Init.Data.Stack +import Init.Data.Queue + +namespace Lean +namespace TypeClass + +structure TypedExpr : Type := +(val type : Expr) + +instance TypedExpr.HasToString : HasToString TypedExpr := +⟨λ ⟨val, type⟩ => "TypedExpr(" ++ toString val ++ ", " ++ toString type ++ ")"⟩ + +instance TypedExpr.Inhabited : Inhabited TypedExpr := +⟨⟨arbitrary _, arbitrary _⟩⟩ + +structure Answer : Type := +(ctx : Context) (typedExpr : TypedExpr) + +instance Answer.HasToString : HasToString Answer := +⟨λ ⟨_, ⟨val, type⟩⟩ => "Answer(" ++ toString val ++ ", " ++ toString type ++ ")"⟩ + +instance Answer.Inhabited : Inhabited TypedExpr := +⟨⟨arbitrary _, arbitrary _⟩⟩ + +structure Node : Type := +(anormSubgoal : Expr) +(ctx : Context) +(futureAnswer : TypedExpr) + +instance Node.Inhabited : Inhabited Node := +⟨⟨arbitrary _, {}, arbitrary _⟩⟩ + +structure ConsumerNode extends Node := +(remainingSubgoals : List Expr) + +instance ConsumerNode.Inhabited : Inhabited ConsumerNode := +⟨⟨arbitrary _, arbitrary _⟩⟩ + +inductive Waiter : Type +| consumerNode : ConsumerNode → Waiter +| root : Waiter + +def Waiter.isRoot : Waiter → Bool +| Waiter.consumerNode _ => false +| root => true + +-- TODO(dselsam): support local instances once elaborator is in Lean +inductive Instance : Type +| lDecl : LocalDecl → Instance +| const : Name → Instance + +structure GeneratorNode extends Node := +(remainingInstances : List Instance) + +instance GeneratorNode.Inhabited : Inhabited GeneratorNode := +⟨⟨arbitrary _, arbitrary _⟩⟩ + +structure TableEntry : Type := +(waiters : Array Waiter) +(answers : Array Answer := #[]) + +structure TCState : Type := +(env : Environment) +(finalAnswer : Option TypedExpr := none) +(mainMVar : Expr := arbitrary _) +(generatorStack : Stack GeneratorNode := Stack.empty) +(consumerStack : Stack ConsumerNode := Stack.empty) +(resumeQueue : Queue (ConsumerNode × Answer) := Queue.empty) +(tableEntries : PersistentHashMap Expr TableEntry := PersistentHashMap.empty) + +abbrev TCMethod : Type → Type := EStateM String TCState + +-- TODO(dselsam): once `whnf` is ready, need a more expensive pass as a backup, +-- that creates locals and calls `whnf` on every recursion. +-- See: [type_context.cpp] optional type_context_old::is_full_class(expr type) +-- TODO(dselsam): check if we need to call `get_decl()` as well in the `const` case. +def quickIsClass (env : Environment) : Expr → Option (Option Name) +| Expr.letE _ _ _ _ _ => none +| Expr.proj _ _ _ _ => none +| Expr.mdata _ e _ => quickIsClass e +| Expr.const n _ _ => if isClass env n then some (some n) else none +| Expr.forallE _ _ b _ => quickIsClass b +| Expr.app e _ _ => + let f := e.getAppFn; + if f.isConst && isClass env f.constName! then some (some f.constName!) + else if f.isLambda then none + else some none +| _ => some none + +def newSubgoal (waiter : Waiter) (ctx : Context) (anormSubgoal mvar : Expr) : TCMethod Unit := +do let mvarType := ctx.eInstantiate (ctx.eInfer mvar); + isClassStatus ← get >>= λ ϕ => pure $ quickIsClass ϕ.env mvarType; + match isClassStatus with + | none => throw $ "quickIsClass not sufficient to show `" ++ toString mvarType ++ "` is a class" + | some none => throw $ "found non-class goal `" ++ toString mvarType ++ "`" + | some (some n) => do + let ⟨newVal, newType, newCtx⟩ := Context.internalize ctx mvar mvarType {}; + gNode ← get >>= λ ϕ => pure { + GeneratorNode . + ctx := newCtx, + anormSubgoal := anormSubgoal, + futureAnswer := ⟨newVal, newType⟩, + remainingInstances := (getClassInstances ϕ.env n).map Instance.const + }; + let tableEntry : TableEntry := { waiters := #[waiter] }; + modify $ λ ϕ => { + generatorStack := ϕ.generatorStack.push gNode, + tableEntries := ϕ.tableEntries.insert gNode.anormSubgoal tableEntry, + .. ϕ + } + +partial def introduceMVars (lctx : LocalContext) (locals : Array Expr) : Context → Expr → Expr → List Expr → Context × Expr × Expr × List Expr +| ctx, instVal, Expr.forallE _ domain body c, mvars => do + let info := c.binderInfo; + let ⟨mvar, ctx⟩ := (Context.eNewMeta $ lctx.mkForall locals domain).run ctx; + let arg := mkAppN mvar locals; + let instVal := mkApp instVal arg; + let instType := body.instantiate1 arg; + let mvars := if info.isInstImplicit then mvar::mvars else mvars; + introduceMVars ctx instVal instType mvars + +| ctx, instVal, instType, mvars => (ctx, instVal, instType, mvars) + +partial def introduceLocals : Nat → LocalContext → Array Expr → Expr → LocalContext × Expr × Array Expr +| nextIdx, lctx, ls, Expr.forallE name domain body c => + let info := c.binderInfo; + let idxName : Name := mkNameNum `_tmp nextIdx; + let lctx := lctx.mkLocalDecl idxName name domain info; + let l : Expr := mkFVar idxName; + introduceLocals (nextIdx + 1) lctx (ls.push l) (body.instantiate1 l) + +| _, lctx, ls, e => (lctx, e, ls) + +def tryResolve (ctx : Context) (futureAnswer : TypedExpr) (instTE : TypedExpr) : TCMethod (Option (Context × List Expr)) := +do let ⟨mvar, mvarType⟩ := futureAnswer; + let ⟨instVal, instType⟩ := instTE; + let ⟨lctx, mvarType, locals⟩ := introduceLocals 0 {} #[] mvarType; + let ⟨ctx, instVal, instType, newMVars⟩ := introduceMVars lctx locals ctx instVal instType []; + match (Context.eUnify mvarType instType *> Context.eUnify mvar (lctx.mkLambda locals instVal)).run ctx with + | EStateM.Result.error msg _ => pure none + | EStateM.Result.ok _ ctx => pure $ some $ (ctx, newMVars) + +def newConsumerNode (node : Node) (ctx : Context) (newMVars : List Expr) : TCMethod Unit := +let cNode : ConsumerNode := { remainingSubgoals := newMVars, ctx := ctx, .. node }; +modify $ λ ϕ => { consumerStack := ϕ.consumerStack.push cNode, .. ϕ } + +def resume : TCMethod Unit := +do ((cNode, answer), resumeQueue) ← get >>= λ ϕ => + match ϕ.resumeQueue.dequeue? with + | none => throw "resume found nothing to resume" + | some result => pure result; + match cNode.remainingSubgoals with + | [] => throw "resume found no remaining subgoals" + | (mvar::rest) => do + let newCtx : Context := cNode.ctx; + let ⟨newVal, newType, newCtx⟩ : Expr × Expr × Context := Context.internalize answer.ctx answer.typedExpr.val answer.typedExpr.type newCtx; + result : Option (Context × List Expr) ← + tryResolve newCtx ⟨mvar, newCtx.eInfer mvar⟩ ⟨newVal, newType⟩; + modify $ λ ϕ => { resumeQueue := resumeQueue, .. ϕ }; + match result with + | none => pure () + | some (newCtx, newMVars) => newConsumerNode cNode.toNode newCtx (newMVars ++ rest) + +def wakeUp (answer : Answer) : Waiter → TCMethod Unit +| Waiter.root => modify $ λ ϕ => { finalAnswer := some answer.typedExpr .. ϕ } +| Waiter.consumerNode cNode => modify $ λ ϕ => { resumeQueue := ϕ.resumeQueue.enqueue (cNode, answer), .. ϕ } + +def newAnswer (anormSubgoal : Expr) (answer : Answer) : TCMethod Unit := +do lookupStatus ← get >>= λ ϕ => pure $ ϕ.tableEntries.find anormSubgoal; + match lookupStatus with + | none => throw $ "[newAnswer]: " ++ toString anormSubgoal ++ " not found in table!" + | some entry => do + if entry.answers.any (λ answer₁ => Context.αNorm (answer₁.typedExpr.type) == Context.αNorm (answer.typedExpr.type)) then pure () + else if entry.waiters.any Waiter.isRoot + && (Context.eHasTmpMVar answer.typedExpr.type || Context.eHasTmpMVar answer.typedExpr.val) then pure() + else do + let newEntry : TableEntry := { answers := entry.answers.push answer .. entry }; + modify $ λ ϕ => { tableEntries := ϕ.tableEntries.insert anormSubgoal newEntry .. ϕ }; + entry.waiters.forM (wakeUp answer) + +def consume : TCMethod Unit := +do cNode ← get >>= λ ϕ => pure ϕ.consumerStack.peek!; + modify $ λ ϕ => { consumerStack := ϕ.consumerStack.pop .. ϕ }; + match cNode.remainingSubgoals with + | [] => do + let answer : Answer := { + ctx := cNode.ctx, + typedExpr := { + val := cNode.ctx.eInstantiate cNode.futureAnswer.val, + type := cNode.ctx.eInstantiate cNode.futureAnswer.type + }}; + newAnswer cNode.anormSubgoal answer + + | mvar::rest => do + let anormSubgoal : Expr := Context.αNorm (cNode.ctx.eInstantiate $ cNode.ctx.eInfer mvar); + let waiter : Waiter := Waiter.consumerNode cNode; + lookupStatus ← get >>= λ ϕ => pure $ ϕ.tableEntries.find anormSubgoal; + match lookupStatus with + | none => newSubgoal waiter cNode.ctx anormSubgoal mvar + | some entry => modify $ λ ϕ => { + resumeQueue := entry.answers.foldl (λ rq answer => rq.enqueue (cNode, answer)) ϕ.resumeQueue, + tableEntries := ϕ.tableEntries.insert anormSubgoal { waiters := entry.waiters.push waiter, .. entry }, + .. ϕ } + +def constNameToTypedExpr (ctx : Context) (instName : Name) : TCMethod (TypedExpr × Context) := +do lookupStatus ← get >>= λ ϕ => pure $ ϕ.env.find instName; + match lookupStatus with + | none => throw $ "instance " ++ toString instName ++ " not found in env" + | some cInfo => + let ⟨uMetas, ctx⟩ : List Level × Context := + cInfo.lparams.foldl (λ ⟨uMetas, ctx⟩ _ => + let ⟨uMeta, ctx⟩ := Context.uNewMeta.run ctx; + ⟨uMeta::uMetas, ctx⟩) + ([], ctx); + let instVal := mkConst instName uMetas; + let instType := cInfo.instantiateTypeLevelParams uMetas; + pure ⟨⟨instVal, instType⟩, ctx⟩ + +def generate : TCMethod Unit := +do gNode ← get >>= λ ϕ => pure ϕ.generatorStack.peek!; + match gNode.remainingInstances with + | [] => modify $ λ ϕ => { generatorStack := ϕ.generatorStack.pop, .. ϕ } + | inst::insts => do + ⟨instTE, ctx⟩ ← match inst with + | Instance.const n => constNameToTypedExpr gNode.ctx n + | Instance.lDecl lDecl => throw "local instances not yet supported"; + result : Option (Context × List Expr) ← tryResolve ctx gNode.futureAnswer instTE; + modify $ λ ϕ => { generatorStack := ϕ.generatorStack.modify (λ gNode => { remainingInstances := insts .. gNode }) .. ϕ }; + match result with + | none => pure () + | some (ctx, newMVars) => newConsumerNode gNode.toNode ctx newMVars + +def step : TCMethod Unit := +do ϕ ← get; + if !ϕ.resumeQueue.isEmpty then resume + else if !ϕ.consumerStack.isEmpty then consume + else if !ϕ.generatorStack.isEmpty then generate + else throw "FAILED TO SYNTHESIZE" + +partial def synthCore (ctx₀ : Context) (goalType : Expr) : Nat → TCMethod TypedExpr +| 0 => throw "[synthCore] out of fuel" +| n+1 => do + step; + finalAnswer ← get >>= λ ϕ => pure ϕ.finalAnswer; + match finalAnswer with + | none => synthCore n + | some ⟨answerVal, answerType⟩ => pure ⟨answerVal, answerType⟩ + +def collectUReplacements : List Level → Context → Array (Level × Level) → Array Level + → Context × Array (Level × Level) × Array Level +| [], ctx, uReplacements, fLevels => (ctx, uReplacements, fLevels) + +| l::ls, ctx, uReplacements, fLevels => + if l.hasMVar then + let ⟨uMeta, ctx⟩ := Context.uNewMeta.run ctx; + collectUReplacements ls ctx (uReplacements.push (uMeta,l)) (fLevels.push uMeta) + else + collectUReplacements ls ctx uReplacements (fLevels.push l) + +def collectEReplacements (env : Environment) (lctx : LocalContext) (locals : Array Expr) + : Expr → List Expr → Context → Array (Expr × Expr) → Array Expr + → Context × Array (Expr × Expr) × Array Expr +| _, [], ctx, eReplacements, fArgs => (ctx, eReplacements, fArgs) + +| Expr.forallE _ d b _, arg::args, ctx, eReplacements, fArgs => + if isOutParam d then + let ⟨eMeta, ctx⟩ := (Context.eNewMeta $ lctx.mkForall locals d).run ctx; + let fArg : Expr := mkAppN eMeta locals; + collectEReplacements (b.instantiate1 fArg) args ctx (eReplacements.push (eMeta, arg)) (fArgs.push fArg) + else + collectEReplacements (b.instantiate1 arg) args ctx eReplacements (fArgs.push arg) + +| _, arg::args, _, _, _ => panic! "TODO(dselsam): this case not yet handled" + +def preprocessForOutParams (env : Environment) (goalType : Expr) : Context × Expr × Array (Level × Level) × Array (Expr × Expr) := +if !goalType.hasMVar && goalType.getAppFn.isConst && !hasOutParams env goalType.getAppFn.constName! +then ({}, goalType, #[], #[]) +else + let ⟨lctx, bodyGoalType, locals⟩ := introduceLocals 0 {} #[] goalType; + let f := goalType.getAppFn; + let fArgs := goalType.getAppArgs; + if !(f.isConst && isClass env f.constName!) + then ({}, goalType, #[], #[]) + else + let ⟨ctx, uReplacements, CLevels⟩ := collectUReplacements f.constLevels! {} #[] #[]; + let f := if uReplacements.isEmpty then f else mkConst f.constName! CLevels.toList; + let fType := + match env.find f.constName! with + | none => panic! "found constant not in the environment" + | some cInfo => cInfo.instantiateTypeLevelParams CLevels.toList; + let (ctx, eReplacements, fArgs) := collectEReplacements env lctx locals fType fArgs.toList ctx #[] #[]; -- TODO: avoid fArgs.toList + (ctx, lctx.mkForall locals $ mkAppN f fArgs, uReplacements, eReplacements) + +def synth (goalType₀ : Expr) (fuel : Nat := 100000) : TCMethod Expr := +do env ← get >>= λ ϕ => pure ϕ.env; + let ⟨ctx₀, goalType, uReplacements, eReplacements⟩ := preprocessForOutParams env goalType₀; + let ⟨mvar, ctx⟩ := (Context.eNewMeta goalType).run ctx₀; + let anormSubgoal : Expr := Context.αNorm goalType; + newSubgoal Waiter.root ctx anormSubgoal mvar; + modify $ λ ϕ => { mainMVar := mvar .. ϕ }; + ⟨instVal, instType⟩ ← synthCore ctx₀ goalType fuel; + match (Context.eUnify goalType₀ instType).run ctx with + | EStateM.Result.error msg _ => throw $ "outParams do not match: " ++ toString goalType₀ ++ " ≠ " ++ toString instType + | EStateM.Result.ok _ ctx => do + let instVal : Expr := ctx.eInstantiate instVal; + when (Context.eHasTmpMVar instVal) $ throw "synthesized instance has mvar"; + pure instVal + +end TypeClass +end Lean diff --git a/stage0/src/Init/Lean/Util.lean b/stage0/src/Init/Lean/Util.lean new file mode 100644 index 0000000000..0a9bd23abb --- /dev/null +++ b/stage0/src/Init/Lean/Util.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2019 Sebastian Ullrich. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sebastian Ullrich +-/ +prelude +import Init.System.IO +import Init.Lean.Position + +namespace Lean + +/-- Print and accumulate run time of `act` when Option `profiler` is set to `true`. -/ +@[extern 5 "lean_lean_profileit"] +constant profileit {α : Type} (category : @& String) (pos : @& Position) (act : IO α) : IO α := act +def profileitPure {α : Type} (category : String) (pos : Position) (fn : Unit → α) : IO α := +profileit category pos $ IO.lazyPure fn + +end Lean diff --git a/stage0/src/Init/Lean/WHNF.lean b/stage0/src/Init/Lean/WHNF.lean new file mode 100644 index 0000000000..4cd439d094 --- /dev/null +++ b/stage0/src/Init/Lean/WHNF.lean @@ -0,0 +1,394 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Lean.Declaration +import Init.Lean.LocalContext + +namespace Lean +namespace WHNF +/- =========================== + Smart unfolding support + =========================== -/ + +def smartUnfoldingSuffix := "_sunfold" + +@[inline] def mkSmartUnfoldingNameFor (n : Name) : Name := +mkNameStr n smartUnfoldingSuffix + +/- =========================== + Helper functions + =========================== -/ + +@[inline] +def matchConstAux {α : Type} {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (e : Expr) (failK : Unit → m α) (k : ConstantInfo → List Level → m α) : m α := +match e with +| Expr.const name lvls _ => do + (some cinfo) ← getConst name | failK (); + k cinfo lvls +| _ => failK () + +/- =========================== + Helper functions for reducing recursors + =========================== -/ + +private def getFirstCtor {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (d : Name) : m (Option Name) := +do some (ConstantInfo.inductInfo { ctors := ctor::_, ..}) ← getConst d | pure none; + pure (some ctor) + +private def mkNullaryCtor {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (type : Expr) (nparams : Nat) : m (Option Expr) := +match type.getAppFn with +| Expr.const d lvls _ => do + (some ctor) ← getFirstCtor getConst d | pure none; + pure $ mkAppN (mkConst ctor lvls) (type.getAppArgs.shrink nparams) +| _ => pure none + +private def toCtorIfLit : Expr → Expr +| Expr.lit (Literal.natVal v) _ => + if v == 0 then mkConst `Nat.zero + else mkApp (mkConst `Nat.succ) (mkNatLit (v-1)) +| e => e + +private def getRecRuleFor (rec : RecursorVal) (major : Expr) : Option RecursorRule := +match major.getAppFn with +| Expr.const fn _ _ => rec.rules.find $ fun r => r.ctor == fn +| _ => none + +@[specialize] private def toCtorWhenK {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (whnf : Expr → m Expr) + (inferType : Expr → m Expr) + (isDefEq : Expr → Expr → m Bool) + (rec : RecursorVal) (major : Expr) : m (Option Expr) := +do majorType ← inferType major; + majorType ← whnf majorType; + let majorTypeI := majorType.getAppFn; + if !majorTypeI.isConstOf rec.getInduct then + pure none + else if majorType.hasExprMVar && majorType.getAppArgs.anyFrom rec.nparams Expr.hasExprMVar then + pure none + else do + (some newCtorApp) ← mkNullaryCtor getConst majorType rec.nparams | pure none; + newType ← inferType newCtorApp; + defeq ← isDefEq majorType newType; + pure $ if defeq then newCtorApp else none + +/-- Auxiliary function for reducing recursor applications. -/ +@[specialize] def reduceRec {α} {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (whnf : Expr → m Expr) + (inferType : Expr → m Expr) + (isDefEq : Expr → Expr → m Bool) + (rec : RecursorVal) (recLvls : List Level) (recArgs : Array Expr) + (failK : Unit → m α) (successK : Expr → m α) : m α := +let majorIdx := rec.getMajorIdx; +if h : majorIdx < recArgs.size then do + let major := recArgs.get ⟨majorIdx, h⟩; + major ← whnf major; + major ← + if !rec.k then + pure major + else do { + newMajor ← toCtorWhenK getConst whnf inferType isDefEq rec major; + pure (newMajor.getD major) + }; + let major := toCtorIfLit major; + match getRecRuleFor rec major with + | some rule => + let majorArgs := major.getAppArgs; + if recLvls.length != rec.lparams.length then + failK () + else + let rhs := rule.rhs.instantiateLevelParams rec.lparams recLvls; + -- Apply parameters, motives and minor premises from recursor application. + let rhs := mkAppRange rhs 0 (rec.nparams+rec.nmotives+rec.nminors) recArgs; + /- The number of parameters in the constructor is not necessarily + equal to the number of parameters in the recursor when we have + nested inductive types. -/ + let nparams := majorArgs.size - rule.nfields; + let rhs := mkAppRange rhs nparams majorArgs.size majorArgs; + let rhs := mkAppRange rhs (majorIdx + 1) recArgs.size recArgs; + successK rhs + | none => failK () +else + failK () + +@[specialize] def isRecStuck {m : Type → Type} [Monad m] + (whnf : Expr → m Expr) + (isStuck : Expr → m (Option Expr)) + (rec : RecursorVal) (recLvls : List Level) (recArgs : Array Expr) : m (Option Expr) := +if rec.k then + -- TODO: improve this case + pure none +else do + let majorIdx := rec.getMajorIdx; + if h : majorIdx < recArgs.size then do + let major := recArgs.get ⟨majorIdx, h⟩; + major ← whnf major; + isStuck major + else + pure none + +/- =========================== + Helper functions for reducing Quot.lift and Quot.ind + =========================== -/ + +/-- Auxiliary function for reducing `Quot.lift` and `Quot.ind` applications. -/ +@[specialize] def reduceQuotRec {α} {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (whnf : Expr → m Expr) + (rec : QuotVal) (recLvls : List Level) (recArgs : Array Expr) + (failK : Unit → m α) (successK : Expr → m α) : m α := +let process (majorPos argPos : Nat) : m α := + if h : majorPos < recArgs.size then do + let major := recArgs.get ⟨majorPos, h⟩; + major ← whnf major; + match major with + | Expr.app (Expr.app (Expr.app (Expr.const majorFn _ _) _ _) _ _) majorArg _ => do + some (ConstantInfo.quotInfo { kind := QuotKind.ctor, .. }) ← getConst majorFn | failK (); + let f := recArgs.get! argPos; + let r := mkApp f majorArg; + let recArity := majorPos + 1; + successK $ mkAppRange r recArity recArgs.size recArgs + | _ => failK () + else + failK (); +match rec.kind with +| QuotKind.lift => process 5 3 +| QuotKind.ind => process 4 3 +| _ => failK () + +@[specialize] def isQuotRecStuck {m : Type → Type} [Monad m] + (whnf : Expr → m Expr) + (isStuck : Expr → m (Option Expr)) + (rec : QuotVal) (recLvls : List Level) (recArgs : Array Expr) : m (Option Expr) := +let process (majorPos : Nat) : m (Option Expr) := + if h : majorPos < recArgs.size then do + let major := recArgs.get ⟨majorPos, h⟩; + major ← whnf major; + isStuck major + else + pure none; +match rec.kind with +| QuotKind.lift => process 5 +| QuotKind.ind => process 4 +| _ => pure none + +/- =========================== + Helper function for extracting "stuck term" + =========================== -/ + +/-- Return `some (Expr.mvar mvarId)` if metavariable `mvarId` is blocking reduction. -/ +@[specialize] partial def getStuckMVar {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (whnf : Expr → m Expr) + : Expr → m (Option Expr) +| Expr.mdata _ e _ => getStuckMVar e +| Expr.proj _ _ e _ => do e ← whnf e; getStuckMVar e +| e@(Expr.mvar _ _) => pure (some e) +| e@(Expr.app f _ _) => + let f := f.getAppFn; + match f with + | Expr.mvar _ _ => pure (some f) + | Expr.const fName fLvls _ => do + cinfo? ← getConst fName; + match cinfo? with + | some $ ConstantInfo.recInfo rec => isRecStuck whnf getStuckMVar rec fLvls e.getAppArgs + | some $ ConstantInfo.quotInfo rec => isQuotRecStuck whnf getStuckMVar rec fLvls e.getAppArgs + | _ => pure none + | _ => pure none +| _ => pure none + +/- =========================== + Weak Head Normal Form auxiliary combinators + =========================== -/ + +/-- Auxiliary combinator for handling easy WHNF cases. It takes a function for handling the "hard" cases as an argument -/ +@[specialize] partial def whnfEasyCases {m : Type → Type} [Monad m] + (getLocalDecl : Name → m LocalDecl) + (getMVarAssignment : Name → m (Option Expr)) + : Expr → (Expr → m Expr) → m Expr +| e@(Expr.forallE _ _ _ _), _ => pure e +| e@(Expr.lam _ _ _ _), _ => pure e +| e@(Expr.sort _ _), _ => pure e +| e@(Expr.lit _ _), _ => pure e +| e@(Expr.bvar _ _), _ => unreachable! +| Expr.mdata _ e _, k => whnfEasyCases e k +| e@(Expr.letE _ _ _ _ _), k => k e +| e@(Expr.fvar fvarId _), k => do + decl ← getLocalDecl fvarId; + match decl.value? with + | none => pure e + | some v => whnfEasyCases v k +| e@(Expr.mvar mvarId _), k => do + v? ← getMVarAssignment mvarId; + match v? with + | some v => whnfEasyCases v k + | none => pure e +| e@(Expr.const _ _ _), k => k e +| e@(Expr.app _ _ _), k => k e +| e@(Expr.proj _ _ _ _), k => k e +| Expr.localE _ _ _ _, _ => unreachable! + +/-- Return true iff term is of the form `idRhs ...` -/ +private def isIdRhsApp (e : Expr) : Bool := +e.isAppOf `idRhs + +/-- (@idRhs T f a_1 ... a_n) ==> (f a_1 ... a_n) -/ +private def extractIdRhs (e : Expr) : Expr := +if !isIdRhsApp e then e +else + let args := e.getAppArgs; + if args.size < 2 then e + else mkAppRange (args.get! 1) 2 args.size args + +@[specialize] private def deltaDefinition {α} (c : ConstantInfo) (lvls : List Level) + (failK : Unit → α) (successK : Expr → α) : α := +if c.lparams.length != lvls.length then failK () +else + let val := c.instantiateValueLevelParams lvls; + successK (extractIdRhs val) + +@[specialize] private def deltaBetaDefinition {α} (c : ConstantInfo) (lvls : List Level) (revArgs : Array Expr) + (failK : Unit → α) (successK : Expr → α) : α := +if c.lparams.length != lvls.length then failK () +else + let val := c.instantiateValueLevelParams lvls; + let val := val.betaRev revArgs; + successK (extractIdRhs val) + +/-- + Apply beta-reduction, zeta-reduction (i.e., unfold let local-decls), iota-reduction, + expand let-expressions, expand assigned meta-variables. + + This method does *not* apply delta-reduction at the head symbol `f` unless `isAuxDef? f` returns true. + Reason: we want to perform these reductions lazily at `isDefEq`. -/ +@[specialize] partial def whnfCore {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (isAuxDef? : Name → m Bool) + (whnf : Expr → m Expr) + (inferType : Expr → m Expr) + (isDefEq : Expr → Expr → m Bool) + (getLocalDecl : Name → m LocalDecl) + (getMVarAssignment : Name → m (Option Expr)) : Expr → m Expr +| e => whnfEasyCases getLocalDecl getMVarAssignment e $ fun e => + match e with + | e@(Expr.const _ _ _) => pure e + | e@(Expr.letE _ _ v b _) => whnfCore $ b.instantiate1 v + | e@(Expr.app f _ _) => do + let f := f.getAppFn; + f' ← whnfCore f; + if f'.isLambda then + let revArgs := e.getAppRevArgs; + whnfCore $ f.betaRev revArgs + else do + let done : Unit → m Expr := fun _ => + if f == f' then pure e else pure $ e.updateFn f'; + matchConstAux getConst f' done $ fun cinfo lvls => + match cinfo with + | ConstantInfo.recInfo rec => reduceRec getConst whnf inferType isDefEq rec lvls e.getAppArgs done whnfCore + | ConstantInfo.quotInfo rec => reduceQuotRec getConst whnf rec lvls e.getAppArgs done whnfCore + | c@(ConstantInfo.defnInfo _) => do + unfold? ← isAuxDef? c.name; + if unfold? then + deltaBetaDefinition c lvls e.getAppRevArgs done whnfCore + else + done () + | _ => done () + | e@(Expr.proj _ i c _) => do + c ← whnf c; + matchConstAux getConst c.getAppFn (fun _ => pure e) $ fun cinfo lvls => + match cinfo with + | ConstantInfo.ctorInfo ctorVal => pure $ c.getArgD (ctorVal.nparams + i) e + | _ => pure e + | _ => unreachable! + +/-- + Similar to `whnfCore`, but uses `synthesizePending` to (try to) synthesize metavariables + that are blocking reduction. -/ +@[specialize] private partial def whnfCoreUnstuck {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (isAuxDef? : Name → m Bool) + (whnf : Expr → m Expr) + (inferType : Expr → m Expr) + (isDefEq : Expr → Expr → m Bool) + (synthesizePending : Expr → m Bool) + (getLocalDecl : Name → m LocalDecl) + (getMVarAssignment : Name → m (Option Expr)) + : Expr → m Expr +| e => do + e ← whnfCore getConst isAuxDef? whnf inferType isDefEq getLocalDecl getMVarAssignment e; + (some mvar) ← getStuckMVar getConst whnf e | pure e; + succeeded ← synthesizePending mvar; + if succeeded then whnfCoreUnstuck e else pure e + +/-- Unfold definition using "smart unfolding" if possible. -/ +@[specialize] def unfoldDefinitionAux {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (isAuxDef? : Name → m Bool) + (whnf : Expr → m Expr) + (inferType : Expr → m Expr) + (isDefEq : Expr → Expr → m Bool) + (synthesizePending : Expr → m Bool) + (getLocalDecl : Name → m LocalDecl) + (getMVarAssignment : Name → m (Option Expr)) + (e : Expr) : m (Option Expr) := +match e with +| Expr.app f _ _ => + matchConstAux getConst f.getAppFn (fun _ => pure none) $ fun fInfo fLvls => + if fInfo.lparams.length != fLvls.length then pure none + else do + fAuxInfo? ← getConst (mkSmartUnfoldingNameFor fInfo.name); + match fAuxInfo? with + | some $ fAuxInfo@(ConstantInfo.defnInfo _) => + deltaBetaDefinition fAuxInfo fLvls e.getAppRevArgs (fun _ => pure none) $ fun e₁ => do + e₂ ← whnfCoreUnstuck getConst isAuxDef? whnf inferType isDefEq synthesizePending getLocalDecl getMVarAssignment e₁; + if isIdRhsApp e₂ then + pure (some (extractIdRhs e₂)) + else + pure none + | _ => + if fInfo.hasValue then + deltaBetaDefinition fInfo fLvls e.getAppRevArgs (fun _ => pure none) (fun e => pure (some e)) + else + pure none +| Expr.const name lvls _ => do + (some (cinfo@(ConstantInfo.defnInfo _))) ← getConst name | pure none; + deltaDefinition cinfo lvls (fun _ => pure none) (fun e => pure (some e)) +| _ => pure none + +/- Reference implementation for `whnf`. It does not cache any results. + + How to use: + - `getConst constName` retrieves `constName` from environment. Caller may make definitions opaque by returning `none`. + - `isAuxDef? constName` returns `true` is `constName` is an auxiliary declaration automatically generated by Lean and + used by equation compiler, and must be eagerly reduced by `whnfCore`. This method is usually implemented using `isAuxRecursor`. + - `synthesizePending` is used to (try to) synthesize synthetic metavariables that may be blocking reduction. + + The other parameters should be self explanatory. -/ +@[specialize] partial def whnfMain {m : Type → Type} [Monad m] + (getConst : Name → m (Option ConstantInfo)) + (isAuxDef? : Name → m Bool) + (inferType : Expr → m Expr) + (isDefEq : Expr → Expr → m Bool) + (synthesizePending : Expr → m Bool) + (getLocalDecl : Name → m LocalDecl) + (getMVarAssignment : Name → m (Option Expr)) + : Expr → m Expr +| e => do + e ← whnfCore getConst isAuxDef? whnfMain inferType isDefEq getLocalDecl getMVarAssignment e; + e? ← unfoldDefinitionAux getConst isAuxDef? whnfMain inferType isDefEq synthesizePending getLocalDecl getMVarAssignment e; + match e? with + | some e => whnfMain e + | none => pure e + +end WHNF +end Lean diff --git a/stage0/src/Init/Makefile.in b/stage0/src/Init/Makefile.in new file mode 100644 index 0000000000..3db0c85dcf --- /dev/null +++ b/stage0/src/Init/Makefile.in @@ -0,0 +1,62 @@ +# Copyright (c) 2018 Simon Hudon. All rights reserved. +# Released under Apache 2.0 license as described in the file LICENSE. +# Authors: Simon Hudon, Sebastian Ullrich, Leonardo de Moura +LEAN = ../../bin/lean +LEANC = ../../bin/leanc +SRCS = $(shell find . -name '*.lean') +OBJS = $(SRCS:.lean=.olean) +DEPS = $(SRCS:.lean=.depend) +OPTS = @LEAN_EXTRA_MAKE_OPTS@ +STAGE0_DIR = ../../stage0 +STAGE1_DIR = ../stage1 +ifndef STAGE1_OUT +$(error "`STAGE1_OUT` must be set (use cmake)") +endif +# ensure deterministic ordering +CS_CORE=$(addprefix Init/,$(sort $(patsubst %.lean,%.c,$(SRCS)))) + +SHELL = /usr/bin/env bash -eo pipefail + +.PHONY: all clean + +all: $(OBJS) + +depends: $(DEPS) + +%.depend: %.lean +# use separate assignment to ensure failure propagation + @deps=`$(LEAN) --deps $< | python relative.py`; echo $(<:.lean=.olean): $$deps > $@ + +%.olean: %.lean %.depend + @echo "[ ] Building $<" + @mkdir -p $(STAGE1_DIR)/Init/$(@D) + $(LEAN) $(OPTS) --make --c="$(STAGE1_DIR)/Init/$*.c.tmp" $< +# create the .c file atomically + mv "$(STAGE1_DIR)/Init/$*.c.tmp" "$(STAGE1_DIR)/Init/$*.c" +# make sure the .olean file is newer than the .depend file to prevent infinite make cycles + @touch $*.olean + +$(STAGE1_DIR)/Init/%.c: %.olean + @ + +$(STAGE1_OUT)/Init/%.o: $(STAGE1_DIR)/Init/%.c + @echo "[ ] Building $<" + @mkdir -p "$(@D)" + $(LEANC) -c -o $@ $< $(LEANC_OPTS) + +$(STAGE1_OUT)/libleanstdlib.a: $(addprefix $(STAGE1_OUT)/Init/,$(patsubst %.lean,%.o,$(SRCS))) + @rm -f $@ + @ar rcs $@ $^ + +update-stage0: + -rm -r $(STAGE0_DIR) + -mkdir $(STAGE0_DIR) + cp -R $(STAGE1_DIR) $(STAGE0_DIR)/stdlib + echo "add_library (stage0 OBJECT $(CS_CORE))" > $(STAGE0_DIR)/stdlib/CMakeLists.txt +# don't copy untracked crap + cd ..; git ls-files -z . | xargs -0 -I '{}' bash -c 'mkdir -p `dirname ../stage0/src/{}` && cp {} ../stage0/src/{}' + -git add $(STAGE0_DIR) + +.PRECIOUS: %.depend $(STAGE1_DIR)/Init/%.c + +include $(DEPS) diff --git a/stage0/src/Init/System.lean b/stage0/src/Init/System.lean new file mode 100644 index 0000000000..0585f2c7ff --- /dev/null +++ b/stage0/src/Init/System.lean @@ -0,0 +1,8 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.System.IO +import Init.System.Platform diff --git a/stage0/src/Init/System/FilePath.lean b/stage0/src/Init/System/FilePath.lean new file mode 100644 index 0000000000..fab5c64d5c --- /dev/null +++ b/stage0/src/Init/System/FilePath.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.System.Platform +import Init.Data.String.Basic + +namespace System +namespace FilePath +open Platform + +/-- The character that separates directories. In the case where more than one character is possible, `pathSeparator` is the 'ideal' one. -/ +def pathSeparator : Char := +if isWindows then '\\' else '/' + +/-- The list of all possible separators. -/ +def pathSeparators : List Char := +if isWindows then ['\\', '/'] else ['/'] + +/-- The character that is used to separate the entries in the $PATH environment variable. -/ +def searchPathSeparator : Char := +if isWindows then ';' else ':' + +/-- The list of all possible separators. -/ +def searchPathSeparators : List Char := +if isWindows then [';', ':'] else [':'] + +def splitSearchPath (s : String) : List String := +s.split (fun c => searchPathSeparators.elem c) + +/-- File extension character -/ +def extSeparator : Char := +'.' + +/-- Case-insensitive file system -/ +def isCaseInsensitive : Bool := +isWindows || isOSX + +def normalizePath (fname : String) : String := +if pathSeparators.length == 1 && !isCaseInsensitive then fname +else fname.map (fun c => + if pathSeparators.any (fun c' => c == c') then pathSeparator + -- else if isCaseInsensitive then c.toLower + else c) + +def dirName (fname : String) : String := +let fname := normalizePath fname; +match fname.revPosOf pathSeparator with +| none => "." +| some pos => { Substring . str := fname, startPos := 0, stopPos := pos }.toString + +end FilePath +end System diff --git a/stage0/src/Init/System/IO.lean b/stage0/src/Init/System/IO.lean new file mode 100644 index 0000000000..a6b04631ae --- /dev/null +++ b/stage0/src/Init/System/IO.lean @@ -0,0 +1,297 @@ +/- +Copyright (c) 2017 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Luke Nelson, Jared Roesch, Leonardo de Moura, Sebastian Ullrich +-/ +prelude +import Init.Control.EState +import Init.Data.String.Basic +import Init.System.FilePath + +/-- Like https://hackage.haskell.org/package/ghc-Prim-0.5.2.0/docs/GHC-Prim.html#t:RealWorld. + Makes sure we never reorder `IO` operations. + + TODO: mark opaque -/ +def IO.RealWorld : Type := Unit + +/- TODO(Leo): mark it as an opaque definition. Reason: prevent + functions defined in other modules from accessing `IO.RealWorld`. + We don't want action such as + ``` + def getWorld : IO (IO.RealWorld) := get + ``` +-/ +def EIO (ε : Type) : Type → Type := EStateM ε IO.RealWorld + +instance (ε : Type) : Monad (EIO ε) := inferInstanceAs (Monad (EStateM ε IO.RealWorld)) +instance (ε : Type) : MonadExcept ε (EIO ε) := inferInstanceAs (MonadExcept ε (EStateM ε IO.RealWorld)) +instance (α ε : Type) : HasOrelse (EIO ε α) := ⟨MonadExcept.orelse⟩ +instance {ε : Type} {α : Type} [Inhabited ε] : Inhabited (EIO ε α) := +inferInstanceAs (Inhabited (EStateM ε IO.RealWorld α)) + +/- +In the future, we may want to give more concrete data +like in https://doc.rust-lang.org/std/IO/enum.ErrorKind.html +-/ +def IO.Error := String + +instance : HasToString IO.Error := inferInstanceAs (HasToString String) +instance : Inhabited IO.Error := inferInstanceAs (Inhabited String) + +def IO.userError (s : String) : IO.Error := +s + +@[export lean_io_error_to_string] +def IO.Error.toString : IO.Error → String := +id + +abbrev IO : Type → Type := EIO IO.Error + +section +/- After we inline `EState.run'`, the closed term `((), ())` is generated, where the second `()` + represents the "initial world". We don't want to cache this closed term. So, we disable + the "extract closed terms" optimization. -/ +set_option compiler.extract_closed false +@[inline] unsafe def unsafeIO {α : Type} (fn : IO α) : Except IO.Error α := +match fn.run () with +| EStateM.Result.ok a _ => Except.ok a +| EStateM.Result.error e _ => Except.error e + +end + +@[extern "lean_io_timeit"] +constant timeit {α : Type} (msg : @& String) (fn : IO α) : IO α := arbitrary _ + +@[extern "lean_io_allocprof"] +constant allocprof {α : Type} (msg : @& String) (fn : IO α) : IO α := arbitrary _ + +/- Programs can execute IO actions during initialization that occurs before + the `main` function is executed. The attribute `[init ]` specifies + which IO action is executed to set the value of an opaque constant. + + The action `initializing` returns `true` iff it is invoked during initialization. -/ +@[extern "lean_io_initializing"] +constant IO.initializing : IO Bool := arbitrary _ + +abbrev monadIO (m : Type → Type) := HasMonadLiftT IO m + +namespace IO + +def ofExcept {ε α : Type} [HasToString ε] (e : Except ε α) : IO α := +match e with +| Except.ok a => pure a +| Except.error e => throw (IO.userError (toString e)) + +def lazyPure {α : Type} (fn : Unit → α) : IO α := +pure (fn ()) + +inductive Fs.Mode +| read | write | readWrite | append + +constant Fs.handle : Type := Unit + +namespace Prim +open Fs + +@[specialize] partial def iterate {α β : Type} : α → (α → IO (Sum α β)) → IO β +| a, f => + do v ← f a; + match v with + | Sum.inl a => iterate a f + | Sum.inr b => pure b + +@[extern "lean_io_prim_put_str"] +constant putStr (s: @& String) : IO Unit := arbitrary _ +@[extern "lean_io_prim_read_text_file"] +constant readTextFile (s : @& String) : IO String := arbitrary _ +@[extern "lean_io_prim_get_line"] +constant getLine : IO String := arbitrary _ +@[extern "lean_io_prim_handle_mk"] +constant handle.mk (s : @& String) (m : Mode) (bin : Bool := false) : IO handle := arbitrary _ +@[extern "lean_io_prim_handle_is_eof"] +constant handle.isEof (h : @& handle) : IO Bool := arbitrary _ +@[extern "lean_io_prim_handle_flush"] +constant handle.flush (h : @& handle) : IO Unit := arbitrary _ +@[extern "lean_io_prim_handle_close"] +constant handle.close (h : @& handle) : IO Unit := arbitrary _ +-- TODO: replace `String` with byte buffer +-- constant handle.read : handle → Nat → EIO String +-- constant handle.write : handle → String → EIO Unit +@[extern "lean_io_prim_handle_get_line"] +constant handle.getLine (h : @& handle) : IO String := arbitrary _ + +@[extern "lean_io_getenv"] +constant getEnv (var : @& String) : IO (Option String) := arbitrary _ +@[extern "lean_io_realpath"] +constant realPath (fname : String) : IO String := arbitrary _ +@[extern "lean_io_is_dir"] +constant isDir (fname : @& String) : IO Bool := arbitrary _ +@[extern "lean_io_file_exists"] +constant fileExists (fname : @& String) : IO Bool := arbitrary _ +@[extern "lean_io_app_dir"] +constant appPath : IO String := arbitrary _ + +@[inline] def liftIO {m : Type → Type} {α : Type} [monadIO m] (x : IO α) : m α := +monadLift x +end Prim + +section +variables {m : Type → Type} [Monad m] [monadIO m] + +private def putStr : String → m Unit := +Prim.liftIO ∘ Prim.putStr + +def print {α} [HasToString α] (s : α) : m Unit := putStr ∘ toString $ s +def println {α} [HasToString α] (s : α) : m Unit := print s *> putStr "\n" +def readTextFile : String → m String := Prim.liftIO ∘ Prim.readTextFile +def getEnv : String → m (Option String) := Prim.liftIO ∘ Prim.getEnv +def realPath : String → m String := Prim.liftIO ∘ Prim.realPath +def isDir : String → m Bool := Prim.liftIO ∘ Prim.isDir +def fileExists : String → m Bool := Prim.liftIO ∘ Prim.fileExists +def appPath : m String := Prim.liftIO Prim.appPath + +def appDir : m String := +do p ← appPath; + realPath (System.FilePath.dirName p) + +end + +namespace Fs +variables {m : Type → Type} [Monad m] [monadIO m] + +def handle.mk (s : String) (Mode : Mode) (bin : Bool := false) : m handle := Prim.liftIO (Prim.handle.mk s Mode bin) +def handle.isEof : handle → m Bool := Prim.liftIO ∘ Prim.handle.isEof +def handle.flush : handle → m Unit := Prim.liftIO ∘ Prim.handle.flush +def handle.close : handle → m Unit := Prim.liftIO ∘ Prim.handle.flush +-- def handle.read (h : handle) (bytes : Nat) : m String := Prim.liftEIO (Prim.handle.read h bytes) +-- def handle.write (h : handle) (s : String) : m Unit := Prim.liftEIO (Prim.handle.write h s) +def handle.getLine : handle → m String := Prim.liftIO ∘ Prim.handle.getLine + +/- +def getChar (h : handle) : m Char := +do b ← h.read 1, + if b.isEmpty then fail "getChar failed" + else pure b.mkIterator.curr +-/ + +-- def handle.putChar (h : handle) (c : Char) : m Unit := +-- h.write (toString c) + +-- def handle.putStr (h : handle) (s : String) : m Unit := +-- h.write s + +-- def handle.putStrLn (h : handle) (s : String) : m Unit := +-- h.putStr s *> h.putStr "\n" + +def handle.readToEnd (h : handle) : m String := +Prim.liftIO $ Prim.iterate "" $ fun r => do + done ← h.isEof; + if done + then pure (Sum.inr r) -- stop + else do + -- HACK: use less efficient `getLine` while `read` is broken + c ← h.getLine; + pure $ Sum.inl (r ++ c) -- continue + +def readFile (fname : String) (bin := false) : m String := +do h ← handle.mk fname Mode.read bin; + r ← h.readToEnd; + h.close; + pure r + +-- def writeFile (fname : String) (data : String) (bin := false) : m Unit := +-- do h ← handle.mk fname Mode.write bin, +-- h.write data, +-- h.close + +end Fs + +-- constant stdin : IO Fs.handle +-- constant stderr : IO Fs.handle +-- constant stdout : IO Fs.handle + +/- +namespace Proc +def child : Type := +monadIOProcess.child ioCore + +def child.stdin : child → handle := +monadIOProcess.stdin + +def child.stdout : child → handle := +monadIOProcess.stdout + +def child.stderr : child → handle := +monadIOProcess.stderr + +def spawn (p : IO.process.spawnArgs) : IO child := +monadIOProcess.spawn ioCore p + +def wait (c : child) : IO Nat := +monadIOProcess.wait c + +end Proc +-/ + + +/- References -/ +constant RefPointed (α : Type) : PointedType := arbitrary _ +def Ref (α : Type) : Type := (RefPointed α).type +instance (α : Type) : Inhabited (Ref α) := ⟨(RefPointed α).val⟩ + +namespace Prim +@[extern "lean_io_mk_ref"] +constant mkRef {α : Type} (a : α) : IO (Ref α) := arbitrary _ +@[extern "lean_io_ref_get"] +constant Ref.get {α : Type} (r : @& Ref α) : IO α := arbitrary _ +@[extern "lean_io_ref_set"] +constant Ref.set {α : Type} (r : @& Ref α) (a : α) : IO Unit := arbitrary _ +@[extern "lean_io_ref_swap"] +constant Ref.swap {α : Type} (r : @& Ref α) (a : α) : IO α := arbitrary _ +@[extern "lean_io_ref_reset"] +constant Ref.reset {α : Type} (r : @& Ref α) : IO Unit := arbitrary _ +end Prim + +section +variables {m : Type → Type} [Monad m] [monadIO m] +@[inline] def mkRef {α : Type} (a : α) : m (Ref α) := Prim.liftIO (Prim.mkRef a) +@[inline] def Ref.get {α : Type} (r : Ref α) : m α := Prim.liftIO (Prim.Ref.get r) +@[inline] def Ref.set {α : Type} (r : Ref α) (a : α) : m Unit := Prim.liftIO (Prim.Ref.set r a) +@[inline] def Ref.swap {α : Type} (r : Ref α) (a : α) : m α := Prim.liftIO (Prim.Ref.swap r a) +@[inline] def Ref.reset {α : Type} (r : Ref α) : m Unit := Prim.liftIO (Prim.Ref.reset r) +@[inline] def Ref.modify {α : Type} (r : Ref α) (f : α → α) : m Unit := +do v ← r.get; + r.reset; + r.set (f v) +end +end IO + +/- +/-- Run the external process specified by `args`. + + The process will run to completion with its output captured by a pipe, and + read into `String` which is then returned. -/ +def IO.cmd (args : IO.process.spawnArgs) : IO String := +do child ← IO.Proc.spawn { stdout := IO.process.stdio.piped, ..args }, + s ← IO.Fs.readToEnd child.stdout, + IO.Fs.close child.stdout, + exitv ← IO.Proc.wait child, + if exitv ≠ 0 then IO.fail $ "process exited with status " ++ repr exitv else pure (), + pure s +-/ + +universe u + +/-- Typeclass used for presenting the output of an `#eval` command. -/ +class HasEval (α : Type u) := +(eval : α → IO Unit) + +instance HasRepr.HasEval {α : Type u} [HasRepr α] : HasEval α := +⟨fun a => IO.println (repr a)⟩ + +instance IO.HasEval {α : Type} [HasEval α] : HasEval (IO α) := +⟨fun x => do a ← x; HasEval.eval a⟩ + +-- special case: do not print `()` +instance IOUnit.HasEval : HasEval (IO Unit) := +⟨fun x => x⟩ diff --git a/stage0/src/Init/System/Platform.lean b/stage0/src/Init/System/Platform.lean new file mode 100644 index 0000000000..379b97e142 --- /dev/null +++ b/stage0/src/Init/System/Platform.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2018 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.Nat.Basic + +namespace System +namespace Platform + +@[extern "lean_system_platform_nbits"] +constant getNumBits : Unit → Nat := arbitrary _ + +@[extern "lean_system_platform_windows"] +constant getIsWindows : Unit → Bool := arbitrary _ + +@[extern "lean_system_platform_osx"] +constant getIsOSX : Unit → Bool := arbitrary _ + +def numBits : Nat := getNumBits () +def isWindows : Bool := getIsWindows () +def isOSX : Bool := getIsOSX () + +end Platform +end System diff --git a/stage0/src/Init/Util.lean b/stage0/src/Init/Util.lean new file mode 100644 index 0000000000..158fef2ab7 --- /dev/null +++ b/stage0/src/Init/Util.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2019 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import Init.Data.String.Basic +import Init.Data.ToString + +universes u v +/- debugging helper functions -/ +@[neverExtract, extern "lean_dbg_trace"] +def dbgTrace {α : Type u} (s : String) (f : Unit → α) : α := +f () + +/- Display the given message if `a` is shared, that is, RC(a) > 1 -/ +@[neverExtract, extern "lean_dbg_trace_if_shared"] +def dbgTraceIfShared {α : Type u} (s : String) (a : α) : α := +a + +@[extern "lean_dbg_sleep"] +def dbgSleep {α : Type u} (ms : UInt32) (f : Unit → α) : α := +f () + +@[extern c inline "#4"] +unsafe def unsafeCast {α : Type u} {β : Type v} [Inhabited β] (a : α) : β := arbitrary _ + +@[neverExtract, extern c inline "lean_panic_fn(#3)"] +constant panic {α : Type u} [Inhabited α] (msg : String) : α := arbitrary _ + +@[noinline] private def mkPanicMessage (modName : String) (line col : Nat) (msg : String) : String := +"PANIC at " ++ modName ++ ":" ++ toString line ++ ":" ++ toString col ++ ": " ++ msg + +@[neverExtract, inline] def panicWithPos {α : Type u} [Inhabited α] (modName : String) (line col : Nat) (msg : String) : α := +panic (mkPanicMessage modName line col msg) + +-- TODO: should be a macro +@[neverExtract, noinline, nospecialize] def unreachable! {α : Type u} [Inhabited α] : α := +panic! "unreachable" diff --git a/stage0/src/Init/WF.lean b/stage0/src/Init/WF.lean new file mode 100644 index 0000000000..63d1317b3e --- /dev/null +++ b/stage0/src/Init/WF.lean @@ -0,0 +1,310 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import Init.Data.Nat.Basic + +universes u v + +set_option codegen false + +inductive Acc {α : Sort u} (r : α → α → Prop) : α → Prop +| intro (x : α) (h : ∀ y, r y x → Acc y) : Acc x + +@[elabAsEliminator, inline, reducible] +def Acc.ndrec.{u1, u2} {α : Sort u2} {r : α → α → Prop} {C : α → Sort u1} + (m : ∀ (x : α) (h : ∀ (y : α), r y x → Acc r y), (∀ (y : α) (a : r y x), C y) → C x) + {a : α} (n : Acc r a) : C a := +@Acc.rec α r (fun α _ => C α) m a n + +@[elabAsEliminator, inline, reducible] +def Acc.ndrecOn.{u1, u2} {α : Sort u2} {r : α → α → Prop} {C : α → Sort u1} + {a : α} (n : Acc r a) + (m : ∀ (x : α) (h : ∀ (y : α), r y x → Acc r y), (∀ (y : α) (a : r y x), C y) → C x) + : C a := +@Acc.rec α r (fun α _ => C α) m a n + +namespace Acc +variables {α : Sort u} {r : α → α → Prop} + +def inv {x y : α} (h₁ : Acc r x) (h₂ : r y x) : Acc r y := +Acc.recOn h₁ (fun x₁ ac₁ ih h₂ => ac₁ y h₂) h₂ + +end Acc + +inductive WellFounded {α : Sort u} (r : α → α → Prop) : Prop +| intro (h : ∀ a, Acc r a) : WellFounded + +class HasWellFounded (α : Sort u) : Type u := +(r : α → α → Prop) (wf : WellFounded r) + +namespace WellFounded +def apply {α : Sort u} {r : α → α → Prop} (wf : WellFounded r) : ∀ a, Acc r a := +fun a => WellFounded.recOn wf (fun p => p) a + +section +variables {α : Sort u} {r : α → α → Prop} (hwf : WellFounded r) + +theorem recursion {C : α → Sort v} (a : α) (h : ∀ x, (∀ y, r y x → C y) → C x) : C a := +Acc.recOn (apply hwf a) (fun x₁ ac₁ ih => h x₁ ih) + +theorem induction {C : α → Prop} (a : α) (h : ∀ x, (∀ y, r y x → C y) → C x) : C a := +recursion hwf a h + +variable {C : α → Sort v} +variable (F : ∀ x, (∀ y, r y x → C y) → C x) + +def fixF (x : α) (a : Acc r x) : C x := +Acc.recOn a (fun x₁ ac₁ ih => F x₁ ih) + +theorem fixFEq (x : α) (acx : Acc r x) : + fixF F x acx = F x (fun (y : α) (p : r y x) => fixF F y (Acc.inv acx p)) := +Acc.rec (fun x r ih => rfl) acx +end + +variables {α : Sort u} {C : α → Sort v} {r : α → α → Prop} + +-- Well-founded fixpoint +def fix (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) : C x := +fixF F x (apply hwf x) + +-- Well-founded fixpoint satisfies fixpoint equation +theorem fixEq (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) : + fix hwf F x = F x (fun y h => fix hwf F y) := +fixFEq F x (apply hwf x) +end WellFounded + +open WellFounded + +-- Empty relation is well-founded +def emptyWf {α : Sort u} : WellFounded (@emptyRelation α) := +WellFounded.intro (fun (a : α) => + Acc.intro a (fun (b : α) (lt : False) => False.rec _ lt)) + +-- Subrelation of a well-founded relation is well-founded +namespace Subrelation +variables {α : Sort u} {r q : α → α → Prop} + +def accessible {a : α} (h₁ : Subrelation q r) (ac : Acc r a) : Acc q a := +Acc.recOn ac $ fun x ax ih => + Acc.intro x $ fun (y : α) (lt : q y x) => ih y (h₁ lt) + +def wf (h₁ : Subrelation q r) (h₂ : WellFounded r) : WellFounded q := +⟨fun a => accessible @h₁ (apply h₂ a)⟩ +end Subrelation + +-- The inverse image of a well-founded relation is well-founded +namespace InvImage +variables {α : Sort u} {β : Sort v} {r : β → β → Prop} + +private def accAux (f : α → β) {b : β} (ac : Acc r b) : ∀ (x : α), f x = b → Acc (InvImage r f) x := +Acc.ndrecOn ac $ fun x acx ih z e => + Acc.intro z $ fun y lt => + Eq.ndrecOn e (fun acx ih => ih (f y) lt y rfl) acx ih + +def accessible {a : α} (f : α → β) (ac : Acc r (f a)) : Acc (InvImage r f) a := +accAux f ac a rfl + +def wf (f : α → β) (h : WellFounded r) : WellFounded (InvImage r f) := +⟨fun a => accessible f (apply h (f a))⟩ +end InvImage + +-- The transitive closure of a well-founded relation is well-founded +namespace TC +variables {α : Sort u} {r : α → α → Prop} + +def accessible {z : α} (ac : Acc r z) : Acc (TC r) z := +Acc.ndrecOn ac $ fun x acx ih => + Acc.intro x $ fun y rel => + TC.ndrecOn rel + (fun a b rab acx ih => ih a rab) + (fun a b c rab rbc ih₁ ih₂ acx ih => Acc.inv (ih₂ acx ih) rab) + acx ih + +def wf (h : WellFounded r) : WellFounded (TC r) := +⟨fun a => accessible (apply h a)⟩ +end TC + +-- less-than is well-founded +def Nat.ltWf : WellFounded Nat.lt := +⟨Nat.rec + (Acc.intro 0 (fun n h => absurd h (Nat.notLtZero n))) + (fun n ih => Acc.intro (Nat.succ n) $ fun m h => + Or.elim (Nat.eqOrLtOfLe (Nat.leOfSuccLeSucc h)) + (fun e => Eq.substr e ih) (Acc.inv ih))⟩ + +def measure {α : Sort u} : (α → Nat) → α → α → Prop := +InvImage (fun a b => a < b) + +def measureWf {α : Sort u} (f : α → Nat) : WellFounded (measure f) := +InvImage.wf f Nat.ltWf + +def sizeofMeasure (α : Sort u) [HasSizeof α] : α → α → Prop := +measure sizeof + +def sizeofMeasureWf (α : Sort u) [HasSizeof α] : WellFounded (sizeofMeasure α) := +measureWf sizeof + +instance hasWellFoundedOfHasSizeof (α : Sort u) [HasSizeof α] : HasWellFounded α := +{r := sizeofMeasure α, wf := sizeofMeasureWf α} + +namespace Prod +open WellFounded + +section +variables {α : Type u} {β : Type v} +variable (ra : α → α → Prop) +variable (rb : β → β → Prop) + +-- Lexicographical order based on ra and rb +inductive Lex : α × β → α × β → Prop +| left {a₁} (b₁) {a₂} (b₂) (h : ra a₁ a₂) : Lex (a₁, b₁) (a₂, b₂) +| right (a) {b₁ b₂} (h : rb b₁ b₂) : Lex (a, b₁) (a, b₂) + +-- relational product based on ra and rb +inductive Rprod : α × β → α × β → Prop +| intro {a₁ b₁ a₂ b₂} (h₁ : ra a₁ a₂) (h₂ : rb b₁ b₂) : Rprod (a₁, b₁) (a₂, b₂) +end + +section +variables {α : Type u} {β : Type v} +variables {ra : α → α → Prop} {rb : β → β → Prop} + +def lexAccessible {a} (aca : Acc ra a) (acb : ∀ b, Acc rb b): ∀ b, Acc (Lex ra rb) (a, b) := +Acc.ndrecOn aca $ fun xa aca iha b => + Acc.ndrecOn (acb b) $ fun xb acb ihb => + Acc.intro (xa, xb) $ fun p lt => + have aux : xa = xa → xb = xb → Acc (Lex ra rb) p from + @Prod.Lex.recOn α β ra rb (fun p₁ p₂ _ => fst p₂ = xa → snd p₂ = xb → Acc (Lex ra rb) p₁) + p (xa, xb) lt + (fun (a₁ b₁ a₂ b₂ h) (Eq₂ : a₂ = xa) (Eq₃ : b₂ = xb) => iha a₁ (Eq.recOn Eq₂ h) b₁) + (fun (a b₁ b₂ h) (Eq₂ : a = xa) (Eq₃ : b₂ = xb) => Eq.recOn Eq₂.symm (ihb b₁ (Eq.recOn Eq₃ h))); + aux rfl rfl + +-- The lexicographical order of well founded relations is well-founded +def lexWf (ha : WellFounded ra) (hb : WellFounded rb) : WellFounded (Lex ra rb) := +⟨fun p => casesOn p $ fun a b => lexAccessible (apply ha a) (WellFounded.apply hb) b⟩ + +-- relational product is a Subrelation of the Lex +def rprodSubLex : ∀ a b, Rprod ra rb a b → Lex ra rb a b := +@Prod.Rprod.rec _ _ ra rb (fun a b _ => Lex ra rb a b) (fun a₁ b₁ a₂ b₂ h₁ h₂ => Lex.left rb b₁ b₂ h₁) + +-- The relational product of well founded relations is well-founded +def rprodWf (ha : WellFounded ra) (hb : WellFounded rb) : WellFounded (Rprod ra rb) := +Subrelation.wf (rprodSubLex) (lexWf ha hb) +end + +instance HasWellFounded {α : Type u} {β : Type v} [s₁ : HasWellFounded α] [s₂ : HasWellFounded β] : HasWellFounded (α × β) := +{r := Lex s₁.r s₂.r, wf := lexWf s₁.wf s₂.wf} + +end Prod + +namespace PSigma +section +variables {α : Sort u} {β : α → Sort v} +variable (r : α → α → Prop) +variable (s : ∀ a, β a → β a → Prop) + +-- Lexicographical order based on r and s +inductive Lex : PSigma β → PSigma β → Prop +| left : ∀ {a₁ : α} (b₁ : β a₁) {a₂ : α} (b₂ : β a₂), r a₁ a₂ → Lex ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ +| right : ∀ (a : α) {b₁ b₂ : β a}, s a b₁ b₂ → Lex ⟨a, b₁⟩ ⟨a, b₂⟩ +end + +section +variables {α : Sort u} {β : α → Sort v} +variables {r : α → α → Prop} {s : ∀ (a : α), β a → β a → Prop} + +def lexAccessible {a} (aca : Acc r a) (acb : ∀ a, WellFounded (s a)) : ∀ (b : β a), Acc (Lex r s) ⟨a, b⟩ := +Acc.ndrecOn aca $ fun (xa aca) (iha : ∀ y, r y xa → ∀ (b : β y), Acc (Lex r s) ⟨y, b⟩) (b : β xa) => + Acc.ndrecOn (WellFounded.apply (acb xa) b) $ fun xb acb (ihb : ∀ (y : β xa), s xa y xb → Acc (Lex r s) ⟨xa, y⟩) => + Acc.intro ⟨xa, xb⟩ $ fun (p) (lt : Lex r s p ⟨xa, xb⟩) => + have aux : xa = xa → xb ≅ xb → Acc (Lex r s) p from + @PSigma.Lex.recOn α β r s (fun p₁ p₂ _ => p₂.1 = xa → p₂.2 ≅ xb → Acc (Lex r s) p₁) + p ⟨xa, xb⟩ lt + (fun (a₁ : α) (b₁ : β a₁) (a₂ : α) (b₂ : β a₂) (h : r a₁ a₂) (Eq₂ : a₂ = xa) (Eq₃ : b₂ ≅ xb) => + have aux : (∀ (y : α), r y xa → ∀ (b : β y), Acc (Lex r s) ⟨y, b⟩) → + r a₁ a₂ → ∀ (b₁ : β a₁), Acc (Lex r s) ⟨a₁, b₁⟩ from Eq.subst Eq₂ (fun iha h b₁ => iha a₁ h b₁); + aux iha h b₁) + (fun (a : α) (b₁ b₂ : β a) (h : s a b₁ b₂) (Eq₂ : a = xa) (Eq₃ : b₂ ≅ xb) => + have aux : ∀ (xb : β xa), (∀ (y : β xa), s xa y xb → Acc (s xa) y) → + (∀ (y : β xa), s xa y xb → Acc (Lex r s) ⟨xa, y⟩) → + Lex r s p ⟨xa, xb⟩ → ∀ (b₁ : β a), s a b₁ b₂ → b₂ ≅ xb → Acc (Lex r s) ⟨a, b₁⟩ + from Eq.subst Eq₂ $ fun xb acb ihb lt b₁ h Eq₃ => + have newEq₃ : b₂ = xb from eqOfHeq Eq₃; + have aux : (∀ (y : β a), s a y xb → Acc (Lex r s) ⟨a, y⟩) → + ∀ (b₁ : β a), s a b₁ b₂ → Acc (Lex r s) ⟨a, b₁⟩ + from Eq.subst newEq₃ (fun ihb b₁ h => ihb b₁ h); + aux ihb b₁ h; + aux xb acb ihb lt b₁ h Eq₃); + aux rfl (Heq.refl xb) + +-- The lexicographical order of well founded relations is well-founded +def lexWf (ha : WellFounded r) (hb : ∀ x, WellFounded (s x)) : WellFounded (Lex r s) := +WellFounded.intro $ fun ⟨a, b⟩ => lexAccessible (WellFounded.apply ha a) hb b +end + +section +variables {α : Sort u} {β : Sort v} + +def lexNdep (r : α → α → Prop) (s : β → β → Prop) := +Lex r (fun a => s) + +def lexNdepWf {r : α → α → Prop} {s : β → β → Prop} (ha : WellFounded r) (hb : WellFounded s) + : WellFounded (lexNdep r s) := +WellFounded.intro $ fun ⟨a, b⟩ => lexAccessible (WellFounded.apply ha a) (fun x => hb) b +end + +section +variables {α : Sort u} {β : Sort v} + +-- Reverse lexicographical order based on r and s +inductive RevLex (r : α → α → Prop) (s : β → β → Prop) : @PSigma α (fun a => β) → @PSigma α (fun a => β) → Prop +| left : ∀ {a₁ a₂ : α} (b : β), r a₁ a₂ → RevLex ⟨a₁, b⟩ ⟨a₂, b⟩ +| right : ∀ (a₁ : α) {b₁ : β} (a₂ : α) {b₂ : β}, s b₁ b₂ → RevLex ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ +end + +section +open WellFounded +variables {α : Sort u} {β : Sort v} +variables {r : α → α → Prop} {s : β → β → Prop} + +def revLexAccessible {b} (acb : Acc s b) (aca : ∀ a, Acc r a): ∀ a, Acc (RevLex r s) ⟨a, b⟩ := +Acc.recOn acb $ fun (xb acb) (ihb : ∀ y, s y xb → ∀ a, Acc (RevLex r s) ⟨a, y⟩) (a) => + Acc.recOn (aca a) $ fun (xa aca) (iha : ∀ y, r y xa → Acc (RevLex r s) (mk y xb)) => + Acc.intro ⟨xa, xb⟩ $ fun (p) (lt : RevLex r s p ⟨xa, xb⟩) => + have aux : xa = xa → xb = xb → Acc (RevLex r s) p from + @RevLex.recOn α β r s (fun p₁ p₂ _ => fst p₂ = xa → snd p₂ = xb → Acc (RevLex r s) p₁) + p ⟨xa, xb⟩ lt + (fun (a₁ a₂ b) (h : r a₁ a₂) (Eq₂ : a₂ = xa) (Eq₃ : b = xb) => + show Acc (RevLex r s) ⟨a₁, b⟩ from + have r₁ : r a₁ xa from Eq.recOn Eq₂ h; + have aux : Acc (RevLex r s) ⟨a₁, xb⟩ from iha a₁ r₁; + Eq.recOn (Eq.symm Eq₃) aux) + (fun (a₁ b₁ a₂ b₂) (h : s b₁ b₂) (Eq₂ : a₂ = xa) (Eq₃ : b₂ = xb) => + show Acc (RevLex r s) (mk a₁ b₁) from + have s₁ : s b₁ xb from Eq.recOn Eq₃ h; + ihb b₁ s₁ a₁); + aux rfl rfl + +def revLexWf (ha : WellFounded r) (hb : WellFounded s) : WellFounded (RevLex r s) := +WellFounded.intro $ fun ⟨a, b⟩ => revLexAccessible (apply hb b) (WellFounded.apply ha) a +end + +section +def skipLeft (α : Type u) {β : Type v} (s : β → β → Prop) : @PSigma α (fun a => β) → @PSigma α (fun a => β) → Prop := +RevLex emptyRelation s + +def skipLeftWf (α : Type u) {β : Type v} {s : β → β → Prop} (hb : WellFounded s) : WellFounded (skipLeft α s) := +revLexWf emptyWf hb + +def mkSkipLeft {α : Type u} {β : Type v} {b₁ b₂ : β} {s : β → β → Prop} (a₁ a₂ : α) (h : s b₁ b₂) : skipLeft α s ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ := +RevLex.right _ _ _ h +end + +instance HasWellFounded {α : Type u} {β : α → Type v} [s₁ : HasWellFounded α] [s₂ : ∀ a, HasWellFounded (β a)] : HasWellFounded (PSigma β) := +{r := Lex s₁.r (fun a => (s₂ a).r), wf := lexWf s₁.wf (fun a => (s₂ a).wf)} + +end PSigma diff --git a/stage0/src/Init/relative.py b/stage0/src/Init/relative.py new file mode 100644 index 0000000000..c4f8b4b615 --- /dev/null +++ b/stage0/src/Init/relative.py @@ -0,0 +1,14 @@ +# Copyright (c) 2018 Microsoft Corporation. All rights reserved. +# Released under Apache 2.0 license as described in the file LICENSE. +# Authors: Simon Hudon, Sebastian Ullrich + +import sys +import os +import re + +for x in sys.stdin: + # HACK: rewrite Windows path to mingw path + x = re.sub(r"^(\w):", lambda m: "/" + m[1].lower(), x).replace('\\', '/').strip() + curr = os.path.realpath(os.curdir) + curr = os.path.normpath(curr) + print(os.path.relpath(x, curr)) diff --git a/stage0/src/init/CMakeLists.txt b/stage0/src/init/CMakeLists.txt deleted file mode 100644 index f8c1052a31..0000000000 --- a/stage0/src/init/CMakeLists.txt +++ /dev/null @@ -1 +0,0 @@ -add_library(init OBJECT init.cpp) diff --git a/stage0/src/initialize/CMakeLists.txt b/stage0/src/initialize/CMakeLists.txt new file mode 100644 index 0000000000..72c5720893 --- /dev/null +++ b/stage0/src/initialize/CMakeLists.txt @@ -0,0 +1 @@ +add_library(initialize OBJECT init.cpp) diff --git a/stage0/src/init/init.cpp b/stage0/src/initialize/init.cpp similarity index 99% rename from stage0/src/init/init.cpp rename to stage0/src/initialize/init.cpp index 4405e8e2a6..a8a76ea2a6 100644 --- a/stage0/src/init/init.cpp +++ b/stage0/src/initialize/init.cpp @@ -16,7 +16,7 @@ Author: Leonardo de Moura #include "library/print.h" #include "library/compiler/init_module.h" #include "frontends/lean/init_module.h" -#include "init/init.h" +#include "initialize/init.h" namespace lean { extern "C" object* initialize_Init_Default(object* w); diff --git a/stage0/src/init/init.h b/stage0/src/initialize/init.h similarity index 100% rename from stage0/src/init/init.h rename to stage0/src/initialize/init.h diff --git a/stage0/src/shared/init.cpp b/stage0/src/shared/init.cpp index 95c7f227c8..98c325b8a7 100644 --- a/stage0/src/shared/init.cpp +++ b/stage0/src/shared/init.cpp @@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Author: Leonardo de Moura */ -#include "init/init.h" +#include "initialize/init.h" namespace lean { // automatic initialization for the shared library initializer g_init; diff --git a/stage0/src/shell/CMakeLists.txt b/stage0/src/shell/CMakeLists.txt index de3f017814..6e512e17a0 100644 --- a/stage0/src/shell/CMakeLists.txt +++ b/stage0/src/shell/CMakeLists.txt @@ -13,8 +13,8 @@ if(NOT STAGE0) add_custom_target(make_stdlib # '-G Ninja' complains otherwise BYPRODUCTS "${CMAKE_BINARY_DIR}/stage1/libleanstdlib.a" - WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../library" - COMMAND ${CMAKE_COMMAND} -E env "LEAN_PATH=Init=Init" $(MAKE) "${CMAKE_BINARY_DIR}/stage1/libleanstdlib.a" "LEAN=$" "LEANC_OPTS=${LEANC_OPTS}" "STAGE1_OUT=${CMAKE_BINARY_DIR}/stage1" + WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/Init" + COMMAND ${CMAKE_COMMAND} -E env "LEAN_PATH=Init=." $(MAKE) "${CMAKE_BINARY_DIR}/stage1/libleanstdlib.a" "LEAN=$" "LEANC_OPTS=${LEANC_OPTS}" "STAGE1_OUT=${CMAKE_BINARY_DIR}/stage1" DEPENDS stage0) set_target_properties(leanstdlib PROPERTIES IMPORTED_LOCATION "${CMAKE_BINARY_DIR}/stage1/libleanstdlib.a" @@ -25,7 +25,7 @@ if(NOT STAGE0) add_custom_target(update-stage0 COMMAND make update-stage0 "STAGE1_OUT=${CMAKE_BINARY_DIR}/stage1" DEPENDS leanstdlib - WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}/../library") + WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}/Init") endif() add_executable(lean lean.cpp) @@ -43,7 +43,7 @@ if(NOT STAGE0) set(NODE_JS "node --stack_size=8192") file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/lean_with_path - "#!/bin/sh\nLEAN_PATH=Init=${CMAKE_CURRENT_SOURCE_DIR}/../../library ${NODE_JS} ${CMAKE_CURRENT_BINARY_DIR}/lean.js \"$@\"\n") + "#!/bin/sh\nLEAN_PATH=Init=${CMAKE_CURRENT_SOURCE_DIR}/.. ${NODE_JS} ${CMAKE_CURRENT_BINARY_DIR}/lean.js \"$@\"\n") execute_process(COMMAND chmod +x ${CMAKE_CURRENT_BINARY_DIR}/lean_with_path) ADD_CUSTOM_TARGET(bin_lean ALL @@ -97,34 +97,9 @@ add_test(lean_version2 "${CMAKE_CURRENT_BINARY_DIR}/lean" --v) endif() add_test(lean_ghash1 "${CMAKE_CURRENT_BINARY_DIR}/lean" -g) add_test(lean_ghash2 "${CMAKE_CURRENT_BINARY_DIR}/lean" --githash) -add_test(lean_new_frontend "${LEAN_SOURCE_DIR}/../bin/lean" --new-frontend "${LEAN_SOURCE_DIR}/../library/Init/Core.lean") +add_test(lean_new_frontend "${LEAN_SOURCE_DIR}/../bin/lean" --new-frontend "${LEAN_SOURCE_DIR}/Init/Core.lean") add_test(lean_unknown_option bash "${LEAN_SOURCE_DIR}/cmake/check_failure.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean" "-z") add_test(lean_unknown_file1 bash "${LEAN_SOURCE_DIR}/cmake/check_failure.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean" "boofoo.lean") -# The following test needs new elaborator to support match -# add_test(NAME "lean_eqn_macro" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND bash "./test_eqn_macro.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean") -# add_test(NAME "lean_print_notation" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND bash "./test_single.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean" "print_tests.lean") -# add_test(NAME "issue_597" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND bash "./issue_597.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean") -# add_test(NAME "issue_616" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND bash "./issue_616.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean") -# add_test(NAME "show_goal" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND bash "./show_goal.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean") -# add_test(NAME "issue_755" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND bash "./issue_755.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean") -# add_test(NAME "print_info" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND bash "./print_info.sh" "${CMAKE_CURRENT_BINARY_DIR}/lean") -# add_test(NAME "dir_option" -# WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../tests/lean/extra" -# COMMAND "${LEAN_SOURCE_DIR}/../bin/lean" "--dir=${LEAN_SOURCE_DIR}/../library/data/nat" "dir_option.lean") if (NOT(${CMAKE_SYSTEM_NAME} MATCHES "Windows")) # The following test cannot be executed on Windows because of the # bash script timeout.sh @@ -245,10 +220,10 @@ if(${CMAKE_SYSTEM_NAME} MATCHES "Windows") # Skip stdlib tests on Windows message(STATUS "skipping stdlib tests") else() - file(GLOB_RECURSE STDLIBFILES RELATIVE "${LEAN_SOURCE_DIR}/../library" "${LEAN_SOURCE_DIR}/../library/*.lean") + file(GLOB_RECURSE STDLIBFILES RELATIVE "${LEAN_SOURCE_DIR}/Init" "${LEAN_SOURCE_DIR}/Init/*.lean") FOREACH(T ${STDLIBFILES}) add_test(NAME "stdlib_${T}" - WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../library" + WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/Init" COMMAND "${LEAN_SOURCE_DIR}/../bin/lean" "${T}") ENDFOREACH(T) endif() diff --git a/stage0/src/shell/lean.cpp b/stage0/src/shell/lean.cpp index ac47f2db02..318297ce6f 100644 --- a/stage0/src/shell/lean.cpp +++ b/stage0/src/shell/lean.cpp @@ -40,7 +40,7 @@ Author: Leonardo de Moura #include "frontends/lean/json.h" #include "frontends/lean/util.h" #include "library/trace.h" -#include "init/init.h" +#include "initialize/init.h" #include "frontends/lean/simple_pos_info_provider.h" #include "library/compiler/ir_interpreter.h" #include "util/path.h" diff --git a/stage0/stdlib/CMakeLists.txt b/stage0/stdlib/CMakeLists.txt new file mode 100644 index 0000000000..62e19bd85c --- /dev/null +++ b/stage0/stdlib/CMakeLists.txt @@ -0,0 +1 @@ +add_library (stage0 OBJECT Init/./Coe.c Init/./Control.c Init/./Control/Alternative.c Init/./Control/Applicative.c Init/./Control/Conditional.c Init/./Control/EState.c Init/./Control/Except.c Init/./Control/Functor.c Init/./Control/Id.c Init/./Control/Lift.c Init/./Control/Monad.c Init/./Control/MonadFail.c Init/./Control/Option.c Init/./Control/Reader.c Init/./Control/State.c Init/./Core.c Init/./Data.c Init/./Data/Array.c Init/./Data/Array/Basic.c Init/./Data/Array/BinSearch.c Init/./Data/Array/QSort.c Init/./Data/AssocList.c Init/./Data/Basic.c Init/./Data/BinomialHeap.c Init/./Data/BinomialHeap/Basic.c Init/./Data/ByteArray.c Init/./Data/ByteArray/Basic.c Init/./Data/Char.c Init/./Data/Char/Basic.c Init/./Data/DList.c Init/./Data/Fin.c Init/./Data/Fin/Basic.c Init/./Data/HashMap.c Init/./Data/HashMap/Basic.c Init/./Data/HashSet.c Init/./Data/Hashable.c Init/./Data/Int.c Init/./Data/Int/Basic.c Init/./Data/List.c Init/./Data/List/Basic.c Init/./Data/List/BasicAux.c Init/./Data/List/Control.c Init/./Data/List/Instances.c Init/./Data/Nat.c Init/./Data/Nat/Basic.c Init/./Data/Nat/Bitwise.c Init/./Data/Nat/Control.c Init/./Data/Nat/Div.c Init/./Data/Option.c Init/./Data/Option/Basic.c Init/./Data/Option/BasicAux.c Init/./Data/Option/Instances.c Init/./Data/PersistentArray.c Init/./Data/PersistentArray/Basic.c Init/./Data/PersistentHashMap.c Init/./Data/PersistentHashMap/Basic.c Init/./Data/PersistentHashSet.c Init/./Data/Queue.c Init/./Data/Queue/Basic.c Init/./Data/RBMap.c Init/./Data/RBMap/Basic.c Init/./Data/RBMap/BasicAux.c Init/./Data/RBTree.c Init/./Data/RBTree/Basic.c Init/./Data/Random.c Init/./Data/Repr.c Init/./Data/Stack.c Init/./Data/Stack/Basic.c Init/./Data/String.c Init/./Data/String/Basic.c Init/./Data/ToString.c Init/./Data/UInt.c Init/./Default.c Init/./Fix.c Init/./Lean.c Init/./Lean/Attributes.c Init/./Lean/AuxRecursor.c Init/./Lean/Class.c Init/./Lean/Compiler.c Init/./Lean/Compiler/ClosedTermCache.c Init/./Lean/Compiler/ConstFolding.c Init/./Lean/Compiler/ExportAttr.c Init/./Lean/Compiler/ExternAttr.c Init/./Lean/Compiler/IR.c Init/./Lean/Compiler/IR/Basic.c Init/./Lean/Compiler/IR/Borrow.c Init/./Lean/Compiler/IR/Boxing.c Init/./Lean/Compiler/IR/Checker.c Init/./Lean/Compiler/IR/CompilerM.c Init/./Lean/Compiler/IR/CtorLayout.c Init/./Lean/Compiler/IR/ElimDeadBranches.c Init/./Lean/Compiler/IR/ElimDeadVars.c Init/./Lean/Compiler/IR/EmitC.c Init/./Lean/Compiler/IR/EmitUtil.c Init/./Lean/Compiler/IR/ExpandResetReuse.c Init/./Lean/Compiler/IR/Format.c Init/./Lean/Compiler/IR/FreeVars.c Init/./Lean/Compiler/IR/LiveVars.c Init/./Lean/Compiler/IR/NormIds.c Init/./Lean/Compiler/IR/PushProj.c Init/./Lean/Compiler/IR/RC.c Init/./Lean/Compiler/IR/ResetReuse.c Init/./Lean/Compiler/IR/SimpCase.c Init/./Lean/Compiler/IR/UnboxResult.c Init/./Lean/Compiler/ImplementedByAttr.c Init/./Lean/Compiler/InitAttr.c Init/./Lean/Compiler/InlineAttrs.c Init/./Lean/Compiler/NameMangling.c Init/./Lean/Compiler/NeverExtractAttr.c Init/./Lean/Compiler/Specialize.c Init/./Lean/Compiler/Util.c Init/./Lean/Declaration.c Init/./Lean/Elaborator.c Init/./Lean/Elaborator/Alias.c Init/./Lean/Elaborator/Basic.c Init/./Lean/Elaborator/Command.c Init/./Lean/Elaborator/ElabStrategyAttrs.c Init/./Lean/Elaborator/PreTerm.c Init/./Lean/Elaborator/ResolveName.c Init/./Lean/Elaborator/Term.c Init/./Lean/Environment.c Init/./Lean/EqnCompiler.c Init/./Lean/EqnCompiler/MatchPattern.c Init/./Lean/Expr.c Init/./Lean/Format.c Init/./Lean/KVMap.c Init/./Lean/LBool.c Init/./Lean/LOption.c Init/./Lean/Level.c Init/./Lean/Linter.c Init/./Lean/LocalContext.c Init/./Lean/Message.c Init/./Lean/Meta.c Init/./Lean/Meta/Basic.c Init/./Lean/Meta/Check.c Init/./Lean/Meta/Exception.c Init/./Lean/Meta/ExprDefEq.c Init/./Lean/Meta/FunInfo.c Init/./Lean/Meta/InferType.c Init/./Lean/Meta/LevelDefEq.c Init/./Lean/Meta/Offset.c Init/./Lean/Meta/WHNF.c Init/./Lean/MetavarContext.c Init/./Lean/Modifiers.c Init/./Lean/MonadCache.c Init/./Lean/Name.c Init/./Lean/NameGenerator.c Init/./Lean/Options.c Init/./Lean/Parser.c Init/./Lean/Parser/Command.c Init/./Lean/Parser/Identifier.c Init/./Lean/Parser/Level.c Init/./Lean/Parser/Module.c Init/./Lean/Parser/Parser.c Init/./Lean/Parser/Term.c Init/./Lean/Parser/Transform.c Init/./Lean/Parser/Trie.c Init/./Lean/Path.c Init/./Lean/Position.c Init/./Lean/ProjFns.c Init/./Lean/ReducibilityAttrs.c Init/./Lean/Runtime.c Init/./Lean/SMap.c Init/./Lean/Scopes.c Init/./Lean/Syntax.c Init/./Lean/ToExpr.c Init/./Lean/Trace.c Init/./Lean/TypeClass.c Init/./Lean/TypeClass/Basic.c Init/./Lean/TypeClass/Context.c Init/./Lean/TypeClass/Synth.c Init/./Lean/Util.c Init/./Lean/WHNF.c Init/./System.c Init/./System/FilePath.c Init/./System/IO.c Init/./System/Platform.c Init/./Util.c Init/./WF.c) diff --git a/stage0/library/Init/Coe.c b/stage0/stdlib/Init/Coe.c similarity index 100% rename from stage0/library/Init/Coe.c rename to stage0/stdlib/Init/Coe.c diff --git a/stage0/library/Init/Control.c b/stage0/stdlib/Init/Control.c similarity index 100% rename from stage0/library/Init/Control.c rename to stage0/stdlib/Init/Control.c diff --git a/stage0/library/Init/Control/Alternative.c b/stage0/stdlib/Init/Control/Alternative.c similarity index 100% rename from stage0/library/Init/Control/Alternative.c rename to stage0/stdlib/Init/Control/Alternative.c diff --git a/stage0/library/Init/Control/Applicative.c b/stage0/stdlib/Init/Control/Applicative.c similarity index 100% rename from stage0/library/Init/Control/Applicative.c rename to stage0/stdlib/Init/Control/Applicative.c diff --git a/stage0/library/Init/Control/Conditional.c b/stage0/stdlib/Init/Control/Conditional.c similarity index 100% rename from stage0/library/Init/Control/Conditional.c rename to stage0/stdlib/Init/Control/Conditional.c diff --git a/stage0/library/Init/Control/EState.c b/stage0/stdlib/Init/Control/EState.c similarity index 100% rename from stage0/library/Init/Control/EState.c rename to stage0/stdlib/Init/Control/EState.c diff --git a/stage0/library/Init/Control/Except.c b/stage0/stdlib/Init/Control/Except.c similarity index 100% rename from stage0/library/Init/Control/Except.c rename to stage0/stdlib/Init/Control/Except.c diff --git a/stage0/library/Init/Control/Functor.c b/stage0/stdlib/Init/Control/Functor.c similarity index 100% rename from stage0/library/Init/Control/Functor.c rename to stage0/stdlib/Init/Control/Functor.c diff --git a/stage0/library/Init/Control/Id.c b/stage0/stdlib/Init/Control/Id.c similarity index 100% rename from stage0/library/Init/Control/Id.c rename to stage0/stdlib/Init/Control/Id.c diff --git a/stage0/library/Init/Control/Lift.c b/stage0/stdlib/Init/Control/Lift.c similarity index 100% rename from stage0/library/Init/Control/Lift.c rename to stage0/stdlib/Init/Control/Lift.c diff --git a/stage0/library/Init/Control/Monad.c b/stage0/stdlib/Init/Control/Monad.c similarity index 100% rename from stage0/library/Init/Control/Monad.c rename to stage0/stdlib/Init/Control/Monad.c diff --git a/stage0/library/Init/Control/MonadFail.c b/stage0/stdlib/Init/Control/MonadFail.c similarity index 100% rename from stage0/library/Init/Control/MonadFail.c rename to stage0/stdlib/Init/Control/MonadFail.c diff --git a/stage0/library/Init/Control/Option.c b/stage0/stdlib/Init/Control/Option.c similarity index 100% rename from stage0/library/Init/Control/Option.c rename to stage0/stdlib/Init/Control/Option.c diff --git a/stage0/library/Init/Control/Reader.c b/stage0/stdlib/Init/Control/Reader.c similarity index 100% rename from stage0/library/Init/Control/Reader.c rename to stage0/stdlib/Init/Control/Reader.c diff --git a/stage0/library/Init/Control/State.c b/stage0/stdlib/Init/Control/State.c similarity index 100% rename from stage0/library/Init/Control/State.c rename to stage0/stdlib/Init/Control/State.c diff --git a/stage0/library/Init/Core.c b/stage0/stdlib/Init/Core.c similarity index 100% rename from stage0/library/Init/Core.c rename to stage0/stdlib/Init/Core.c diff --git a/stage0/library/Init/Data.c b/stage0/stdlib/Init/Data.c similarity index 100% rename from stage0/library/Init/Data.c rename to stage0/stdlib/Init/Data.c diff --git a/stage0/library/Init/Data/Array.c b/stage0/stdlib/Init/Data/Array.c similarity index 100% rename from stage0/library/Init/Data/Array.c rename to stage0/stdlib/Init/Data/Array.c diff --git a/stage0/library/Init/Data/Array/Basic.c b/stage0/stdlib/Init/Data/Array/Basic.c similarity index 100% rename from stage0/library/Init/Data/Array/Basic.c rename to stage0/stdlib/Init/Data/Array/Basic.c diff --git a/stage0/library/Init/Data/Array/BinSearch.c b/stage0/stdlib/Init/Data/Array/BinSearch.c similarity index 100% rename from stage0/library/Init/Data/Array/BinSearch.c rename to stage0/stdlib/Init/Data/Array/BinSearch.c diff --git a/stage0/library/Init/Data/Array/QSort.c b/stage0/stdlib/Init/Data/Array/QSort.c similarity index 100% rename from stage0/library/Init/Data/Array/QSort.c rename to stage0/stdlib/Init/Data/Array/QSort.c diff --git a/stage0/library/Init/Data/AssocList.c b/stage0/stdlib/Init/Data/AssocList.c similarity index 100% rename from stage0/library/Init/Data/AssocList.c rename to stage0/stdlib/Init/Data/AssocList.c diff --git a/stage0/library/Init/Data/Basic.c b/stage0/stdlib/Init/Data/Basic.c similarity index 100% rename from stage0/library/Init/Data/Basic.c rename to stage0/stdlib/Init/Data/Basic.c diff --git a/stage0/library/Init/Data/BinomialHeap.c b/stage0/stdlib/Init/Data/BinomialHeap.c similarity index 100% rename from stage0/library/Init/Data/BinomialHeap.c rename to stage0/stdlib/Init/Data/BinomialHeap.c diff --git a/stage0/library/Init/Data/BinomialHeap/Basic.c b/stage0/stdlib/Init/Data/BinomialHeap/Basic.c similarity index 100% rename from stage0/library/Init/Data/BinomialHeap/Basic.c rename to stage0/stdlib/Init/Data/BinomialHeap/Basic.c diff --git a/stage0/library/Init/Data/ByteArray.c b/stage0/stdlib/Init/Data/ByteArray.c similarity index 100% rename from stage0/library/Init/Data/ByteArray.c rename to stage0/stdlib/Init/Data/ByteArray.c diff --git a/stage0/library/Init/Data/ByteArray/Basic.c b/stage0/stdlib/Init/Data/ByteArray/Basic.c similarity index 100% rename from stage0/library/Init/Data/ByteArray/Basic.c rename to stage0/stdlib/Init/Data/ByteArray/Basic.c diff --git a/stage0/library/Init/Data/Char.c b/stage0/stdlib/Init/Data/Char.c similarity index 100% rename from stage0/library/Init/Data/Char.c rename to stage0/stdlib/Init/Data/Char.c diff --git a/stage0/library/Init/Data/Char/Basic.c b/stage0/stdlib/Init/Data/Char/Basic.c similarity index 100% rename from stage0/library/Init/Data/Char/Basic.c rename to stage0/stdlib/Init/Data/Char/Basic.c diff --git a/stage0/library/Init/Data/DList.c b/stage0/stdlib/Init/Data/DList.c similarity index 100% rename from stage0/library/Init/Data/DList.c rename to stage0/stdlib/Init/Data/DList.c diff --git a/stage0/library/Init/Data/Fin.c b/stage0/stdlib/Init/Data/Fin.c similarity index 100% rename from stage0/library/Init/Data/Fin.c rename to stage0/stdlib/Init/Data/Fin.c diff --git a/stage0/library/Init/Data/Fin/Basic.c b/stage0/stdlib/Init/Data/Fin/Basic.c similarity index 100% rename from stage0/library/Init/Data/Fin/Basic.c rename to stage0/stdlib/Init/Data/Fin/Basic.c diff --git a/stage0/library/Init/Data/HashMap.c b/stage0/stdlib/Init/Data/HashMap.c similarity index 100% rename from stage0/library/Init/Data/HashMap.c rename to stage0/stdlib/Init/Data/HashMap.c diff --git a/stage0/library/Init/Data/HashMap/Basic.c b/stage0/stdlib/Init/Data/HashMap/Basic.c similarity index 100% rename from stage0/library/Init/Data/HashMap/Basic.c rename to stage0/stdlib/Init/Data/HashMap/Basic.c diff --git a/stage0/library/Init/Data/HashSet.c b/stage0/stdlib/Init/Data/HashSet.c similarity index 100% rename from stage0/library/Init/Data/HashSet.c rename to stage0/stdlib/Init/Data/HashSet.c diff --git a/stage0/library/Init/Data/Hashable.c b/stage0/stdlib/Init/Data/Hashable.c similarity index 100% rename from stage0/library/Init/Data/Hashable.c rename to stage0/stdlib/Init/Data/Hashable.c diff --git a/stage0/library/Init/Data/Int.c b/stage0/stdlib/Init/Data/Int.c similarity index 100% rename from stage0/library/Init/Data/Int.c rename to stage0/stdlib/Init/Data/Int.c diff --git a/stage0/library/Init/Data/Int/Basic.c b/stage0/stdlib/Init/Data/Int/Basic.c similarity index 100% rename from stage0/library/Init/Data/Int/Basic.c rename to stage0/stdlib/Init/Data/Int/Basic.c diff --git a/stage0/library/Init/Data/List.c b/stage0/stdlib/Init/Data/List.c similarity index 100% rename from stage0/library/Init/Data/List.c rename to stage0/stdlib/Init/Data/List.c diff --git a/stage0/library/Init/Data/List/Basic.c b/stage0/stdlib/Init/Data/List/Basic.c similarity index 100% rename from stage0/library/Init/Data/List/Basic.c rename to stage0/stdlib/Init/Data/List/Basic.c diff --git a/stage0/library/Init/Data/List/BasicAux.c b/stage0/stdlib/Init/Data/List/BasicAux.c similarity index 100% rename from stage0/library/Init/Data/List/BasicAux.c rename to stage0/stdlib/Init/Data/List/BasicAux.c diff --git a/stage0/library/Init/Data/List/Control.c b/stage0/stdlib/Init/Data/List/Control.c similarity index 100% rename from stage0/library/Init/Data/List/Control.c rename to stage0/stdlib/Init/Data/List/Control.c diff --git a/stage0/library/Init/Data/List/Instances.c b/stage0/stdlib/Init/Data/List/Instances.c similarity index 100% rename from stage0/library/Init/Data/List/Instances.c rename to stage0/stdlib/Init/Data/List/Instances.c diff --git a/stage0/library/Init/Data/Nat.c b/stage0/stdlib/Init/Data/Nat.c similarity index 100% rename from stage0/library/Init/Data/Nat.c rename to stage0/stdlib/Init/Data/Nat.c diff --git a/stage0/library/Init/Data/Nat/Basic.c b/stage0/stdlib/Init/Data/Nat/Basic.c similarity index 100% rename from stage0/library/Init/Data/Nat/Basic.c rename to stage0/stdlib/Init/Data/Nat/Basic.c diff --git a/stage0/library/Init/Data/Nat/Bitwise.c b/stage0/stdlib/Init/Data/Nat/Bitwise.c similarity index 100% rename from stage0/library/Init/Data/Nat/Bitwise.c rename to stage0/stdlib/Init/Data/Nat/Bitwise.c diff --git a/stage0/library/Init/Data/Nat/Control.c b/stage0/stdlib/Init/Data/Nat/Control.c similarity index 100% rename from stage0/library/Init/Data/Nat/Control.c rename to stage0/stdlib/Init/Data/Nat/Control.c diff --git a/stage0/library/Init/Data/Nat/Div.c b/stage0/stdlib/Init/Data/Nat/Div.c similarity index 100% rename from stage0/library/Init/Data/Nat/Div.c rename to stage0/stdlib/Init/Data/Nat/Div.c diff --git a/stage0/library/Init/Data/Option.c b/stage0/stdlib/Init/Data/Option.c similarity index 100% rename from stage0/library/Init/Data/Option.c rename to stage0/stdlib/Init/Data/Option.c diff --git a/stage0/library/Init/Data/Option/Basic.c b/stage0/stdlib/Init/Data/Option/Basic.c similarity index 100% rename from stage0/library/Init/Data/Option/Basic.c rename to stage0/stdlib/Init/Data/Option/Basic.c diff --git a/stage0/library/Init/Data/Option/BasicAux.c b/stage0/stdlib/Init/Data/Option/BasicAux.c similarity index 100% rename from stage0/library/Init/Data/Option/BasicAux.c rename to stage0/stdlib/Init/Data/Option/BasicAux.c diff --git a/stage0/library/Init/Data/Option/Instances.c b/stage0/stdlib/Init/Data/Option/Instances.c similarity index 100% rename from stage0/library/Init/Data/Option/Instances.c rename to stage0/stdlib/Init/Data/Option/Instances.c diff --git a/stage0/library/Init/Data/PersistentArray.c b/stage0/stdlib/Init/Data/PersistentArray.c similarity index 100% rename from stage0/library/Init/Data/PersistentArray.c rename to stage0/stdlib/Init/Data/PersistentArray.c diff --git a/stage0/library/Init/Data/PersistentArray/Basic.c b/stage0/stdlib/Init/Data/PersistentArray/Basic.c similarity index 100% rename from stage0/library/Init/Data/PersistentArray/Basic.c rename to stage0/stdlib/Init/Data/PersistentArray/Basic.c diff --git a/stage0/library/Init/Data/PersistentHashMap.c b/stage0/stdlib/Init/Data/PersistentHashMap.c similarity index 100% rename from stage0/library/Init/Data/PersistentHashMap.c rename to stage0/stdlib/Init/Data/PersistentHashMap.c diff --git a/stage0/library/Init/Data/PersistentHashMap/Basic.c b/stage0/stdlib/Init/Data/PersistentHashMap/Basic.c similarity index 100% rename from stage0/library/Init/Data/PersistentHashMap/Basic.c rename to stage0/stdlib/Init/Data/PersistentHashMap/Basic.c diff --git a/stage0/library/Init/Data/PersistentHashSet.c b/stage0/stdlib/Init/Data/PersistentHashSet.c similarity index 100% rename from stage0/library/Init/Data/PersistentHashSet.c rename to stage0/stdlib/Init/Data/PersistentHashSet.c diff --git a/stage0/library/Init/Data/Queue.c b/stage0/stdlib/Init/Data/Queue.c similarity index 100% rename from stage0/library/Init/Data/Queue.c rename to stage0/stdlib/Init/Data/Queue.c diff --git a/stage0/library/Init/Data/Queue/Basic.c b/stage0/stdlib/Init/Data/Queue/Basic.c similarity index 100% rename from stage0/library/Init/Data/Queue/Basic.c rename to stage0/stdlib/Init/Data/Queue/Basic.c diff --git a/stage0/library/Init/Data/RBMap.c b/stage0/stdlib/Init/Data/RBMap.c similarity index 100% rename from stage0/library/Init/Data/RBMap.c rename to stage0/stdlib/Init/Data/RBMap.c diff --git a/stage0/library/Init/Data/RBMap/Basic.c b/stage0/stdlib/Init/Data/RBMap/Basic.c similarity index 100% rename from stage0/library/Init/Data/RBMap/Basic.c rename to stage0/stdlib/Init/Data/RBMap/Basic.c diff --git a/stage0/library/Init/Data/RBMap/BasicAux.c b/stage0/stdlib/Init/Data/RBMap/BasicAux.c similarity index 100% rename from stage0/library/Init/Data/RBMap/BasicAux.c rename to stage0/stdlib/Init/Data/RBMap/BasicAux.c diff --git a/stage0/library/Init/Data/RBTree.c b/stage0/stdlib/Init/Data/RBTree.c similarity index 100% rename from stage0/library/Init/Data/RBTree.c rename to stage0/stdlib/Init/Data/RBTree.c diff --git a/stage0/library/Init/Data/RBTree/Basic.c b/stage0/stdlib/Init/Data/RBTree/Basic.c similarity index 100% rename from stage0/library/Init/Data/RBTree/Basic.c rename to stage0/stdlib/Init/Data/RBTree/Basic.c diff --git a/stage0/library/Init/Data/Random.c b/stage0/stdlib/Init/Data/Random.c similarity index 100% rename from stage0/library/Init/Data/Random.c rename to stage0/stdlib/Init/Data/Random.c diff --git a/stage0/library/Init/Data/Repr.c b/stage0/stdlib/Init/Data/Repr.c similarity index 100% rename from stage0/library/Init/Data/Repr.c rename to stage0/stdlib/Init/Data/Repr.c diff --git a/stage0/library/Init/Data/Stack.c b/stage0/stdlib/Init/Data/Stack.c similarity index 100% rename from stage0/library/Init/Data/Stack.c rename to stage0/stdlib/Init/Data/Stack.c diff --git a/stage0/library/Init/Data/Stack/Basic.c b/stage0/stdlib/Init/Data/Stack/Basic.c similarity index 100% rename from stage0/library/Init/Data/Stack/Basic.c rename to stage0/stdlib/Init/Data/Stack/Basic.c diff --git a/stage0/library/Init/Data/String.c b/stage0/stdlib/Init/Data/String.c similarity index 100% rename from stage0/library/Init/Data/String.c rename to stage0/stdlib/Init/Data/String.c diff --git a/stage0/library/Init/Data/String/Basic.c b/stage0/stdlib/Init/Data/String/Basic.c similarity index 100% rename from stage0/library/Init/Data/String/Basic.c rename to stage0/stdlib/Init/Data/String/Basic.c diff --git a/stage0/library/Init/Data/ToString.c b/stage0/stdlib/Init/Data/ToString.c similarity index 100% rename from stage0/library/Init/Data/ToString.c rename to stage0/stdlib/Init/Data/ToString.c diff --git a/stage0/library/Init/Data/UInt.c b/stage0/stdlib/Init/Data/UInt.c similarity index 100% rename from stage0/library/Init/Data/UInt.c rename to stage0/stdlib/Init/Data/UInt.c diff --git a/stage0/library/Init/Default.c b/stage0/stdlib/Init/Default.c similarity index 100% rename from stage0/library/Init/Default.c rename to stage0/stdlib/Init/Default.c diff --git a/stage0/library/Init/Fix.c b/stage0/stdlib/Init/Fix.c similarity index 100% rename from stage0/library/Init/Fix.c rename to stage0/stdlib/Init/Fix.c diff --git a/stage0/library/Init/Lean.c b/stage0/stdlib/Init/Lean.c similarity index 100% rename from stage0/library/Init/Lean.c rename to stage0/stdlib/Init/Lean.c diff --git a/stage0/library/Init/Lean/Attributes.c b/stage0/stdlib/Init/Lean/Attributes.c similarity index 100% rename from stage0/library/Init/Lean/Attributes.c rename to stage0/stdlib/Init/Lean/Attributes.c diff --git a/stage0/library/Init/Lean/AuxRecursor.c b/stage0/stdlib/Init/Lean/AuxRecursor.c similarity index 100% rename from stage0/library/Init/Lean/AuxRecursor.c rename to stage0/stdlib/Init/Lean/AuxRecursor.c diff --git a/stage0/library/Init/Lean/Class.c b/stage0/stdlib/Init/Lean/Class.c similarity index 100% rename from stage0/library/Init/Lean/Class.c rename to stage0/stdlib/Init/Lean/Class.c diff --git a/stage0/library/Init/Lean/Compiler.c b/stage0/stdlib/Init/Lean/Compiler.c similarity index 100% rename from stage0/library/Init/Lean/Compiler.c rename to stage0/stdlib/Init/Lean/Compiler.c diff --git a/stage0/library/Init/Lean/Compiler/ClosedTermCache.c b/stage0/stdlib/Init/Lean/Compiler/ClosedTermCache.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/ClosedTermCache.c rename to stage0/stdlib/Init/Lean/Compiler/ClosedTermCache.c diff --git a/stage0/library/Init/Lean/Compiler/ConstFolding.c b/stage0/stdlib/Init/Lean/Compiler/ConstFolding.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/ConstFolding.c rename to stage0/stdlib/Init/Lean/Compiler/ConstFolding.c diff --git a/stage0/library/Init/Lean/Compiler/ExportAttr.c b/stage0/stdlib/Init/Lean/Compiler/ExportAttr.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/ExportAttr.c rename to stage0/stdlib/Init/Lean/Compiler/ExportAttr.c diff --git a/stage0/library/Init/Lean/Compiler/ExternAttr.c b/stage0/stdlib/Init/Lean/Compiler/ExternAttr.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/ExternAttr.c rename to stage0/stdlib/Init/Lean/Compiler/ExternAttr.c diff --git a/stage0/library/Init/Lean/Compiler/IR.c b/stage0/stdlib/Init/Lean/Compiler/IR.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR.c rename to stage0/stdlib/Init/Lean/Compiler/IR.c diff --git a/stage0/library/Init/Lean/Compiler/IR/Basic.c b/stage0/stdlib/Init/Lean/Compiler/IR/Basic.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/Basic.c rename to stage0/stdlib/Init/Lean/Compiler/IR/Basic.c diff --git a/stage0/library/Init/Lean/Compiler/IR/Borrow.c b/stage0/stdlib/Init/Lean/Compiler/IR/Borrow.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/Borrow.c rename to stage0/stdlib/Init/Lean/Compiler/IR/Borrow.c diff --git a/stage0/library/Init/Lean/Compiler/IR/Boxing.c b/stage0/stdlib/Init/Lean/Compiler/IR/Boxing.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/Boxing.c rename to stage0/stdlib/Init/Lean/Compiler/IR/Boxing.c diff --git a/stage0/library/Init/Lean/Compiler/IR/Checker.c b/stage0/stdlib/Init/Lean/Compiler/IR/Checker.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/Checker.c rename to stage0/stdlib/Init/Lean/Compiler/IR/Checker.c diff --git a/stage0/library/Init/Lean/Compiler/IR/CompilerM.c b/stage0/stdlib/Init/Lean/Compiler/IR/CompilerM.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/CompilerM.c rename to stage0/stdlib/Init/Lean/Compiler/IR/CompilerM.c diff --git a/stage0/library/Init/Lean/Compiler/IR/CtorLayout.c b/stage0/stdlib/Init/Lean/Compiler/IR/CtorLayout.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/CtorLayout.c rename to stage0/stdlib/Init/Lean/Compiler/IR/CtorLayout.c diff --git a/stage0/library/Init/Lean/Compiler/IR/ElimDeadBranches.c b/stage0/stdlib/Init/Lean/Compiler/IR/ElimDeadBranches.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/ElimDeadBranches.c rename to stage0/stdlib/Init/Lean/Compiler/IR/ElimDeadBranches.c diff --git a/stage0/library/Init/Lean/Compiler/IR/ElimDeadVars.c b/stage0/stdlib/Init/Lean/Compiler/IR/ElimDeadVars.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/ElimDeadVars.c rename to stage0/stdlib/Init/Lean/Compiler/IR/ElimDeadVars.c diff --git a/stage0/library/Init/Lean/Compiler/IR/EmitC.c b/stage0/stdlib/Init/Lean/Compiler/IR/EmitC.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/EmitC.c rename to stage0/stdlib/Init/Lean/Compiler/IR/EmitC.c diff --git a/stage0/library/Init/Lean/Compiler/IR/EmitUtil.c b/stage0/stdlib/Init/Lean/Compiler/IR/EmitUtil.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/EmitUtil.c rename to stage0/stdlib/Init/Lean/Compiler/IR/EmitUtil.c diff --git a/stage0/library/Init/Lean/Compiler/IR/ExpandResetReuse.c b/stage0/stdlib/Init/Lean/Compiler/IR/ExpandResetReuse.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/ExpandResetReuse.c rename to stage0/stdlib/Init/Lean/Compiler/IR/ExpandResetReuse.c diff --git a/stage0/library/Init/Lean/Compiler/IR/Format.c b/stage0/stdlib/Init/Lean/Compiler/IR/Format.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/Format.c rename to stage0/stdlib/Init/Lean/Compiler/IR/Format.c diff --git a/stage0/library/Init/Lean/Compiler/IR/FreeVars.c b/stage0/stdlib/Init/Lean/Compiler/IR/FreeVars.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/FreeVars.c rename to stage0/stdlib/Init/Lean/Compiler/IR/FreeVars.c diff --git a/stage0/library/Init/Lean/Compiler/IR/LiveVars.c b/stage0/stdlib/Init/Lean/Compiler/IR/LiveVars.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/LiveVars.c rename to stage0/stdlib/Init/Lean/Compiler/IR/LiveVars.c diff --git a/stage0/library/Init/Lean/Compiler/IR/NormIds.c b/stage0/stdlib/Init/Lean/Compiler/IR/NormIds.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/NormIds.c rename to stage0/stdlib/Init/Lean/Compiler/IR/NormIds.c diff --git a/stage0/library/Init/Lean/Compiler/IR/PushProj.c b/stage0/stdlib/Init/Lean/Compiler/IR/PushProj.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/PushProj.c rename to stage0/stdlib/Init/Lean/Compiler/IR/PushProj.c diff --git a/stage0/library/Init/Lean/Compiler/IR/RC.c b/stage0/stdlib/Init/Lean/Compiler/IR/RC.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/RC.c rename to stage0/stdlib/Init/Lean/Compiler/IR/RC.c diff --git a/stage0/library/Init/Lean/Compiler/IR/ResetReuse.c b/stage0/stdlib/Init/Lean/Compiler/IR/ResetReuse.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/ResetReuse.c rename to stage0/stdlib/Init/Lean/Compiler/IR/ResetReuse.c diff --git a/stage0/library/Init/Lean/Compiler/IR/SimpCase.c b/stage0/stdlib/Init/Lean/Compiler/IR/SimpCase.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/SimpCase.c rename to stage0/stdlib/Init/Lean/Compiler/IR/SimpCase.c diff --git a/stage0/library/Init/Lean/Compiler/IR/UnboxResult.c b/stage0/stdlib/Init/Lean/Compiler/IR/UnboxResult.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/IR/UnboxResult.c rename to stage0/stdlib/Init/Lean/Compiler/IR/UnboxResult.c diff --git a/stage0/library/Init/Lean/Compiler/ImplementedByAttr.c b/stage0/stdlib/Init/Lean/Compiler/ImplementedByAttr.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/ImplementedByAttr.c rename to stage0/stdlib/Init/Lean/Compiler/ImplementedByAttr.c diff --git a/stage0/library/Init/Lean/Compiler/InitAttr.c b/stage0/stdlib/Init/Lean/Compiler/InitAttr.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/InitAttr.c rename to stage0/stdlib/Init/Lean/Compiler/InitAttr.c diff --git a/stage0/library/Init/Lean/Compiler/InlineAttrs.c b/stage0/stdlib/Init/Lean/Compiler/InlineAttrs.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/InlineAttrs.c rename to stage0/stdlib/Init/Lean/Compiler/InlineAttrs.c diff --git a/stage0/library/Init/Lean/Compiler/NameMangling.c b/stage0/stdlib/Init/Lean/Compiler/NameMangling.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/NameMangling.c rename to stage0/stdlib/Init/Lean/Compiler/NameMangling.c diff --git a/stage0/library/Init/Lean/Compiler/NeverExtractAttr.c b/stage0/stdlib/Init/Lean/Compiler/NeverExtractAttr.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/NeverExtractAttr.c rename to stage0/stdlib/Init/Lean/Compiler/NeverExtractAttr.c diff --git a/stage0/library/Init/Lean/Compiler/Specialize.c b/stage0/stdlib/Init/Lean/Compiler/Specialize.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/Specialize.c rename to stage0/stdlib/Init/Lean/Compiler/Specialize.c diff --git a/stage0/library/Init/Lean/Compiler/Util.c b/stage0/stdlib/Init/Lean/Compiler/Util.c similarity index 100% rename from stage0/library/Init/Lean/Compiler/Util.c rename to stage0/stdlib/Init/Lean/Compiler/Util.c diff --git a/stage0/library/Init/Lean/Declaration.c b/stage0/stdlib/Init/Lean/Declaration.c similarity index 100% rename from stage0/library/Init/Lean/Declaration.c rename to stage0/stdlib/Init/Lean/Declaration.c diff --git a/stage0/library/Init/Lean/Elaborator.c b/stage0/stdlib/Init/Lean/Elaborator.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator.c rename to stage0/stdlib/Init/Lean/Elaborator.c diff --git a/stage0/library/Init/Lean/Elaborator/Alias.c b/stage0/stdlib/Init/Lean/Elaborator/Alias.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator/Alias.c rename to stage0/stdlib/Init/Lean/Elaborator/Alias.c diff --git a/stage0/library/Init/Lean/Elaborator/Basic.c b/stage0/stdlib/Init/Lean/Elaborator/Basic.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator/Basic.c rename to stage0/stdlib/Init/Lean/Elaborator/Basic.c diff --git a/stage0/library/Init/Lean/Elaborator/Command.c b/stage0/stdlib/Init/Lean/Elaborator/Command.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator/Command.c rename to stage0/stdlib/Init/Lean/Elaborator/Command.c diff --git a/stage0/library/Init/Lean/Elaborator/ElabStrategyAttrs.c b/stage0/stdlib/Init/Lean/Elaborator/ElabStrategyAttrs.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator/ElabStrategyAttrs.c rename to stage0/stdlib/Init/Lean/Elaborator/ElabStrategyAttrs.c diff --git a/stage0/library/Init/Lean/Elaborator/PreTerm.c b/stage0/stdlib/Init/Lean/Elaborator/PreTerm.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator/PreTerm.c rename to stage0/stdlib/Init/Lean/Elaborator/PreTerm.c diff --git a/stage0/library/Init/Lean/Elaborator/ResolveName.c b/stage0/stdlib/Init/Lean/Elaborator/ResolveName.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator/ResolveName.c rename to stage0/stdlib/Init/Lean/Elaborator/ResolveName.c diff --git a/stage0/library/Init/Lean/Elaborator/Term.c b/stage0/stdlib/Init/Lean/Elaborator/Term.c similarity index 100% rename from stage0/library/Init/Lean/Elaborator/Term.c rename to stage0/stdlib/Init/Lean/Elaborator/Term.c diff --git a/stage0/library/Init/Lean/Environment.c b/stage0/stdlib/Init/Lean/Environment.c similarity index 100% rename from stage0/library/Init/Lean/Environment.c rename to stage0/stdlib/Init/Lean/Environment.c diff --git a/stage0/library/Init/Lean/EqnCompiler.c b/stage0/stdlib/Init/Lean/EqnCompiler.c similarity index 100% rename from stage0/library/Init/Lean/EqnCompiler.c rename to stage0/stdlib/Init/Lean/EqnCompiler.c diff --git a/stage0/library/Init/Lean/EqnCompiler/MatchPattern.c b/stage0/stdlib/Init/Lean/EqnCompiler/MatchPattern.c similarity index 100% rename from stage0/library/Init/Lean/EqnCompiler/MatchPattern.c rename to stage0/stdlib/Init/Lean/EqnCompiler/MatchPattern.c diff --git a/stage0/library/Init/Lean/Expr.c b/stage0/stdlib/Init/Lean/Expr.c similarity index 100% rename from stage0/library/Init/Lean/Expr.c rename to stage0/stdlib/Init/Lean/Expr.c diff --git a/stage0/library/Init/Lean/Format.c b/stage0/stdlib/Init/Lean/Format.c similarity index 100% rename from stage0/library/Init/Lean/Format.c rename to stage0/stdlib/Init/Lean/Format.c diff --git a/stage0/library/Init/Lean/KVMap.c b/stage0/stdlib/Init/Lean/KVMap.c similarity index 100% rename from stage0/library/Init/Lean/KVMap.c rename to stage0/stdlib/Init/Lean/KVMap.c diff --git a/stage0/library/Init/Lean/LBool.c b/stage0/stdlib/Init/Lean/LBool.c similarity index 100% rename from stage0/library/Init/Lean/LBool.c rename to stage0/stdlib/Init/Lean/LBool.c diff --git a/stage0/library/Init/Lean/LOption.c b/stage0/stdlib/Init/Lean/LOption.c similarity index 100% rename from stage0/library/Init/Lean/LOption.c rename to stage0/stdlib/Init/Lean/LOption.c diff --git a/stage0/library/Init/Lean/Level.c b/stage0/stdlib/Init/Lean/Level.c similarity index 100% rename from stage0/library/Init/Lean/Level.c rename to stage0/stdlib/Init/Lean/Level.c diff --git a/stage0/library/Init/Lean/Linter.c b/stage0/stdlib/Init/Lean/Linter.c similarity index 100% rename from stage0/library/Init/Lean/Linter.c rename to stage0/stdlib/Init/Lean/Linter.c diff --git a/stage0/library/Init/Lean/LocalContext.c b/stage0/stdlib/Init/Lean/LocalContext.c similarity index 100% rename from stage0/library/Init/Lean/LocalContext.c rename to stage0/stdlib/Init/Lean/LocalContext.c diff --git a/stage0/library/Init/Lean/Message.c b/stage0/stdlib/Init/Lean/Message.c similarity index 100% rename from stage0/library/Init/Lean/Message.c rename to stage0/stdlib/Init/Lean/Message.c diff --git a/stage0/library/Init/Lean/Meta.c b/stage0/stdlib/Init/Lean/Meta.c similarity index 100% rename from stage0/library/Init/Lean/Meta.c rename to stage0/stdlib/Init/Lean/Meta.c diff --git a/stage0/library/Init/Lean/Meta/Basic.c b/stage0/stdlib/Init/Lean/Meta/Basic.c similarity index 100% rename from stage0/library/Init/Lean/Meta/Basic.c rename to stage0/stdlib/Init/Lean/Meta/Basic.c diff --git a/stage0/library/Init/Lean/Meta/Check.c b/stage0/stdlib/Init/Lean/Meta/Check.c similarity index 100% rename from stage0/library/Init/Lean/Meta/Check.c rename to stage0/stdlib/Init/Lean/Meta/Check.c diff --git a/stage0/library/Init/Lean/Meta/Exception.c b/stage0/stdlib/Init/Lean/Meta/Exception.c similarity index 100% rename from stage0/library/Init/Lean/Meta/Exception.c rename to stage0/stdlib/Init/Lean/Meta/Exception.c diff --git a/stage0/library/Init/Lean/Meta/ExprDefEq.c b/stage0/stdlib/Init/Lean/Meta/ExprDefEq.c similarity index 100% rename from stage0/library/Init/Lean/Meta/ExprDefEq.c rename to stage0/stdlib/Init/Lean/Meta/ExprDefEq.c diff --git a/stage0/library/Init/Lean/Meta/FunInfo.c b/stage0/stdlib/Init/Lean/Meta/FunInfo.c similarity index 100% rename from stage0/library/Init/Lean/Meta/FunInfo.c rename to stage0/stdlib/Init/Lean/Meta/FunInfo.c diff --git a/stage0/library/Init/Lean/Meta/InferType.c b/stage0/stdlib/Init/Lean/Meta/InferType.c similarity index 100% rename from stage0/library/Init/Lean/Meta/InferType.c rename to stage0/stdlib/Init/Lean/Meta/InferType.c diff --git a/stage0/library/Init/Lean/Meta/LevelDefEq.c b/stage0/stdlib/Init/Lean/Meta/LevelDefEq.c similarity index 100% rename from stage0/library/Init/Lean/Meta/LevelDefEq.c rename to stage0/stdlib/Init/Lean/Meta/LevelDefEq.c diff --git a/stage0/library/Init/Lean/Meta/Offset.c b/stage0/stdlib/Init/Lean/Meta/Offset.c similarity index 100% rename from stage0/library/Init/Lean/Meta/Offset.c rename to stage0/stdlib/Init/Lean/Meta/Offset.c diff --git a/stage0/library/Init/Lean/Meta/WHNF.c b/stage0/stdlib/Init/Lean/Meta/WHNF.c similarity index 100% rename from stage0/library/Init/Lean/Meta/WHNF.c rename to stage0/stdlib/Init/Lean/Meta/WHNF.c diff --git a/stage0/library/Init/Lean/MetavarContext.c b/stage0/stdlib/Init/Lean/MetavarContext.c similarity index 100% rename from stage0/library/Init/Lean/MetavarContext.c rename to stage0/stdlib/Init/Lean/MetavarContext.c diff --git a/stage0/library/Init/Lean/Modifiers.c b/stage0/stdlib/Init/Lean/Modifiers.c similarity index 100% rename from stage0/library/Init/Lean/Modifiers.c rename to stage0/stdlib/Init/Lean/Modifiers.c diff --git a/stage0/library/Init/Lean/MonadCache.c b/stage0/stdlib/Init/Lean/MonadCache.c similarity index 100% rename from stage0/library/Init/Lean/MonadCache.c rename to stage0/stdlib/Init/Lean/MonadCache.c diff --git a/stage0/library/Init/Lean/Name.c b/stage0/stdlib/Init/Lean/Name.c similarity index 100% rename from stage0/library/Init/Lean/Name.c rename to stage0/stdlib/Init/Lean/Name.c diff --git a/stage0/library/Init/Lean/NameGenerator.c b/stage0/stdlib/Init/Lean/NameGenerator.c similarity index 100% rename from stage0/library/Init/Lean/NameGenerator.c rename to stage0/stdlib/Init/Lean/NameGenerator.c diff --git a/stage0/library/Init/Lean/Options.c b/stage0/stdlib/Init/Lean/Options.c similarity index 100% rename from stage0/library/Init/Lean/Options.c rename to stage0/stdlib/Init/Lean/Options.c diff --git a/stage0/library/Init/Lean/Parser.c b/stage0/stdlib/Init/Lean/Parser.c similarity index 100% rename from stage0/library/Init/Lean/Parser.c rename to stage0/stdlib/Init/Lean/Parser.c diff --git a/stage0/library/Init/Lean/Parser/Command.c b/stage0/stdlib/Init/Lean/Parser/Command.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Command.c rename to stage0/stdlib/Init/Lean/Parser/Command.c diff --git a/stage0/library/Init/Lean/Parser/Identifier.c b/stage0/stdlib/Init/Lean/Parser/Identifier.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Identifier.c rename to stage0/stdlib/Init/Lean/Parser/Identifier.c diff --git a/stage0/library/Init/Lean/Parser/Level.c b/stage0/stdlib/Init/Lean/Parser/Level.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Level.c rename to stage0/stdlib/Init/Lean/Parser/Level.c diff --git a/stage0/library/Init/Lean/Parser/Module.c b/stage0/stdlib/Init/Lean/Parser/Module.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Module.c rename to stage0/stdlib/Init/Lean/Parser/Module.c diff --git a/stage0/library/Init/Lean/Parser/Parser.c b/stage0/stdlib/Init/Lean/Parser/Parser.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Parser.c rename to stage0/stdlib/Init/Lean/Parser/Parser.c diff --git a/stage0/library/Init/Lean/Parser/Term.c b/stage0/stdlib/Init/Lean/Parser/Term.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Term.c rename to stage0/stdlib/Init/Lean/Parser/Term.c diff --git a/stage0/library/Init/Lean/Parser/Transform.c b/stage0/stdlib/Init/Lean/Parser/Transform.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Transform.c rename to stage0/stdlib/Init/Lean/Parser/Transform.c diff --git a/stage0/library/Init/Lean/Parser/Trie.c b/stage0/stdlib/Init/Lean/Parser/Trie.c similarity index 100% rename from stage0/library/Init/Lean/Parser/Trie.c rename to stage0/stdlib/Init/Lean/Parser/Trie.c diff --git a/stage0/library/Init/Lean/Path.c b/stage0/stdlib/Init/Lean/Path.c similarity index 100% rename from stage0/library/Init/Lean/Path.c rename to stage0/stdlib/Init/Lean/Path.c diff --git a/stage0/library/Init/Lean/Position.c b/stage0/stdlib/Init/Lean/Position.c similarity index 100% rename from stage0/library/Init/Lean/Position.c rename to stage0/stdlib/Init/Lean/Position.c diff --git a/stage0/library/Init/Lean/ProjFns.c b/stage0/stdlib/Init/Lean/ProjFns.c similarity index 100% rename from stage0/library/Init/Lean/ProjFns.c rename to stage0/stdlib/Init/Lean/ProjFns.c diff --git a/stage0/library/Init/Lean/ReducibilityAttrs.c b/stage0/stdlib/Init/Lean/ReducibilityAttrs.c similarity index 100% rename from stage0/library/Init/Lean/ReducibilityAttrs.c rename to stage0/stdlib/Init/Lean/ReducibilityAttrs.c diff --git a/stage0/library/Init/Lean/Runtime.c b/stage0/stdlib/Init/Lean/Runtime.c similarity index 100% rename from stage0/library/Init/Lean/Runtime.c rename to stage0/stdlib/Init/Lean/Runtime.c diff --git a/stage0/library/Init/Lean/SMap.c b/stage0/stdlib/Init/Lean/SMap.c similarity index 100% rename from stage0/library/Init/Lean/SMap.c rename to stage0/stdlib/Init/Lean/SMap.c diff --git a/stage0/library/Init/Lean/Scopes.c b/stage0/stdlib/Init/Lean/Scopes.c similarity index 100% rename from stage0/library/Init/Lean/Scopes.c rename to stage0/stdlib/Init/Lean/Scopes.c diff --git a/stage0/library/Init/Lean/Syntax.c b/stage0/stdlib/Init/Lean/Syntax.c similarity index 100% rename from stage0/library/Init/Lean/Syntax.c rename to stage0/stdlib/Init/Lean/Syntax.c diff --git a/stage0/library/Init/Lean/ToExpr.c b/stage0/stdlib/Init/Lean/ToExpr.c similarity index 100% rename from stage0/library/Init/Lean/ToExpr.c rename to stage0/stdlib/Init/Lean/ToExpr.c diff --git a/stage0/library/Init/Lean/Trace.c b/stage0/stdlib/Init/Lean/Trace.c similarity index 100% rename from stage0/library/Init/Lean/Trace.c rename to stage0/stdlib/Init/Lean/Trace.c diff --git a/stage0/library/Init/Lean/TypeClass.c b/stage0/stdlib/Init/Lean/TypeClass.c similarity index 100% rename from stage0/library/Init/Lean/TypeClass.c rename to stage0/stdlib/Init/Lean/TypeClass.c diff --git a/stage0/library/Init/Lean/TypeClass/Basic.c b/stage0/stdlib/Init/Lean/TypeClass/Basic.c similarity index 100% rename from stage0/library/Init/Lean/TypeClass/Basic.c rename to stage0/stdlib/Init/Lean/TypeClass/Basic.c diff --git a/stage0/library/Init/Lean/TypeClass/Context.c b/stage0/stdlib/Init/Lean/TypeClass/Context.c similarity index 100% rename from stage0/library/Init/Lean/TypeClass/Context.c rename to stage0/stdlib/Init/Lean/TypeClass/Context.c diff --git a/stage0/library/Init/Lean/TypeClass/Synth.c b/stage0/stdlib/Init/Lean/TypeClass/Synth.c similarity index 100% rename from stage0/library/Init/Lean/TypeClass/Synth.c rename to stage0/stdlib/Init/Lean/TypeClass/Synth.c diff --git a/stage0/library/Init/Lean/Util.c b/stage0/stdlib/Init/Lean/Util.c similarity index 100% rename from stage0/library/Init/Lean/Util.c rename to stage0/stdlib/Init/Lean/Util.c diff --git a/stage0/library/Init/Lean/WHNF.c b/stage0/stdlib/Init/Lean/WHNF.c similarity index 100% rename from stage0/library/Init/Lean/WHNF.c rename to stage0/stdlib/Init/Lean/WHNF.c diff --git a/stage0/library/Init/System.c b/stage0/stdlib/Init/System.c similarity index 100% rename from stage0/library/Init/System.c rename to stage0/stdlib/Init/System.c diff --git a/stage0/library/Init/System/FilePath.c b/stage0/stdlib/Init/System/FilePath.c similarity index 100% rename from stage0/library/Init/System/FilePath.c rename to stage0/stdlib/Init/System/FilePath.c diff --git a/stage0/library/Init/System/IO.c b/stage0/stdlib/Init/System/IO.c similarity index 100% rename from stage0/library/Init/System/IO.c rename to stage0/stdlib/Init/System/IO.c diff --git a/stage0/library/Init/System/Platform.c b/stage0/stdlib/Init/System/Platform.c similarity index 100% rename from stage0/library/Init/System/Platform.c rename to stage0/stdlib/Init/System/Platform.c diff --git a/stage0/library/Init/Util.c b/stage0/stdlib/Init/Util.c similarity index 100% rename from stage0/library/Init/Util.c rename to stage0/stdlib/Init/Util.c diff --git a/stage0/library/Init/WF.c b/stage0/stdlib/Init/WF.c similarity index 100% rename from stage0/library/Init/WF.c rename to stage0/stdlib/Init/WF.c