/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Util.CollectFVars
import Lean.Meta.Match.MatchPatternAttr
import Lean.Meta.Match.Match
import Lean.Meta.SortLocalDecls
import Lean.Meta.GeneralizeVars
import Lean.Elab.SyntheticMVars
import Lean.Elab.Arg
import Lean.Parser.Term
import Lean.Elab.PatternVar

namespace Lean.Elab.Term
open Meta
open Lean.Parser.Term

private def expandSimpleMatch (stx discr lhsVar rhs : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
  let newStx ← `(let $lhsVar := $discr; $rhs)
  withMacroExpansion stx newStx <| elabTerm newStx expectedType?

private def mkUserNameFor (e : Expr) : TermElabM Name := do
  match e with
  /- Remark: we use `mkFreshUserName` to make sure we don't add a variable to the local context that can be resolved to `e`. -/
  | Expr.fvar fvarId _ => mkFreshUserName ((← getLocalDecl fvarId).userName)
  | _                  => mkFreshBinderName

/-- Return true iff `n` is an auxiliary variable created by `expandNonAtomicDiscrs?` -/
def isAuxDiscrName (n : Name) : Bool :=
  n.hasMacroScopes && n.eraseMacroScopes == `_discr

/- We treat `@x` as atomic to avoid unnecessary extra local declarations from being
   inserted into the local context. Recall that `expandMatchAltsIntoMatch` uses `@` modifier.
   Thus this is kind of discriminant is quite common.

   Remark: if the discriminat is `Systax.missing`, we abort the elaboration of the `match`-expression.
   This can happen due to error recovery. Example
   ```
   example : (p ∨ p) → p := fun h => match
   ```
   If we don't abort, the elaborator loops because we will keep trying to expand
   ```
   match
   ```
   into
   ```
   let d := <Syntax.missing>; match
   ```
   Recall that `Syntax.setArg stx i arg` is a no-op when `i` is out-of-bounds. -/
def isAtomicDiscr? (discr : Syntax) : TermElabM (Option Expr) := do
  match discr with
  | `($x:ident)  => isLocalIdent? x
  | `(@$x:ident) => isLocalIdent? x
  | _ => if discr.isMissing then throwAbortTerm else return none

-- See expandNonAtomicDiscrs?
private def elabAtomicDiscr (discr : Syntax) : TermElabM Expr := do
  let term := discr[1]
  match (← isAtomicDiscr? term) with
  | some e@(Expr.fvar fvarId _) =>
    let localDecl ← getLocalDecl fvarId
    if !isAuxDiscrName localDecl.userName then
      return e -- it is not an auxiliary local created by `expandNonAtomicDiscrs?`
    else
      instantiateMVars localDecl.value
  | _ => throwErrorAt discr "unexpected discriminant"

structure ElabMatchTypeAndDiscrsResult where
  discrs    : Array Expr
  matchType : Expr
  /- `true` when performing dependent elimination. We use this to decide whether we optimize the "match unit" case.
     See `isMatchUnit?`. -/
  isDep     : Bool
  alts      : Array MatchAltView

private partial def elabMatchTypeAndDiscrs (discrStxs : Array Syntax) (matchOptType : Syntax) (matchAltViews : Array MatchAltView) (expectedType : Expr)
      : TermElabM ElabMatchTypeAndDiscrsResult := do
    let numDiscrs := discrStxs.size
    if matchOptType.isNone then
      elabDiscrs 0 #[]
    else
      let matchTypeStx := matchOptType[0][1]
      let matchType ← elabType matchTypeStx
      let (discrs, isDep) ← elabDiscrsWitMatchType matchType expectedType
      return { discrs := discrs, matchType := matchType, isDep := isDep, alts := matchAltViews }
  where
    /- Easy case: elaborate discriminant when the match-type has been explicitly provided by the user.  -/
    elabDiscrsWitMatchType (matchType : Expr) (expectedType : Expr) : TermElabM (Array Expr × Bool) := do
      let mut discrs := #[]
      let mut i := 0
      let mut matchType := matchType
      let mut isDep := false
      for discrStx in discrStxs do
        i := i + 1
        matchType ← whnf matchType
        match matchType with
        | Expr.forallE _ d b _ =>
          let discr ← fullApproxDefEq <| elabTermEnsuringType discrStx[1] d
          trace[Elab.match] "discr #{i} {discr} : {d}"
          if b.hasLooseBVars then
            isDep := true
          matchType ← b.instantiate1 discr
          discrs := discrs.push discr
        | _ =>
          throwError "invalid type provided to match-expression, function type with arity #{discrStxs.size} expected"
      return (discrs, isDep)

    markIsDep (r : ElabMatchTypeAndDiscrsResult) :=
      { r with isDep := true }

    /- Elaborate discriminants inferring the match-type -/
    elabDiscrs (i : Nat) (discrs : Array Expr) : TermElabM ElabMatchTypeAndDiscrsResult := do
      if h : i < discrStxs.size then
        let discrStx := discrStxs.get ⟨i, h⟩
        let discr     ← elabAtomicDiscr discrStx
        let discr     ← instantiateMVars discr
        let discrType ← inferType discr
        let discrType ← instantiateMVars discrType
        let discrs    := discrs.push discr
        let userName ← mkUserNameFor discr
        if discrStx[0].isNone then
          let mut result ← elabDiscrs (i + 1) discrs
          let matchTypeBody ← kabstract result.matchType discr
          if matchTypeBody.hasLooseBVars then
            result := markIsDep result
          return { result with matchType := Lean.mkForall userName BinderInfo.default discrType matchTypeBody }
        else
          let discrs := discrs.push (← mkEqRefl discr)
          let result ← elabDiscrs (i + 1) discrs
          let result := markIsDep result
          let identStx := discrStx[0][0]
          withLocalDeclD userName discrType fun x => do
            let eqType ← mkEq discr x
            withLocalDeclD identStx.getId eqType fun h => do
              let matchTypeBody ← kabstract result.matchType discr
              let matchTypeBody := matchTypeBody.instantiate1 x
              let matchType ← mkForallFVars #[x, h] matchTypeBody
              return { result with
                matchType := matchType
                alts      := result.alts.map fun altView => { altView with patterns := altView.patterns.insertAt (i+1) identStx }
              }
      else
        return { discrs, alts := matchAltViews, isDep := false, matchType := expectedType }

def expandMacrosInPatterns (matchAlts : Array MatchAltView) : MacroM (Array MatchAltView) := do
  matchAlts.mapM fun matchAlt => do
    let patterns ← matchAlt.patterns.mapM expandMacros
    pure { matchAlt with patterns := patterns }

private def getMatchGeneralizing? : Syntax → Option Bool
  | `(match (generalizing := true)  $discrs,* $[: $ty?]? with $alts:matchAlt*) => some true
  | `(match (generalizing := false) $discrs,* $[: $ty?]? with $alts:matchAlt*) => some false
  | _ => none

/- Given `stx` a match-expression, return its alternatives. -/
private def getMatchAlts : Syntax → Array MatchAltView
  | `(match $[$gen]? $discrs,* $[: $ty?]? with $alts:matchAlt*) =>
    alts.filterMap fun alt => match alt with
      | `(matchAltExpr| | $patterns,* => $rhs) => some {
          ref      := alt,
          patterns := patterns,
          rhs      := rhs
        }
      | _ => none
  | _ => #[]

builtin_initialize Parser.registerBuiltinNodeKind `MVarWithIdKind

open Meta.Match (mkInaccessible inaccessible?)

/--
  The elaboration function for `Syntax` created using `mkMVarSyntax`.
  It just converts the metavariable id wrapped by the Syntax into an `Expr`. -/
@[builtinTermElab MVarWithIdKind] def elabMVarWithIdKind : TermElab := fun stx expectedType? =>
  return mkInaccessible <| mkMVar (getMVarSyntaxMVarId stx)

@[builtinTermElab inaccessible] def elabInaccessible : TermElab := fun stx expectedType? => do
  let e ← elabTerm stx[1] expectedType?
  return mkInaccessible e

open Lean.Elab.Term.Quotation in
@[builtinQuotPrecheck Lean.Parser.Term.match] def precheckMatch : Precheck
  | `(match $[$discrs:term],* with $[| $[$patss],* => $rhss]*) => do
    discrs.forM precheck
    for (pats, rhs) in patss.zip rhss do
      let vars ←
        try
          getPatternsVars pats
        catch
          | _ => return  -- can happen in case of pattern antiquotations
      Quotation.withNewLocals (getPatternVarNames vars) <| precheck rhs
  | _ => throwUnsupportedSyntax

/- We convert the collected `PatternVar`s intro `PatternVarDecl` -/
inductive PatternVarDecl where
  /- For `anonymousVar`, we create both a metavariable and a free variable. The free variable is used as an assignment for the metavariable
     when it is not assigned during pattern elaboration. -/
  | anonymousVar (mvarId : MVarId) (fvarId : FVarId)
  | localVar     (fvarId : FVarId)

private partial def withPatternVars {α} (pVars : Array PatternVar) (k : Array PatternVarDecl → TermElabM α) : TermElabM α :=
  let rec loop (i : Nat) (decls : Array PatternVarDecl) := do
    if h : i < pVars.size then
      match pVars.get ⟨i, h⟩ with
      | PatternVar.anonymousVar mvarId =>
        let type ← mkFreshTypeMVar
        let userName ← mkFreshBinderName
        withLocalDecl userName BinderInfo.default type fun x =>
          loop (i+1) (decls.push (PatternVarDecl.anonymousVar mvarId x.fvarId!))
      | PatternVar.localVar userName   =>
        let type ← mkFreshTypeMVar
        withLocalDecl userName BinderInfo.default type fun x =>
          loop (i+1) (decls.push (PatternVarDecl.localVar x.fvarId!))
    else
      /- We must create the metavariables for `PatternVar.anonymousVar` AFTER we create the new local decls using `withLocalDecl`.
         Reason: their scope must include the new local decls since some of them are assigned by typing constraints. -/
      decls.forM fun decl => match decl with
        | PatternVarDecl.anonymousVar mvarId fvarId => do
          let type ← inferType (mkFVar fvarId)
          discard <| mkFreshExprMVarWithId mvarId type
        | _ => pure ()
      k decls
  loop 0 #[]

/-
Remark: when performing dependent pattern matching, we often had to write code such as

```lean
def Vec.map' (f : α → β) (xs : Vec α n) : Vec β n :=
  match n, xs with
  | _, nil       => nil
  | _, cons a as => cons (f a) (map' f as)
```
We had to include `n` and the `_`s because the type of `xs` depends on `n`.
Moreover, `nil` and `cons a as` have different types.
This was quite tedious. So, we have implemented an automatic "discriminant refinement procedure".
The procedure is based on the observation that we get a type error whenenver we forget to include `_`s
and the indices a discriminant depends on. So, we catch the exception, check whether the type of the discriminant
is an indexed family, and add their indices as new discriminants.

The current implementation, adds indices as they are found, and does not
try to "sort" the new discriminants.

If the refinement process fails, we report the original error message.
-/

/- Auxiliary structure for storing an type mismatch exception when processing the
   pattern #`idx` of some alternative. -/
structure PatternElabException where
  ex          : Exception
  patternIdx  : Nat -- Discriminant that sh
  pathToIndex : List Nat -- Path to the problematic inductive type index that produced the type mismatch

/--
  This method is part of the "discriminant refinement" procedure. It in invoked when the
  type of the `pattern` does not match the expected type. The expected type is based on the
  motive computed using the `match` discriminants.
  It tries to compute a path to an index of the discriminant type.
  For example, suppose the user has written
  ```
  inductive Mem (a : α) : List α → Prop where
    | head {as} : Mem a (a::as)
    | tail {as} : Mem a as → Mem a (a'::as)

  infix:50 " ∈ " => Mem

  example (a b : Nat) (h : a ∈ [b]) : b = a :=
  match h with
  | Mem.head => rfl
  ```
  The motive for the match is `a ∈ [b] → b = a`, and get a type mismatch between the type
  of `Mem.head` and `a ∈ [b]`. This procedure return the path `[2, 1]` to the index `b`.
  We use it to produce the following refinement
  ```
  example (a b : Nat) (h : a ∈ [b]) : b = a :=
  match b, h with
  | _, Mem.head => rfl
  ```
  which produces the new motive `(x : Nat) →  a ∈ [x] → x = a`
  After this refinement step, the `match` is elaborated successfully.

  This method relies on the fact that the dependent pattern matcher compiler solves equations
  between indices of indexed inductive families.
  The following kinds of equations are supported by this compiler:
  - `x = t`
  - `t = x`
  - `ctor ... = ctor ...`

  where `x` is a free variable, `t` is an arbitrary term, and `ctor` is constructor.
  Our procedure ensures that "information" is not lost, and will *not* succeed in an
  example such as
  ```
  example (a b : Nat) (f : Nat → Nat) (h : f a ∈ [f b]) : f b = f a :=
    match h with
    | Mem.head => rfl
  ```
  and will not add `f b` as a new discriminant. We may add an option in the future to
  enable this more liberal form of refinement.
-/
private partial def findDiscrRefinementPath (pattern : Expr) (expected : Expr) : OptionT MetaM (List Nat) := do
  goType (← instantiateMVars (← inferType pattern)) expected
where
  checkCompatibleApps (t d : Expr) : OptionT MetaM Unit := do
    guard d.isApp
    guard <| t.getAppNumArgs == d.getAppNumArgs
    let tFn := t.getAppFn
    let dFn := d.getAppFn
    guard <| tFn.isConst && dFn.isConst
    guard (← isDefEq tFn dFn)

  -- Visitor for inductive types
  goType (t d : Expr) : OptionT MetaM (List Nat) := do
    trace[Meta.debug] "type {t} =?= {d}"
    let t ← whnf t
    let d ← whnf d
    checkCompatibleApps t d
    matchConstInduct t.getAppFn (fun _ => failure) fun info _ => do
      let tArgs := t.getAppArgs
      let dArgs := d.getAppArgs
      for i in [:info.numParams] do
        let tArg := tArgs[i]
        let dArg := dArgs[i]
        unless (← isDefEq tArg dArg) do
          return i :: (← goType tArg dArg)
      for i in [info.numParams : tArgs.size] do
        let tArg := tArgs[i]
        let dArg := dArgs[i]
        unless (← isDefEq tArg dArg) do
          return i :: (← goIndex tArg dArg)
      failure

  -- Visitor for indexed families
  goIndex (t d : Expr) : OptionT MetaM (List Nat) := do
    let t ← whnfD t
    let d ← whnfD d
    if t.isFVar || d.isFVar then
      return [] -- Found refinement path
    else
      trace[Meta.debug] "index {t} =?= {d}"
      checkCompatibleApps t d
      matchConstCtor t.getAppFn (fun _ => failure) fun info _ => do
        let tArgs := t.getAppArgs
        let dArgs := d.getAppArgs
        for i in [:info.numParams] do
          let tArg := tArgs[i]
          let dArg := dArgs[i]
          unless (← isDefEq tArg dArg) do
            failure
        for i in [info.numParams : tArgs.size] do
          let tArg := tArgs[i]
          let dArg := dArgs[i]
          unless (← isDefEq tArg dArg) do
            return i :: (← goIndex tArg dArg)
        failure

private partial def eraseIndices (type : Expr) : MetaM Expr := do
  let type' ← whnfD type
  matchConstInduct type'.getAppFn (fun _ => return type) fun info _ => do
    let args := type'.getAppArgs
    let params ← args[:info.numParams].toArray.mapM eraseIndices
    let result := mkAppN type'.getAppFn params
    let resultType ← inferType result
    let (newIndices, _, _) ←  forallMetaTelescopeReducing resultType (some (args.size - info.numParams))
    return mkAppN result newIndices

private def elabPatterns (patternStxs : Array Syntax) (matchType : Expr) : ExceptT PatternElabException TermElabM (Array Expr × Expr) :=
  withReader (fun ctx => { ctx with implicitLambda := false }) do
    let mut patterns  := #[]
    let mut matchType := matchType
    for idx in [:patternStxs.size] do
      let patternStx := patternStxs[idx]
      matchType ← whnf matchType
      match matchType with
      | Expr.forallE _ d b _ =>
        let pattern ← do
          let s ← saveState
          try
            liftM <| withSynthesize <| withoutErrToSorry <| elabTermEnsuringType patternStx d
          catch ex : Exception =>
            restoreState s
            match (← liftM <| commitIfNoErrors? <| withoutErrToSorry do elabTermAndSynthesize patternStx (← eraseIndices d)) with
            | some pattern =>
              match (← findDiscrRefinementPath pattern d |>.run) with
              | some path =>
                trace[Meta.debug] "refinement path: {path}"
                restoreState s
                -- Wrap the type mismatch exception for the "discriminant refinement" feature.
                throwThe PatternElabException { ex := ex, patternIdx := idx, pathToIndex := path }
              | none => restoreState s; throw ex
            | none => throw ex
        matchType := b.instantiate1 pattern
        patterns  := patterns.push pattern
      | _ => throwError "unexpected match type"
    return (patterns, matchType)

def finalizePatternDecls (patternVarDecls : Array PatternVarDecl) : TermElabM (Array LocalDecl) := do
  let mut decls := #[]
  for pdecl in patternVarDecls do
    match pdecl with
    | PatternVarDecl.localVar fvarId =>
      let decl ← getLocalDecl fvarId
      let decl ← instantiateLocalDeclMVars decl
      decls := decls.push decl
    | PatternVarDecl.anonymousVar mvarId fvarId =>
       let e ← instantiateMVars (mkMVar mvarId);
       trace[Elab.match] "finalizePatternDecls: mvarId: {mvarId} := {e}, fvar: {mkFVar fvarId}"
       match e with
       | Expr.mvar newMVarId _ =>
         /- Metavariable was not assigned, or assigned to another metavariable. So,
            we assign to the auxiliary free variable we created at `withPatternVars` to `newMVarId`. -/
         assignExprMVar newMVarId (mkFVar fvarId)
         trace[Elab.match] "finalizePatternDecls: {mkMVar newMVarId} := {mkFVar fvarId}"
         let decl ← getLocalDecl fvarId
         let decl ← instantiateLocalDeclMVars decl
         decls := decls.push decl
       | _ => pure ()
  /- We perform a topological sort (dependecies) on `decls` because the pattern elaboration process may produce a sequence where a declaration d₁ may occur after d₂ when d₂ depends on d₁. -/
  sortLocalDecls decls

open Meta.Match (Pattern Pattern.var Pattern.inaccessible Pattern.ctor Pattern.as Pattern.val Pattern.arrayLit AltLHS MatcherResult)

namespace ToDepElimPattern

structure State where
  found      : NameSet := {}
  localDecls : Array LocalDecl
  newLocals  : NameSet := {}

abbrev M := StateRefT State TermElabM

private def alreadyVisited (fvarId : FVarId) : M Bool := do
  let s ← get
  return s.found.contains fvarId

private def markAsVisited (fvarId : FVarId) : M Unit :=
  modify fun s => { s with found := s.found.insert fvarId }

private def throwInvalidPattern {α} (e : Expr) : M α :=
  throwError "invalid pattern {indentExpr e}"

/- Create a new LocalDecl `x` for the metavariable `mvar`, and return `Pattern.var x` -/
private def mkLocalDeclFor (mvar : Expr) : M Pattern := do
  let mvarId := mvar.mvarId!
  let s ← get
  match (← getExprMVarAssignment? mvarId) with
  | some val => return Pattern.inaccessible val
  | none =>
    let fvarId ← mkFreshId
    let type   ← inferType mvar
    /- HACK: `fvarId` is not in the scope of `mvarId`
       If this generates problems in the future, we should update the metavariable declarations. -/
    assignExprMVar mvarId (mkFVar fvarId)
    let userName ← mkFreshBinderName
    let newDecl := LocalDecl.cdecl arbitrary fvarId userName type BinderInfo.default;
    modify fun s =>
      { s with
        newLocals  := s.newLocals.insert fvarId,
        localDecls :=
        match s.localDecls.findIdx? fun decl => mvar.occurs decl.type with
        | none   => s.localDecls.push newDecl -- None of the existing declarations depend on `mvar`
        | some i => s.localDecls.insertAt i newDecl }
    return Pattern.var fvarId

partial def main (e : Expr) : M Pattern := do
  let isLocalDecl (fvarId : FVarId) : M Bool := do
    return (← get).localDecls.any fun d => d.fvarId == fvarId
  let mkPatternVar (fvarId : FVarId) (e : Expr) : M Pattern := do
    if (← alreadyVisited fvarId) then
      return Pattern.inaccessible e
    else
      markAsVisited fvarId
      return Pattern.var e.fvarId!
  let mkInaccessible (e : Expr) : M Pattern := do
    match e with
    | Expr.fvar fvarId _ =>
      if (← isLocalDecl fvarId) then
        mkPatternVar fvarId e
      else
        return Pattern.inaccessible e
    | _ =>
      return Pattern.inaccessible e
  match inaccessible? e with
  | some t => mkInaccessible t
  | none =>
    match e.arrayLit? with
    | some (α, lits) =>
      return Pattern.arrayLit α (← lits.mapM main)
    | none =>
      if e.isAppOfArity `namedPattern 3 then
        let p ← main <| e.getArg! 2
        match e.getArg! 1 with
        | Expr.fvar fvarId _ => return Pattern.as fvarId p
        | _                  => throwError "unexpected occurrence of auxiliary declaration 'namedPattern'"
      else if e.isNatLit || e.isStringLit || e.isCharLit then
        return Pattern.val e
      else if e.isFVar then
        let fvarId := e.fvarId!
        unless (← isLocalDecl fvarId) do
          throwInvalidPattern e
        mkPatternVar fvarId e
      else if e.isMVar then
        mkLocalDeclFor e
      else
        let newE ← whnf e
        if newE != e then
          main newE
        else matchConstCtor e.getAppFn (fun _ => throwInvalidPattern e) fun v us => do
          let args := e.getAppArgs
          unless args.size == v.numParams + v.numFields do
            throwInvalidPattern e
          let params := args.extract 0 v.numParams
          let fields := args.extract v.numParams args.size
          let fields ← fields.mapM main
          return Pattern.ctor v.name us params.toList fields.toList

end ToDepElimPattern

def withDepElimPatterns {α} (localDecls : Array LocalDecl) (ps : Array Expr) (k : Array LocalDecl → Array Pattern → TermElabM α) : TermElabM α := do
  let (patterns, s) ← (ps.mapM ToDepElimPattern.main).run { localDecls := localDecls }
  let localDecls ← s.localDecls.mapM fun d => instantiateLocalDeclMVars d
  /- toDepElimPatterns may have added new localDecls. Thus, we must update the local context before we execute `k` -/
  let lctx ← getLCtx
  let lctx := localDecls.foldl (fun (lctx : LocalContext) d => lctx.erase d.fvarId) lctx
  let lctx := localDecls.foldl (fun (lctx : LocalContext) d => lctx.addDecl d) lctx
  withTheReader Meta.Context (fun ctx => { ctx with lctx := lctx }) do
    k localDecls patterns

private def withElaboratedLHS {α} (ref : Syntax) (patternVarDecls : Array PatternVarDecl) (patternStxs : Array Syntax) (matchType : Expr)
    (k : AltLHS → Expr → TermElabM α) : ExceptT PatternElabException TermElabM α := do
  let (patterns, matchType) ← withSynthesize <| elabPatterns patternStxs matchType
  id (α := TermElabM α) do
    let localDecls ← finalizePatternDecls patternVarDecls
    let patterns ← patterns.mapM (instantiateMVars ·)
    withDepElimPatterns localDecls patterns fun localDecls patterns =>
      k { ref := ref, fvarDecls := localDecls.toList, patterns := patterns.toList } matchType

private def elabMatchAltView (alt : MatchAltView) (matchType : Expr) : ExceptT PatternElabException TermElabM (AltLHS × Expr) := withRef alt.ref do
  let (patternVars, alt) ← collectPatternVars alt
  trace[Elab.match] "patternVars: {patternVars}"
  withPatternVars patternVars fun patternVarDecls => do
    withElaboratedLHS alt.ref patternVarDecls alt.patterns matchType fun altLHS matchType => do
      let rhs ← elabTermEnsuringType alt.rhs matchType
      let xs := altLHS.fvarDecls.toArray.map LocalDecl.toExpr
      let rhs ← if xs.isEmpty then pure <| mkSimpleThunk rhs else mkLambdaFVars xs rhs
      trace[Elab.match] "rhs: {rhs}"
      return (altLHS, rhs)

/--
  Collect problematic index for the "discriminant refinement feature". This method is invoked
  when we detect a type mismatch at a pattern #`idx` of some alternative. -/
private partial def getIndexToInclude? (discr : Expr) (pathToIndex : List Nat) : TermElabM (Option Expr) := do
  go (← inferType discr) pathToIndex |>.run
where
  go (e : Expr) (path : List Nat) : OptionT MetaM Expr := do
    match path with
    | [] => return e
    | i::path =>
      let e ← whnfD e
      guard <| e.isApp && i < e.getAppNumArgs
      go (e.getArg! i) path

/--
  "Generalize" variables that depend on the discriminants.

  Remarks and limitations:
  - If `matchType` is a proposition, then we generalize even when the user did not provide `(generalizing := true)`.
    Motivation: users should have control about the actual `match`-expressions in their programs.
  - We currently do not generalize let-decls.
  - We abort generalization if the new `matchType` is type incorrect.
  - Only discriminants that are free variables are considered during specialization.
  - We "generalize" by adding new discriminants and pattern variables. We do not "clear" the generalized variables,
    but they become inaccessible since they are shadowed by the patterns variables. We assume this is ok since
    this is the exact behavior users would get if they had written it by hand. Recall there is no `clear` in term mode.
-/
private def generalize (discrs : Array Expr) (matchType : Expr) (altViews : Array MatchAltView) (generalizing? : Option Bool) : TermElabM (Array Expr × Expr × Array MatchAltView × Bool) := do
  let gen ←
    match generalizing? with
    | some g => pure g
    | _ => isProp matchType
  if !gen then
    return (discrs, matchType, altViews, false)
  else
    let ysFVarIds ← getFVarsToGeneralize discrs
    /- let-decls are currently being ignored by the generalizer. -/
    let ysFVarIds ← ysFVarIds.filterM fun fvarId => return !(← getLocalDecl fvarId).isLet
    if ysFVarIds.isEmpty then
      return (discrs, matchType, altViews, false)
    else
      let ys := ysFVarIds.map mkFVar
      -- trace[Meta.debug] "ys: {ys}, discrs: {discrs}"
      let matchType' ← forallBoundedTelescope matchType discrs.size fun ds type => do
        let type ← mkForallFVars ys type
        let (discrs', ds') := Array.unzip <| Array.zip discrs ds |>.filter fun (di, d) => di.isFVar
        let type := type.replaceFVars discrs' ds'
        mkForallFVars ds type
      -- trace[Meta.debug] "matchType': {matchType'}"
      if (← isTypeCorrect matchType') then
        let discrs := discrs ++ ys
        let altViews ← altViews.mapM fun altView => do
          let patternVars ← getPatternsVars altView.patterns
          -- We traverse backwards because we want to keep the most recent names.
          -- For example, if `ys` contains `#[h, h]`, we want to make sure `mkFreshUsername is applied to the first `h`,
          -- since it is already shadowed by the second.
          let ysUserNames ← ys.foldrM (init := #[]) fun ys ysUserNames => do
            let yDecl ← getLocalDecl ys.fvarId!
            let mut yUserName := yDecl.userName
            if ysUserNames.contains yUserName then
              yUserName ← mkFreshUserName yUserName
            -- Explicitly provided pattern variables shadow `y`
            else if patternVars.any fun | PatternVar.localVar x => x == yUserName | _ => false then
              yUserName ← mkFreshUserName yUserName
            return ysUserNames.push yUserName
          let ysIds ← ysUserNames.reverse.mapM fun n => return mkIdentFrom (← getRef) n
          return { altView with patterns := altView.patterns ++ ysIds }
        return (discrs, matchType', altViews, true)
      else
        return (discrs, matchType, altViews, true)

private partial def elabMatchAltViews (generalizing? : Option Bool) (discrs : Array Expr) (matchType : Expr) (altViews : Array MatchAltView) : TermElabM (Array Expr × Expr × Array (AltLHS × Expr) × Bool) := do
  loop discrs matchType altViews none
where
  /-
    "Discriminant refinement" main loop.
    `first?` contains the first error message we found before updated the `discrs`. -/
  loop (discrs : Array Expr) (matchType : Expr) (altViews : Array MatchAltView) (first? : Option (SavedState × Exception))
      : TermElabM (Array Expr × Expr × Array (AltLHS × Expr) × Bool) := do
    let s ← saveState
    let (discrs', matchType', altViews', refined) ← generalize discrs matchType altViews generalizing?
    match (← altViews'.mapM (fun altView => elabMatchAltView altView matchType') |>.run) with
    | Except.ok alts => return (discrs', matchType', alts, first?.isSome || refined)
    | Except.error { patternIdx := patternIdx, pathToIndex := pathToIndex, ex := ex } =>
      trace[Meta.debug] "pathToIndex: {toString pathToIndex}"
      let some index ← getIndexToInclude? discrs[patternIdx] pathToIndex
        | throwEx (← updateFirst first? ex)
      trace[Meta.debug] "index: {index}"
      if (← discrs.anyM fun discr => isDefEq discr index) then
        throwEx (← updateFirst first? ex)
      let first ← updateFirst first? ex
      s.restore
      let indices ← collectDeps #[index] discrs
      let matchType ←
        try
          updateMatchType indices matchType
        catch ex =>
          throwEx first
      let altViews  ← addWildcardPatterns indices.size altViews
      let discrs    := indices ++ discrs
      loop discrs matchType altViews first

  throwEx {α} (p : SavedState × Exception) : TermElabM α := do
    p.1.restore; throw p.2

  updateFirst (first? : Option (SavedState × Exception)) (ex : Exception) : TermElabM (SavedState × Exception) := do
    match first? with
    | none       => return (← saveState, ex)
    | some first => return first

  containsFVar (es : Array Expr) (fvarId : FVarId) : Bool :=
    es.any fun e => e.isFVar && e.fvarId! == fvarId

  /- Update `indices` by including any free variable `x` s.t.
     - Type of some `discr` depends on `x`.
     - Type of `x` depends on some free variable in `indices`.

     If we don't include these extra variables in indices, then
     `updateMatchType` will generate a type incorrect term.
     For example, suppose `discr` contains `h : @HEq α a α b`, and
     `indices` is `#[α, b]`, and `matchType` is `@HEq α a α b → B`.
     `updateMatchType indices matchType` produces the type
     `(α' : Type) → (b : α') → @HEq α' a α' b → B` which is type incorrect
     because we have `a : α`.
     The method `collectDeps` will include `a` into `indices`.

     This method does not handle dependencies among non-free variables.
     We rely on the type checking method `check` at `updateMatchType`.

     Remark: `indices : Array Expr` does not need to be an array anymore.
     We should cleanup this code, and use `index : Expr` instead.
   -/
  collectDeps (indices : Array Expr) (discrs : Array Expr) : TermElabM (Array Expr) := do
    let mut s : CollectFVars.State := {}
    for discr in discrs do
      s := collectFVars s (← instantiateMVars (← inferType discr))
    let (indicesFVar, indicesNonFVar) := indices.split Expr.isFVar
    let indicesFVar := indicesFVar.map Expr.fvarId!
    let mut toAdd := #[]
    for fvarId in s.fvarSet.toList do
      unless containsFVar discrs fvarId || containsFVar indices fvarId do
        let localDecl ← getLocalDecl fvarId
        let mctx ← getMCtx
        for indexFVarId in indicesFVar do
          if mctx.localDeclDependsOn localDecl indexFVarId then
            toAdd := toAdd.push fvarId
    let lctx ← getLCtx
    let indicesFVar := (indicesFVar ++ toAdd).qsort fun fvarId₁ fvarId₂ =>
      (lctx.get! fvarId₁).index < (lctx.get! fvarId₂).index
    return indicesFVar.map mkFVar ++ indicesNonFVar

  updateMatchType (indices : Array Expr) (matchType : Expr) : TermElabM Expr := do
    let matchType ← indices.foldrM (init := matchType) fun index matchType => do
      let indexType ← inferType index
      let matchTypeBody ← kabstract matchType index
      let userName ← mkUserNameFor index
      return Lean.mkForall userName BinderInfo.default indexType matchTypeBody
    check matchType
    return matchType

  addWildcardPatterns (num : Nat) (altViews : Array MatchAltView) : TermElabM (Array MatchAltView) := do
    let hole := mkHole (← getRef)
    let wildcards := mkArray num hole
    return altViews.map fun altView => { altView with patterns := wildcards ++ altView.patterns }

def mkMatcher (input : Meta.Match.MkMatcherInput) : TermElabM MatcherResult :=
  Meta.Match.mkMatcher input

register_builtin_option match.ignoreUnusedAlts : Bool := {
  defValue := false
  descr := "if true, do not generate error if an alternative is not used"
}

def reportMatcherResultErrors (altLHSS : List AltLHS) (result : MatcherResult) : TermElabM Unit := do
  unless result.counterExamples.isEmpty do
    withHeadRefOnly <| logError m!"missing cases:\n{Meta.Match.counterExamplesToMessageData result.counterExamples}"
  unless match.ignoreUnusedAlts.get (← getOptions) || result.unusedAltIdxs.isEmpty do
    let mut i := 0
    for alt in altLHSS do
      if result.unusedAltIdxs.contains i then
        withRef alt.ref do
          logError "redundant alternative"
      i := i + 1

/--
  If `altLHSS + rhss` is encoding `| PUnit.unit => rhs[0]`, return `rhs[0]`
  Otherwise, return none.
-/
private def isMatchUnit? (altLHSS : List Match.AltLHS) (rhss : Array Expr) : MetaM (Option Expr) := do
  assert! altLHSS.length == rhss.size
  match altLHSS with
  | [ { fvarDecls := [], patterns := [ Pattern.ctor `PUnit.unit .. ], .. } ] =>
    /- Recall that for alternatives of the form `| PUnit.unit => rhs`, `rhss[0]` is of the form `fun _ : Unit => b`. -/
    match rhss[0] with
    | Expr.lam _ _ b _ => return if b.hasLooseBVars then none else b
    | _ => return none
  | _ => return none
private def elabMatchAux (generalizing? : Option Bool) (discrStxs : Array Syntax) (altViews : Array MatchAltView) (matchOptType : Syntax) (expectedType : Expr)
    : TermElabM Expr := do
  let mut generalizing? := generalizing?
  if !matchOptType.isNone then
    if generalizing? == some true then
      throwError "the '(generalizing := true)' parameter is not supported when the 'match' type is explicitly provided"
    generalizing? := some false
  let (discrs, matchType, altLHSS, isDep, rhss) ← commitIfDidNotPostpone do
    let ⟨discrs, matchType, isDep, altViews⟩ ← elabMatchTypeAndDiscrs discrStxs matchOptType altViews expectedType
    let matchAlts ← liftMacroM <| expandMacrosInPatterns altViews
    trace[Elab.match] "matchType: {matchType}"
    let (discrs, matchType, alts, refined) ← elabMatchAltViews generalizing? discrs matchType matchAlts
    let isDep := isDep || refined
    /-
     We should not use `synthesizeSyntheticMVarsNoPostponing` here. Otherwise, we will not be
     able to elaborate examples such as:
     ```
     def f (x : Nat) : Option Nat := none

     def g (xs : List (Nat × Nat)) : IO Unit :=
     xs.forM fun x =>
       match f x.fst with
       | _ => pure ()
     ```
     If `synthesizeSyntheticMVarsNoPostponing`, the example above fails at `x.fst` because
     the type of `x` is only available after we proces the last argument of `List.forM`.

     We apply pending default types to make sure we can process examples such as
     ```
     let (a, b) := (0, 0)
     ```
    -/
    synthesizeSyntheticMVarsUsingDefault
    let rhss := alts.map Prod.snd
    let matchType ← instantiateMVars matchType
    let altLHSS ← alts.toList.mapM fun alt => do
      let altLHS ← Match.instantiateAltLHSMVars alt.1
      /- Remark: we try to postpone before throwing an error.
         The combinator `commitIfDidNotPostpone` ensures we backtrack any updates that have been performed.
         The quick-check `waitExpectedTypeAndDiscrs` minimizes the number of scenarios where we have to postpone here.
         Here is an example that passes the `waitExpectedTypeAndDiscrs` test, but postpones here.
         ```
          def bad (ps : Array (Nat × Nat)) : Array (Nat × Nat) :=
            (ps.filter fun (p : Prod _ _) =>
              match p with
              | (x, y) => x == 0)
            ++
            ps
         ```
         When we try to elaborate `fun (p : Prod _ _) => ...` for the first time, we haven't propagated the type of `ps` yet
         because `Array.filter` has type `{α : Type u_1} → (α → Bool) → (as : Array α) → optParam Nat 0 → optParam Nat (Array.size as) → Array α`
         However, the partial type annotation `(p : Prod _ _)` makes sure we succeed at the quick-check `waitExpectedTypeAndDiscrs`.
      -/
      withRef altLHS.ref do
        for d in altLHS.fvarDecls do
            if d.hasExprMVar then
            withExistingLocalDecls altLHS.fvarDecls do
              tryPostpone
              throwMVarError m!"invalid match-expression, type of pattern variable '{d.toExpr}' contains metavariables{indentExpr d.type}"
        for p in altLHS.patterns do
          if p.hasExprMVar then
            withExistingLocalDecls altLHS.fvarDecls do
              tryPostpone
              throwMVarError m!"invalid match-expression, pattern contains metavariables{indentExpr (← p.toExpr)}"
        pure altLHS
    return (discrs, matchType, altLHSS, isDep, rhss)
  if let some r ← if isDep then pure none else isMatchUnit? altLHSS rhss then
    return r
  else
    let numDiscrs := discrs.size
    let matcherName ← mkAuxName `match
    let matcherResult ← mkMatcher { matcherName, matchType, numDiscrs, lhss := altLHSS }
    matcherResult.addMatcher
    let motive ← forallBoundedTelescope matchType numDiscrs fun xs matchType => mkLambdaFVars xs matchType
    reportMatcherResultErrors altLHSS matcherResult
    let r := mkApp matcherResult.matcher motive
    let r := mkAppN r discrs
    let r := mkAppN r rhss
    trace[Elab.match] "result: {r}"
    return r

private def getDiscrs (matchStx : Syntax) : Array Syntax :=
  matchStx[2].getSepArgs

private def getMatchOptType (matchStx : Syntax) : Syntax :=
  matchStx[3]

private def expandNonAtomicDiscrs? (matchStx : Syntax) : TermElabM (Option Syntax) :=
  let matchOptType := getMatchOptType matchStx;
  if matchOptType.isNone then do
    let discrs := getDiscrs matchStx;
    let allLocal ← discrs.allM fun discr => Option.isSome <$> isAtomicDiscr? discr[1]
    if allLocal then
      return none
    else
      -- We use `foundFVars` to make sure the discriminants are distinct variables.
      -- See: code for computing "matchType" at `elabMatchTypeAndDiscrs`
      let rec loop (discrs : List Syntax) (discrsNew : Array Syntax) (foundFVars : NameSet) := do
        match discrs with
        | [] =>
          let discrs := Syntax.mkSep discrsNew (mkAtomFrom matchStx ", ");
          pure (matchStx.setArg 2 discrs)
        | discr :: discrs =>
          -- Recall that
          -- matchDiscr := leading_parser optional (ident >> ":") >> termParser
          let term := discr[1]
          let addAux : TermElabM Syntax := withFreshMacroScope do
            let d ← `(_discr);
            unless isAuxDiscrName d.getId do -- Use assertion?
              throwError "unexpected internal auxiliary discriminant name"
            let discrNew := discr.setArg 1 d;
            let r ← loop discrs (discrsNew.push discrNew) foundFVars
            `(let _discr := $term; $r)
          match (← isAtomicDiscr? term) with
          | some x  => if x.isFVar then loop discrs (discrsNew.push discr) (foundFVars.insert x.fvarId!) else addAux
          | none    => addAux
      return some (← loop discrs.toList #[] {})
  else
    -- We do not pull non atomic discriminants when match type is provided explicitly by the user
    return none

private def waitExpectedType (expectedType? : Option Expr) : TermElabM Expr := do
  tryPostponeIfNoneOrMVar expectedType?
  match expectedType? with
    | some expectedType => pure expectedType
    | none              => mkFreshTypeMVar

private def tryPostponeIfDiscrTypeIsMVar (matchStx : Syntax) : TermElabM Unit := do
  -- We don't wait for the discriminants types when match type is provided by user
  if getMatchOptType matchStx |>.isNone then
    let discrs := getDiscrs matchStx
    for discr in discrs do
      let term := discr[1]
      match (← isAtomicDiscr? term) with
      | none   => throwErrorAt discr "unexpected discriminant" -- see `expandNonAtomicDiscrs?
      | some d =>
        let dType ← inferType d
        trace[Elab.match] "discr {d} : {dType}"
        tryPostponeIfMVar dType

/-
We (try to) elaborate a `match` only when the expected type is available.
If the `matchType` has not been provided by the user, we also try to postpone elaboration if the type
of a discriminant is not available. That is, it is of the form `(?m ...)`.
We use `expandNonAtomicDiscrs?` to make sure all discriminants are local variables.
This is a standard trick we use in the elaborator, and it is also used to elaborate structure instances.
Suppose, we are trying to elaborate
```
match g x with
  | ... => ...
```
`expandNonAtomicDiscrs?` converts it intro
```
let _discr := g x
match _discr with
  | ... => ...
```
Thus, at `tryPostponeIfDiscrTypeIsMVar` we only need to check whether the type of `_discr` is not of the form `(?m ...)`.
Note that, the auxiliary variable `_discr` is expanded at `elabAtomicDiscr`.

This elaboration technique is needed to elaborate terms such as:
```lean
xs.filter fun (a, b) => a > b
```
which are syntax sugar for
```lean
List.filter (fun p => match p with | (a, b) => a > b) xs
```
When we visit `match p with | (a, b) => a > b`, we don't know the type of `p` yet.
-/
private def waitExpectedTypeAndDiscrs (matchStx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
  tryPostponeIfNoneOrMVar expectedType?
  tryPostponeIfDiscrTypeIsMVar matchStx
  match expectedType? with
  | some expectedType => return expectedType
  | none              => mkFreshTypeMVar

/-
```
leading_parser:leadPrec "match " >> sepBy1 matchDiscr ", " >> optType >> " with " >> matchAlts
```
Remark the `optIdent` must be `none` at `matchDiscr`. They are expanded by `expandMatchDiscr?`.
-/
private def elabMatchCore (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
  let expectedType ← waitExpectedTypeAndDiscrs stx expectedType?
  let discrStxs := (getDiscrs stx).map fun d => d
  let gen?         := getMatchGeneralizing? stx
  let altViews     := getMatchAlts stx
  let matchOptType := getMatchOptType stx
  elabMatchAux gen? discrStxs altViews matchOptType expectedType

private def isPatternVar (stx : Syntax) : TermElabM Bool := do
  match (← resolveId? stx "pattern") with
  | none   => isAtomicIdent stx
  | some f => match f with
    | Expr.const fName _ _ =>
      match (← getEnv).find? fName with
      | some (ConstantInfo.ctorInfo _) => return false
      | some _                         => return !hasMatchPatternAttribute (← getEnv) fName
      | _                              => isAtomicIdent stx
    | _ => isAtomicIdent stx
where
  isAtomicIdent (stx : Syntax) : Bool :=
    stx.isIdent && stx.getId.eraseMacroScopes.isAtomic

-- leading_parser "match " >> sepBy1 termParser ", " >> optType >> " with " >> matchAlts
@[builtinTermElab «match»] def elabMatch : TermElab := fun stx expectedType? => do
  match stx with
  | `(match $discr:term with | $y:ident => $rhs:term) =>
     if (← isPatternVar y) then expandSimpleMatch stx discr y rhs expectedType? else elabMatchDefault stx expectedType?
  | _ => elabMatchDefault stx expectedType?
where
  elabMatchDefault (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
    match (← expandNonAtomicDiscrs? stx) with
    | some stxNew => withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
    | none =>
      let discrs       := getDiscrs stx;
      let matchOptType := getMatchOptType stx;
      if !matchOptType.isNone && discrs.any fun d => !d[0].isNone then
        throwErrorAt matchOptType "match expected type should not be provided when discriminants with equality proofs are used"
      elabMatchCore stx expectedType?

builtin_initialize
  registerTraceClass `Elab.match

-- leading_parser:leadPrec "nomatch " >> termParser
@[builtinTermElab «nomatch»] def elabNoMatch : TermElab := fun stx expectedType? => do
  match stx with
  | `(nomatch $discrExpr) =>
    match (← isLocalIdent? discrExpr) with
    | some _ =>
      let expectedType ← waitExpectedType expectedType?
      let discr := Syntax.node ``Lean.Parser.Term.matchDiscr #[mkNullNode, discrExpr]
      elabMatchAux none #[discr] #[] mkNullNode expectedType
    | _ =>
      let stxNew ← `(let _discr := $discrExpr; nomatch _discr)
      withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
  | _ => throwUnsupportedSyntax

end Lean.Elab.Term


import sheaves.sheaf_of_rings Kenny.sheaf_on_opens ring_theory.subring

universes v w u₁ v₁ u

open topological_space lattice

def sheaf_of_rings_on_opens (X : Type u) [topological_space X] (U : opens X) : Type (max u (v+1)) :=
sheaf_of_rings.{u v} X

namespace sheaf_of_rings_on_opens

variables {X : Type u} [topological_space X] {U : opens X}

def to_sheaf_on_opens (F : sheaf_of_rings_on_opens X U) : sheaf_on_opens X U :=
{ locality := F.2,
  gluing := F.3,
  .. F.F }

-- def eval (F : sheaf_of_rings_on_opens X U) : Π (V : opens X), V ≤ U → Type v :=
-- F.to_sheaf_on_opens.eval

instance comm_ring_eval (F : sheaf_of_rings_on_opens X U) (V HVU) : comm_ring (F.to_sheaf_on_opens.eval V HVU) :=
F.1.2 V

-- def res (F : sheaf_of_rings_on_opens X U) : Π (V : opens X) (HVU : V ≤ U) (W : opens X) (HWU : W ≤ U) (HWV : W ≤ V), F.to_sheaf_on_opens.eval V HVU → F.to_sheaf_on_opens.eval W HWU :=
-- F.to_sheaf_on_opens.res

instance is_ring_hom_res (F : sheaf_of_rings_on_opens X U) (V HVU W HWU HWV) : is_ring_hom (F.to_sheaf_on_opens.res V HVU W HWU HWV) :=
F.1.3 V W HWV

section
variables (F : sheaf_of_rings_on_opens X U) (V : opens X) (HVU : V ≤ U) (W : opens X) (HWU : W ≤ U) (HWV : W ≤ V)
variables (x y : F.to_sheaf_on_opens.eval V HVU) (n : ℕ)
@[simp] lemma res_add : F.to_sheaf_on_opens.res V HVU W HWU HWV (x + y) = F.to_sheaf_on_opens.res V HVU W HWU HWV x + F.to_sheaf_on_opens.res V HVU W HWU HWV y := is_ring_hom.map_add _
@[simp] lemma res_zero : F.to_sheaf_on_opens.res V HVU W HWU HWV 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma res_neg : F.to_sheaf_on_opens.res V HVU W HWU HWV (-x) = -F.to_sheaf_on_opens.res V HVU W HWU HWV x := is_ring_hom.map_neg _
@[simp] lemma res_sub : F.to_sheaf_on_opens.res V HVU W HWU HWV (x - y) = F.to_sheaf_on_opens.res V HVU W HWU HWV x - F.to_sheaf_on_opens.res V HVU W HWU HWV y := is_ring_hom.map_sub _
@[simp] lemma res_mul : F.to_sheaf_on_opens.res V HVU W HWU HWV (x * y) = F.to_sheaf_on_opens.res V HVU W HWU HWV x * F.to_sheaf_on_opens.res V HVU W HWU HWV y := is_ring_hom.map_mul _
@[simp] lemma res_one : F.to_sheaf_on_opens.res V HVU W HWU HWV 1 = 1 := is_ring_hom.map_one _
@[simp] lemma res_pow : F.to_sheaf_on_opens.res V HVU W HWU HWV (x^n) = (F.to_sheaf_on_opens.res V HVU W HWU HWV x)^n := is_semiring_hom.map_pow _ x n
end

theorem res_self (F : sheaf_of_rings_on_opens X U) (V HVU HV x) :
  F.to_sheaf_on_opens.res V HVU V HVU HV x = x :=
F.to_sheaf_on_opens.res_self V HVU HV x

theorem res_res (F : sheaf_of_rings_on_opens X U) (V HVU W HWU HWV S HSU HSW x) :
  F.to_sheaf_on_opens.res W HWU S HSU HSW (F.to_sheaf_on_opens.res V HVU W HWU HWV x) = F.to_sheaf_on_opens.res V HVU S HSU (le_trans HSW HWV) x :=
F.to_sheaf_on_opens.res_res V HVU W HWU HWV S HSU HSW x

theorem locality (F : sheaf_of_rings_on_opens X U) (V HVU s t) (OC : covering V)
  (H : ∀ i : OC.γ, F.to_sheaf_on_opens.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) s =
    F.to_sheaf_on_opens.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) t) :
  s = t :=
F.locality OC s t H

-- noncomputable def glue (F : sheaf_of_rings_on_opens X U) (V HVU) (OC : covering V)
--   (s : Π i : OC.γ, F.to_sheaf_on_opens.eval (OC.Uis i) (le_trans (subset_covering i) HVU))
--   (H : ∀ i j : OC.γ, F.to_sheaf_on_opens.res _ _ (OC.Uis i ⊓ OC.Uis j) (le_trans inf_le_left (le_trans (subset_covering i) HVU)) inf_le_left (s i) =
--     F.to_sheaf_on_opens.res _ _ (OC.Uis i ⊓ OC.Uis j) (le_trans inf_le_left (le_trans (subset_covering i) HVU)) inf_le_right (s j)) :
--   F.to_sheaf_on_opens.eval V HVU :=
-- classical.some $ F.gluing OC s H

-- theorem res_glue (F : sheaf_of_rings_on_opens X U) (V HVU) (OC : covering V) (s H i) :
--   F.to_sheaf_on_opens.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) (F.glue V HVU OC s H) = s i :=
-- classical.some_spec (F.gluing OC s H) i

-- theorem eq_glue (F : sheaf_of_rings_on_opens X U) (V HVU) (OC : covering V)
--   (s : Π i : OC.γ, F.to_sheaf_on_opens.eval (OC.Uis i) (le_trans (subset_covering i) HVU)) (H t)
--   (ht : ∀ i, F.to_sheaf_on_opens.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) t = s i) :
--   F.glue V HVU OC s H = t :=
-- F.locality V HVU _ _ OC $ λ i, by rw [res_glue, ht]

def res_subset (F : sheaf_of_rings_on_opens X U) (V : opens X) (HVU : V ≤ U) : sheaf_of_rings_on_opens X V :=
F

theorem res_res_subset (F : sheaf_of_rings_on_opens X U) (V HVU S HSV T HTV HTS x) :
  (F.to_sheaf_on_opens.res_subset V HVU).res S HSV T HTV HTS x = F.to_sheaf_on_opens.res S (le_trans HSV HVU) T (le_trans HTV HVU) HTS x :=
rfl

-- def stalk (F : sheaf_of_rings_on_opens.{v} X U) (x : X) (hx : x ∈ U) : Type (max u v) :=
-- stalk_of_rings F.1 x

instance comm_ring_stalk (F : sheaf_of_rings_on_opens.{v} X U) (x : X) (hx : x ∈ U) :
  comm_ring (F.to_sheaf_on_opens.stalk x hx) :=
stalk_of_rings_is_comm_ring F.1 x

-- def to_stalk (F : sheaf_of_rings_on_opens.{v} X U) (x : X) (hx : x ∈ U) (V : opens X) (hxV : x ∈ V) (HVU : V ≤ U) (s : F.to_sheaf_on_opens.eval V HVU) : F.to_sheaf_on_opens.stalk x hx :=
-- F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s

instance is_ring_hom_to_stalk (F : sheaf_of_rings_on_opens X U) (x hx V hxV HVU) :
  is_ring_hom (F.to_sheaf_on_opens.to_stalk x hx V hxV HVU) :=
to_stalk.is_ring_hom _ _ _ _

section
variables (F : sheaf_of_rings_on_opens.{v} X U) (x : X) (hx : x ∈ U) (V : opens X) (hxV : x ∈ V) (HVU : V ≤ U)
variables (s t : F.to_sheaf_on_opens.eval V HVU) (n : ℕ)
@[simp] lemma to_stalk_add : F.to_sheaf_on_opens.to_stalk x hx V hxV HVU (s + t) = F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s + F.to_sheaf_on_opens.to_stalk x hx V hxV HVU t := is_ring_hom.map_add _
@[simp] lemma to_stalk_zero : F.to_sheaf_on_opens.to_stalk x hx V hxV HVU 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma to_stalk_neg : F.to_sheaf_on_opens.to_stalk x hx V hxV HVU (-s) = -F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s := is_ring_hom.map_neg _
@[simp] lemma to_stalk_sub : F.to_sheaf_on_opens.to_stalk x hx V hxV HVU (s - t) = F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s - F.to_sheaf_on_opens.to_stalk x hx V hxV HVU t := is_ring_hom.map_sub _
@[simp] lemma to_stalk_mul : F.to_sheaf_on_opens.to_stalk x hx V hxV HVU (s * t) = F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s * F.to_sheaf_on_opens.to_stalk x hx V hxV HVU t := is_ring_hom.map_mul _
@[simp] lemma to_stalk_one : F.to_sheaf_on_opens.to_stalk x hx V hxV HVU 1 = 1 := is_ring_hom.map_one _
@[simp] lemma to_stalk_pow : F.to_sheaf_on_opens.to_stalk x hx V hxV HVU (s^n) = (F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s)^n := is_semiring_hom.map_pow _ s n
end

@[simp] lemma to_stalk_res (F : sheaf_of_rings_on_opens.{v} X U) (x : X) (hx : x ∈ U) (V : opens X) (hxV : x ∈ V) (HVU : V ≤ U)
  (W : opens X) (hxW : x ∈ W) (HWV : W ≤ V) (s : F.to_sheaf_on_opens.eval V HVU) :
  F.to_sheaf_on_opens.to_stalk x hx W hxW (le_trans HWV HVU) (F.to_sheaf_on_opens.res _ _ _ _ HWV s) = F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s :=
to_stalk_res _ _ _ _ _ _ _ _

@[elab_as_eliminator] theorem stalk.induction_on {F : sheaf_of_rings_on_opens X U} {x : X} {hx : x ∈ U}
  {C : F.to_sheaf_on_opens.stalk x hx → Prop} (g : F.to_sheaf_on_opens.stalk x hx)
  (H : ∀ V : opens X, ∀ hxV : x ∈ V, ∀ HVU : V ≤ U, ∀ s : F.to_sheaf_on_opens.eval V HVU, C (F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s)) :
  C g :=
quotient.induction_on g $ λ e,
have (⟦e⟧ : F.to_sheaf_on_opens.stalk x hx) = ⟦⟨e.1 ⊓ U, ⟨e.2, hx⟩, F.F.res _ _ (set.inter_subset_left _ _) e.3⟩⟧,
from quotient.sound ⟨e.1 ⊓ U, ⟨e.2, hx⟩, set.inter_subset_left _ _, set.subset.refl _,
  by dsimp only [to_sheaf_on_opens]; rw ← presheaf.Hcomp'; refl⟩,
this.symm ▸ H (e.1 ⊓ U) ⟨e.2, hx⟩ inf_le_right _

@[elab_as_eliminator] theorem stalk.induction_on₂ {F : sheaf_of_rings_on_opens X U} {x : X} {hx : x ∈ U}
  {C : F.to_sheaf_on_opens.stalk x hx → F.to_sheaf_on_opens.stalk x hx → Prop} (g1 g2 : F.to_sheaf_on_opens.stalk x hx)
  (H : ∀ V : opens X, ∀ hxV : x ∈ V, ∀ HVU : V ≤ U, ∀ s t : F.to_sheaf_on_opens.eval V HVU, C (F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s) (F.to_sheaf_on_opens.to_stalk x hx V hxV HVU t)) :
  C g1 g2 :=
quotient.induction_on₂ g1 g2 $ λ e1 e2,
have h1 : (⟦e1⟧ : F.to_sheaf_on_opens.stalk x hx) = _root_.to_stalk F.F x (e1.1 ⊓ e2.1 ⊓ U) ⟨⟨e1.2, e2.2⟩, hx⟩ (F.F.res _ _ (λ p hp, hp.1.1) e1.3),
by erw [_root_.to_stalk_res]; cases e1; refl,
have h2 : (⟦e2⟧ : F.to_sheaf_on_opens.stalk x hx) = _root_.to_stalk F.F x (e1.1 ⊓ e2.1 ⊓ U) ⟨⟨e1.2, e2.2⟩, hx⟩ (F.F.res _ _ (λ p hp, hp.1.2) e2.3),
by erw [_root_.to_stalk_res]; cases e2; refl,
h1.symm ▸ h2.symm ▸ H _ _ inf_le_right _ _

structure morphism (F : sheaf_of_rings_on_opens.{v} X U) (G : sheaf_of_rings_on_opens.{w} X U) : Type (max u v w) :=
(η : F.to_sheaf_on_opens.morphism G.to_sheaf_on_opens)
[hom : ∀ V HV, is_ring_hom (η.map V HV)]
attribute [instance] morphism.hom

namespace morphism

section
variables {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U}
variables (η : F.morphism G) (V : opens X) (HVU : V ≤ U) (x y : F.to_sheaf_on_opens.eval V HVU) (n : ℕ)
@[simp] lemma map_add : η.1.map V HVU (x + y) = η.1.map V HVU x + η.1.map V HVU y := is_ring_hom.map_add _
@[simp] lemma map_zero : η.1.map V HVU 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma map_neg : η.1.map V HVU (-x) = -η.1.map V HVU x := is_ring_hom.map_neg _
@[simp] lemma map_sub : η.1.map V HVU (x - y) = η.1.map V HVU x - η.1.map V HVU y := is_ring_hom.map_sub _
@[simp] lemma map_mul : η.1.map V HVU (x * y) = η.1.map V HVU x * η.1.map V HVU y := is_ring_hom.map_mul _
@[simp] lemma map_one : η.1.map V HVU 1 = 1 := is_ring_hom.map_one _
@[simp] lemma map_pow : η.1.map V HVU (x^n) = (η.1.map V HVU x)^n := is_semiring_hom.map_pow _ x n
end

protected def id (F : sheaf_of_rings_on_opens.{v} X U) : F.morphism F :=
{ η := sheaf_on_opens.morphism.id _,
  hom := λ _ _, is_ring_hom.id }

def comp {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} {H : sheaf_of_rings_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) : F.morphism H :=
{ η := η.1.comp ξ.1,
  hom := λ _ _, is_ring_hom.comp _ _ }

@[simp] lemma comp_apply {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} {H : sheaf_of_rings_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V HV s) :
  (η.comp ξ).1.1 V HV s = η.1.1 V HV (ξ.1.1 V HV s) :=
rfl

@[ext] lemma ext {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U}
  {η ξ : F.morphism G} (H : ∀ V HV x, η.1.map V HV x = ξ.1.map V HV x) : η = ξ :=
by cases η; cases ξ; congr; ext; apply H

@[simp] lemma id_comp {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) :
  (morphism.id G).comp η = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_id {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) :
  η.comp (morphism.id F) = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_assoc {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} {H : sheaf_of_rings_on_opens.{u₁} X U} {I : sheaf_of_rings_on_opens.{v₁} X U}
  (η : H.morphism I) (ξ : G.morphism H) (χ : F.morphism G) :
  (η.comp ξ).comp χ = η.comp (ξ.comp χ) :=
rfl

def res_subset {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (F.res_subset V HVU).morphism (G.res_subset V HVU) :=
{ η := η.1.res_subset V HVU,
  hom := λ _ _, η.2 _ _ }

@[simp] lemma res_subset_apply {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U)
  (W HWV s) : (η.res_subset V HVU).1.1 W HWV s = η.1.1 W (le_trans HWV HVU) s :=
rfl

@[simp] lemma comp_res_subset {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} {H : sheaf_of_rings_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (η.res_subset V HVU).comp (ξ.res_subset V HVU) = (η.comp ξ).res_subset V HVU :=
rfl

@[simp] lemma id_res_subset {F : sheaf_of_rings_on_opens.{v} X U} (V : opens X) (HVU : V ≤ U) :
  (morphism.id F).res_subset V HVU = morphism.id (F.res_subset V HVU) :=
rfl

-- def stalk {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
--   (s : F.to_sheaf_on_opens.stalk x hx) : G.to_sheaf_on_opens.stalk x hx :=
-- quotient.lift_on s (λ g, ⟦(⟨g.1 ⊓ U, (⟨g.2, hx⟩ : x ∈ g.1 ⊓ U),
--   η.1.map _ inf_le_right (presheaf.res F.1.1 _ _ (set.inter_subset_left _ _) g.3)⟩ : stalk.elem _ _)⟧) $
-- λ g₁ g₂ ⟨V, hxV, HV1, HV2, hg⟩, quotient.sound ⟨V ⊓ U, ⟨hxV, hx⟩, set.inter_subset_inter_left _ HV1, set.inter_subset_inter_left _ HV2,
-- calc  G.to_sheaf_on_opens.res _ _ (V ⊓ U) inf_le_right (inf_le_inf HV1 (le_refl _)) (η.1.map (g₁.U ⊓ U) inf_le_right ((F.F).res (g₁.U) (g₁.U ⊓ U) (set.inter_subset_left _ _) (g₁.s)))
--     = η.1.map (V ⊓ U) inf_le_right ((F.F).res V (V ⊓ U) (set.inter_subset_left _ _) ((F.F).res (g₁.U) V HV1 (g₁.s))) :
--   by rw ← η.3; dsimp only [sheaf_on_opens.res, sheaf_of_rings_on_opens.to_sheaf_on_opens]; rw [← presheaf.Hcomp', ← presheaf.Hcomp']
-- ... = G.to_sheaf_on_opens.res _ _ (V ⊓ U) _ _ (η.1.map (g₂.U ⊓ U) inf_le_right ((F.F).res (g₂.U) (g₂.U ⊓ U) _ (g₂.s))) :
--   by erw [hg, ← η.3]; dsimp only [sheaf_on_opens.res, sheaf_of_rings_on_opens.to_sheaf_on_opens]; rw [← presheaf.Hcomp', ← presheaf.Hcomp']⟩

-- @[simp] lemma stalk_to_stalk {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
--   (V : opens X) (HVU : V ≤ U) (hxV : x ∈ V) (s : F.to_sheaf_on_opens.eval V HVU) :
--   η.stalk x hx (F.to_sheaf_on_opens.to_stalk x hx V hxV HVU s) =
--   G.to_sheaf_on_opens.to_stalk x hx V hxV HVU (η.1.map V HVU s) :=
-- quotient.sound ⟨V, hxV, set.subset_inter (set.subset.refl _) HVU, set.subset.refl _,
-- calc  G.to_sheaf_on_opens.res (V ⊓ U) inf_le_right V HVU (le_inf (le_refl V) HVU) (η.1.map (V ⊓ U) inf_le_right (F.to_sheaf_on_opens.res V HVU (V ⊓ U) inf_le_right inf_le_left s))
--     = G.to_sheaf_on_opens.res V HVU V HVU (le_refl V) (η.1.map V HVU s) : by rw [η.3, res_res]⟩

instance is_ring_hom_stalk {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U) :
  is_ring_hom (η.1.stalk x hx) :=
{ map_one := quotient.sound ⟨U, hx, set.subset_inter (set.subset_univ U.1) (set.subset.refl U.1), set.subset_univ U.1,
    by dsimp only; erw [_root_.res_one, η.map_one, _root_.res_one, _root_.res_one]⟩,
  map_mul := λ y z, stalk.induction_on₂ y z $ λ V hxV HVU s t,
    by rw [sheaf_on_opens.morphism.stalk_to_stalk, sheaf_on_opens.morphism.stalk_to_stalk, ← to_stalk_mul,
      sheaf_on_opens.morphism.stalk_to_stalk, η.map_mul, to_stalk_mul],
  map_add := λ y z, stalk.induction_on₂ y z $ λ V hxV HVU s t,
    by rw [sheaf_on_opens.morphism.stalk_to_stalk, sheaf_on_opens.morphism.stalk_to_stalk, ← to_stalk_add,
      sheaf_on_opens.morphism.stalk_to_stalk, η.map_add, to_stalk_add] }

section
variables {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
variables (s t : F.to_sheaf_on_opens.stalk x hx) (n : ℕ)
@[simp] lemma stalk_add : η.1.stalk x hx (s + t) = η.1.stalk x hx s + η.1.stalk x hx t := is_ring_hom.map_add _
@[simp] lemma stalk_zero : η.1.stalk x hx 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma stalk_neg : η.1.stalk x hx (-s) = -η.1.stalk x hx s := is_ring_hom.map_neg _
@[simp] lemma stalk_sub : η.1.stalk x hx (s - t) = η.1.stalk x hx s - η.1.stalk x hx t := is_ring_hom.map_sub _
@[simp] lemma stalk_mul : η.1.stalk x hx (s * t) = η.1.stalk x hx s * η.1.stalk x hx t := is_ring_hom.map_mul _
@[simp] lemma stalk_one : η.1.stalk x hx 1 = 1 := is_ring_hom.map_one _
@[simp] lemma stalk_pow : η.1.stalk x hx (s^n) = (η.1.stalk x hx s)^n := is_semiring_hom.map_pow _ s n
end

end morphism

structure equiv (F : sheaf_of_rings_on_opens.{v} X U) (G : sheaf_of_rings_on_opens.{w} X U) : Type (max u v w) :=
(to_fun : F.morphism G)
(inv_fun : G.to_sheaf_on_opens.morphism F.to_sheaf_on_opens)
(left_inv : ∀ V HVU s, inv_fun.1 V HVU (to_fun.1.1 V HVU s) = s)
(right_inv : ∀ V HVU s, to_fun.1.1 V HVU (inv_fun.1 V HVU s) = s)

namespace equiv

def to_sheaf_on_opens {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (e : F.equiv G) :
  F.to_sheaf_on_opens.equiv G.to_sheaf_on_opens :=
{ to_fun := e.1.1, .. e }

def to_ring_equiv {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{v} X U} (e : equiv F G) (V HVU) :
  F.to_sheaf_on_opens.eval V HVU ≃+* G.to_sheaf_on_opens.eval V HVU :=
ring_equiv.of' { to_fun := e.1.1.1 V HVU, inv_fun := e.2.1 V HVU, left_inv := e.3 V HVU, right_inv := e.4 V HVU }

def refl (F : sheaf_of_rings_on_opens.{v} X U) : equiv F F :=
⟨morphism.id F, sheaf_on_opens.morphism.id F.to_sheaf_on_opens, λ _ _ _, rfl, λ _ _ _, rfl⟩

@[simp] lemma refl_apply (F : sheaf_of_rings_on_opens.{v} X U) (V HV s) :
  (refl F).1.1.1 V HV s = s := rfl

def symm {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{v} X U} (e : equiv F G) : equiv G F :=
⟨{ η := e.2,
   hom := λ V HVU, (ring_equiv.symm (e.to_ring_equiv V HVU)).hom },
e.1.1, e.4, e.3⟩

def trans {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{v} X U} {H : sheaf_of_rings_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) : equiv F H :=
⟨e₂.1.comp e₁.1, e₁.2.comp e₂.2,
λ _ _ _, by rw [morphism.comp_apply, sheaf_on_opens.morphism.comp_apply, e₂.3, e₁.3],
λ _ _ _, by rw [morphism.comp_apply, sheaf_on_opens.morphism.comp_apply, e₁.4, e₂.4]⟩

@[simp] lemma trans_apply {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{v} X U} {H : sheaf_of_rings_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) (V HV s) :
  (e₁.trans e₂).1.1.1 V HV s = e₂.1.1.1 V HV (e₁.1.1.1 V HV s) :=
rfl

def res_subset {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) : equiv (F.res_subset V HVU) (G.res_subset V HVU) :=
⟨e.1.res_subset V HVU, e.2.res_subset V HVU,
λ _ _ _, by rw [morphism.res_subset_apply, sheaf_on_opens.morphism.res_subset_apply, e.3],
λ _ _ _, by rw [morphism.res_subset_apply, sheaf_on_opens.morphism.res_subset_apply, e.4]⟩

@[simp] lemma res_subset_apply {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) (W HW s) :
  (e.res_subset V HVU).1.1.1 W HW s = e.1.1.1 W (le_trans HW HVU) s :=
rfl

-- def stalk {F : sheaf_of_rings_on_opens.{v} X U} {G : sheaf_of_rings_on_opens.{w} X U} (e : equiv F G) (x : X) (hx : x ∈ U) :
--   F.to_sheaf_on_opens.stalk x hx ≃ G.to_sheaf_on_opens.stalk x hx :=
-- { to_fun := e.1.1.stalk x hx,
--   inv_fun := e.2.stalk x hx,
--   left_inv := λ g, stalk.induction_on g $ λ V hxV HVU s,
--     by rw [sheaf_on_opens.morphism.stalk_to_stalk, sheaf_on_opens.morphism.stalk_to_stalk, e.3]; refl,
--   right_inv := λ g, stalk.induction_on g $ λ V hxV HVU s,
--     by rw [sheaf_on_opens.morphism.stalk_to_stalk, sheaf_on_opens.morphism.stalk_to_stalk, e.4]; refl }

end equiv

def sheaf_glue {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_of_rings_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right)) :
  sheaf_of_rings_on_opens.{max u v} X (⋃S) :=
{ F :=
  { Fring := λ U, @subtype.comm_ring (Π (i : I), (F i).to_sheaf_on_opens.eval (S i ⊓ U) inf_le_left) _
      { f | ∀ (i j : I), (φ i j).1.1.1 (S i ⊓ S j ⊓ U) inf_le_left
              ((F i).to_sheaf_on_opens.res (S i ⊓ U) inf_le_left (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_left)
                (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
                (f i)) =
            (F j).to_sheaf_on_opens.res (S j ⊓ U) inf_le_left (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_right)
              (by rw inf_assoc; exact inf_le_right)
              (f j) }
      { add_mem := λ f g hf hg i j, by erw [res_add, morphism.map_add, res_add, hf i j, hg i j],
        zero_mem := λ i j, by erw [res_zero, morphism.map_zero, res_zero]; refl,
        neg_mem := λ f hf i j, by erw [res_neg, morphism.map_neg, res_neg, hf i j],
        one_mem := λ i j, by erw [res_one, morphism.map_one, res_one]; refl,
        mul_mem := λ f g hf hg i j, by erw [res_mul, morphism.map_mul, res_mul, hf i j, hg i j] },
    res_is_ring_hom := λ U V HVU,
      { map_one := subtype.eq $ funext $ λ i, res_one _ _ _ _ _ _,
        map_mul := λ f g, subtype.eq $ funext $ λ i, res_mul _ _ _ _ _ _ _ _,
        map_add := λ f g, subtype.eq $ funext $ λ i, res_add _ _ _ _ _ _ _ _ },
    .. sheaf_on_opens.sheaf_glue S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens) }
  .. sheaf_on_opens.sheaf_glue S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens) }

@[simp] lemma sheaf_glue_res_val {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_of_rings_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (U HU V HV HVU s i) :
  ((sheaf_glue S F φ).to_sheaf_on_opens.res U HU V HV HVU s).1 i =
  (F i).to_sheaf_on_opens.res _ _ _ _ (inf_le_inf (le_refl _) HVU) (s.1 i) := rfl

def universal_property (I : Type u) (S : I → opens X) (F : Π (i : I), sheaf_of_rings_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (Hφ1 : ∀ i V HV s, (φ i i).1.1.1 V HV s = s)
  (Hφ2 : ∀ i j k V HV1 HV2 HV3 s, (φ j k).1.1.1 V HV1 ((φ i j).1.1.1 V HV2 s) = (φ i k).1.1.1 V HV3 s)
  (i : I) :
  equiv (res_subset (sheaf_glue S F φ) (S i) (le_supr S i)) (F i) :=
{ to_fun :=
  { η := (sheaf_on_opens.universal_property I S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens) Hφ1 Hφ2 i).1,
    hom := λ U HU,
    { map_one := res_one _ _ _ _ _ _,
      map_mul := λ x y, res_mul _ _ _ _ _ _ _ _,
      map_add := λ x y, res_add _ _ _ _ _ _ _ _ } },
  .. sheaf_on_opens.universal_property I S (λ i, (F i).to_sheaf_on_opens) (λ i j, (φ i j).to_sheaf_on_opens) Hφ1 Hφ2 i }

end sheaf_of_rings_on_opens


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro

Notation for operators defined at Prelude.lean
-/
prelude
import Init.Prelude
import Init.Coe
set_option linter.missingDocs true -- keep it documented

namespace Lean

/--
Auxiliary type used to represent syntax categories. We mainly use auxiliary
definitions with this type to attach doc strings to syntax categories.
-/
structure Parser.Category

namespace Parser.Category

/-- `command` is the syntax category for things that appear at the top level
of a lean file. For example, `def foo := 1` is a `command`, as is
`namespace Foo` and `end Foo`. Commands generally have an effect on the state of
adding something to the environment (like a new definition), as well as
commands like `variable` which modify future commands within a scope. -/
def command : Category := {}

/-- `term` is the builtin syntax category for terms. A term denotes an expression
in lean's type theory, for example `2 + 2` is a term. The difference between
`Term` and `Expr` is that the former is a kind of syntax, while the latter is
the result of elaboration. For example `by simp` is also a `Term`, but it elaborates
to different `Expr`s depending on the context. -/
def term : Category := {}

/-- `tactic` is the builtin syntax category for tactics. These appear after
`by` in proofs, and they are programs that take in the proof context
(the hypotheses in scope plus the type of the term to synthesize) and construct
a term of the expected type. For example, `simp` is a tactic, used in:
```
example : 2 + 2 = 4 := by simp
```
-/
def tactic : Category := {}

/-- `doElem` is a builtin syntax category for elements that can appear in the `do` notation.
For example, `let x ← e` is a `doElem`, and a `do` block consists of a list of `doElem`s. -/
def doElem : Category := {}

/-- `level` is a builtin syntax category for universe levels.
This is the `u` in `Sort u`: it can contain `max` and `imax`, addition with
constants, and variables. -/
def level : Category := {}

/-- `attr` is a builtin syntax category for attributes.
Declarations can be annotated with attributes using the `@[...]` notation. -/
def attr : Category := {}

/-- `stx` is a builtin syntax category for syntax. This is the abbreviated
parser notation used inside `syntax` and `macro` declarations. -/
def stx : Category := {}

/-- `prio` is a builtin syntax category for priorities.
Priorities are used in many different attributes.
Higher numbers denote higher priority, and for example typeclass search will
try high priority instances before low priority.
In addition to literals like `37`, you can also use `low`, `mid`, `high`, as well as
add and subtract priorities. -/
def prio : Category := {}

/-- `prec` is a builtin syntax category for precedences. A precedence is a value
that expresses how tightly a piece of syntax binds: for example `1 + 2 * 3` is
parsed as `1 + (2 * 3)` because `*` has a higher pr0ecedence than `+`.
Higher numbers denote higher precedence.
In addition to literals like `37`, there are some special named priorities:
* `arg` for the precedence of function arguments
* `max` for the highest precedence used in term parsers (not actually the maximum possible value)
* `lead` for the precedence of terms not supposed to be used as arguments
and you can also add and subtract precedences. -/
def prec : Category := {}

end Parser.Category

namespace Parser.Syntax

/-! DSL for specifying parser precedences and priorities -/

/-- Addition of precedences. This is normally used only for offseting, e.g. `max + 1`. -/
syntax:65 (name := addPrec) prec " + " prec:66 : prec
/-- Subtraction of precedences. This is normally used only for offseting, e.g. `max - 1`. -/
syntax:65 (name := subPrec) prec " - " prec:66 : prec

/-- Addition of priorities. This is normally used only for offseting, e.g. `default + 1`. -/
syntax:65 (name := addPrio) prio " + " prio:66 : prio
/-- Subtraction of priorities. This is normally used only for offseting, e.g. `default - 1`. -/
syntax:65 (name := subPrio) prio " - " prio:66 : prio

end Parser.Syntax

instance : CoeOut (TSyntax ks) Syntax where
  coe stx := stx.raw

instance : Coe SyntaxNodeKind SyntaxNodeKinds where
  coe k := List.cons k List.nil

end Lean

/--
Maximum precedence used in term parsers, in particular for terms in
function position (`ident`, `paren`, ...)
-/
macro "max"  : prec => `(prec| 1024)
/-- Precedence used for application arguments (`do`, `by`, ...). -/
macro "arg"  : prec => `(prec| 1023)
/-- Precedence used for terms not supposed to be used as arguments (`let`, `have`, ...). -/
macro "lead" : prec => `(prec| 1022)
/-- Parentheses are used for grouping precedence expressions. -/
macro "(" p:prec ")" : prec => return p
/-- Minimum precedence used in term parsers. -/
macro "min"  : prec => `(prec| 10)
/-- `(min+1)` (we can only write `min+1` after `Meta.lean`) -/
macro "min1" : prec => `(prec| 11)
/--
`max:prec` as a term. It is equivalent to `eval_prec max` for `eval_prec` defined at `Meta.lean`.
We use `max_prec` to workaround bootstrapping issues.
-/
macro "max_prec" : term => `(1024)

/-- The default priority `default = 1000`, which is used when no priority is set. -/
macro "default" : prio => `(prio| 1000)
/-- The standardized "low" priority `low = 100`, for things that should be lower than default priority. -/
macro "low"     : prio => `(prio| 100)
/--
The standardized "medium" priority `med = 1000`. This is lower than `default`, and higher than `low`.
-/
macro "mid"     : prio => `(prio| 500)
/-- The standardized "high" priority `high = 10000`, for things that should be higher than default priority. -/
macro "high"    : prio => `(prio| 10000)
/-- Parentheses are used for grouping priority expressions. -/
macro "(" p:prio ")" : prio => return p

/-
Note regarding priorities. We want `low < mid < default` because we have the following default instances:
```
@[default_instance low] instance (n : Nat) : OfNat Nat n where ...
@[default_instance mid] instance : Neg Int where ...
@[default_instance default] instance [Add α] : HAdd α α α where ...
@[default_instance default] instance [Sub α] : HSub α α α where ...
...
```

Monomorphic default instances must always "win" to preserve the Lean 3 monomorphic "look&feel".
The `Neg Int` instance must have precedence over the `OfNat Nat n` one, otherwise we fail to elaborate `#check -42`
See issue #1813 for an example that failed when `mid = default`.
-/

-- Basic notation for defining parsers
-- NOTE: precedence must be at least `arg` to be used in `macro` without parentheses

/--
`p+` is shorthand for `many1(p)`. It uses parser `p` 1 or more times, and produces a
`nullNode` containing the array of parsed results. This parser has arity 1.

If `p` has arity more than 1, it is auto-grouped in the items generated by the parser.
-/
syntax:arg stx:max "+" : stx

/--
`p*` is shorthand for `many(p)`. It uses parser `p` 0 or more times, and produces a
`nullNode` containing the array of parsed results. This parser has arity 1.

If `p` has arity more than 1, it is auto-grouped in the items generated by the parser.
-/
syntax:arg stx:max "*" : stx

/--
`(p)?` is shorthand for `optional(p)`. It uses parser `p` 0 or 1 times, and produces a
`nullNode` containing the array of parsed results. This parser has arity 1.

`p` is allowed to have arity n > 1 (in which case the node will have either 0 or n children),
but if it has arity 0 then the result will be ambiguous.

Because `?` is an identifier character, `ident?` will not work as intended.
You have to write either `ident ?` or `(ident)?` for it to parse as the `?` combinator
applied to the `ident` parser.
-/
syntax:arg stx:max "?" : stx

/--
`p1 <|> p2` is shorthand for `orelse(p1, p2)`, and parses either `p1` or `p2`.
It does not backtrack, meaning that if `p1` consumes at least one token then
`p2` will not be tried. Therefore, the parsers should all differ in their first
token. The `atomic(p)` parser combinator can be used to locally backtrack a parser.
(For full backtracking, consider using extensible syntax classes instead.)

On success, if the inner parser does not generate exactly one node, it will be
automatically wrapped in a `group` node, so the result will always be arity 1.

The `<|>` combinator does not generate a node of its own, and in particular
does not tag the inner parsers to distinguish them, which can present a problem
when reconstructing the parse. A well formed `<|>` parser should use disjoint
node kinds for `p1` and `p2`.
-/
syntax:2 stx:2 " <|> " stx:1 : stx

macro_rules
  | `(stx| $p +) => `(stx| many1($p))
  | `(stx| $p *) => `(stx| many($p))
  | `(stx| $p ?) => `(stx| optional($p))
  | `(stx| $p₁ <|> $p₂) => `(stx| orelse($p₁, $p₂))

/--
`p,*` is shorthand for `sepBy(p, ",")`. It parses 0 or more occurrences of
`p` separated by `,`, that is: `empty | p | p,p | p,p,p | ...`.

It produces a `nullNode` containing a `SepArray` with the interleaved parser
results. It has arity 1, and auto-groups its component parser if needed.
-/
macro:arg x:stx:max ",*"   : stx => `(stx| sepBy($x, ",", ", "))
/--
`p,+` is shorthand for `sepBy(p, ",")`. It parses 1 or more occurrences of
`p` separated by `,`, that is: `p | p,p | p,p,p | ...`.

It produces a `nullNode` containing a `SepArray` with the interleaved parser
results. It has arity 1, and auto-groups its component parser if needed.
-/
macro:arg x:stx:max ",+"   : stx => `(stx| sepBy1($x, ",", ", "))

/--
`p,*,?` is shorthand for `sepBy(p, ",", allowTrailingSep)`.
It parses 0 or more occurrences of `p` separated by `,`, possibly including
a trailing `,`, that is: `empty | p | p, | p,p | p,p, | p,p,p | ...`.

It produces a `nullNode` containing a `SepArray` with the interleaved parser
results. It has arity 1, and auto-groups its component parser if needed.
-/
macro:arg x:stx:max ",*,?" : stx => `(stx| sepBy($x, ",", ", ", allowTrailingSep))

/--
`p,+,?` is shorthand for `sepBy1(p, ",", allowTrailingSep)`.
It parses 1 or more occurrences of `p` separated by `,`, possibly including
a trailing `,`, that is: `p | p, | p,p | p,p, | p,p,p | ...`.

It produces a `nullNode` containing a `SepArray` with the interleaved parser
results. It has arity 1, and auto-groups its component parser if needed.
-/
macro:arg x:stx:max ",+,?" : stx => `(stx| sepBy1($x, ",", ", ", allowTrailingSep))

/--
`!p` parses the negation of `p`. That is, it fails if `p` succeeds, and
otherwise parses nothing. It has arity 0.
-/
macro:arg "!" x:stx:max : stx => `(stx| notFollowedBy($x))

/--
The `nat_lit n` macro constructs "raw numeric literals". This corresponds to the
`Expr.lit (.natVal n)` constructor in the `Expr` data type.

Normally, when you write a numeral like `#check 37`, the parser turns this into
an application of `OfNat.ofNat` to the raw literal `37` to cast it into the
target type, even if this type is `Nat` (so the cast is the identity function).
But sometimes it is necessary to talk about the raw numeral directly,
especially when proving properties about the `ofNat` function itself.
-/
syntax (name := rawNatLit) "nat_lit " num : term

@[inherit_doc] infixr:90 " ∘ "  => Function.comp
@[inherit_doc] infixr:35 " × "  => Prod

@[inherit_doc] infixl:55 " ||| " => HOr.hOr
@[inherit_doc] infixl:58 " ^^^ " => HXor.hXor
@[inherit_doc] infixl:60 " &&& " => HAnd.hAnd
@[inherit_doc] infixl:65 " + "   => HAdd.hAdd
@[inherit_doc] infixl:65 " - "   => HSub.hSub
@[inherit_doc] infixl:70 " * "   => HMul.hMul
@[inherit_doc] infixl:70 " / "   => HDiv.hDiv
@[inherit_doc] infixl:70 " % "   => HMod.hMod
@[inherit_doc] infixl:75 " <<< " => HShiftLeft.hShiftLeft
@[inherit_doc] infixl:75 " >>> " => HShiftRight.hShiftRight
@[inherit_doc] infixr:80 " ^ "   => HPow.hPow
@[inherit_doc] infixl:65 " ++ "  => HAppend.hAppend
@[inherit_doc] prefix:75 "-"    => Neg.neg
@[inherit_doc] prefix:100 "~~~"  => Complement.complement

/-!
  Remark: the infix commands above ensure a delaborator is generated for each relations.
  We redefine the macros below to be able to use the auxiliary `binop%` elaboration helper for binary operators.
  It addresses issue #382. -/
macro_rules | `($x ||| $y) => `(binop% HOr.hOr $x $y)
macro_rules | `($x ^^^ $y) => `(binop% HXor.hXor $x $y)
macro_rules | `($x &&& $y) => `(binop% HAnd.hAnd $x $y)
macro_rules | `($x + $y)   => `(binop% HAdd.hAdd $x $y)
macro_rules | `($x - $y)   => `(binop% HSub.hSub $x $y)
macro_rules | `($x * $y)   => `(binop% HMul.hMul $x $y)
macro_rules | `($x / $y)   => `(binop% HDiv.hDiv $x $y)
macro_rules | `($x % $y)   => `(binop% HMod.hMod $x $y)
macro_rules | `($x ^ $y)   => `(binop% HPow.hPow $x $y)
macro_rules | `($x ++ $y)  => `(binop% HAppend.hAppend $x $y)
macro_rules | `(- $x)      => `(unop% Neg.neg $x)

-- declare ASCII alternatives first so that the latter Unicode unexpander wins
@[inherit_doc] infix:50 " <= " => LE.le
@[inherit_doc] infix:50 " ≤ "  => LE.le
@[inherit_doc] infix:50 " < "  => LT.lt
@[inherit_doc] infix:50 " >= " => GE.ge
@[inherit_doc] infix:50 " ≥ "  => GE.ge
@[inherit_doc] infix:50 " > "  => GT.gt
@[inherit_doc] infix:50 " = "  => Eq
@[inherit_doc] infix:50 " == " => BEq.beq
/-!
  Remark: the infix commands above ensure a delaborator is generated for each relations.
  We redefine the macros below to be able to use the auxiliary `binrel%` elaboration helper for binary relations.
  It has better support for applying coercions. For example, suppose we have `binrel% Eq n i` where `n : Nat` and
  `i : Int`. The default elaborator fails because we don't have a coercion from `Int` to `Nat`, but
  `binrel%` succeeds because it also tries a coercion from `Nat` to `Int` even when the nat occurs before the int. -/
macro_rules | `($x <= $y) => `(binrel% LE.le $x $y)
macro_rules | `($x ≤ $y)  => `(binrel% LE.le $x $y)
macro_rules | `($x < $y)  => `(binrel% LT.lt $x $y)
macro_rules | `($x > $y)  => `(binrel% GT.gt $x $y)
macro_rules | `($x >= $y) => `(binrel% GE.ge $x $y)
macro_rules | `($x ≥ $y)  => `(binrel% GE.ge $x $y)
macro_rules | `($x = $y)  => `(binrel% Eq $x $y)
macro_rules | `($x == $y) => `(binrel_no_prop% BEq.beq $x $y)

@[inherit_doc] infixr:35 " /\\ " => And
@[inherit_doc] infixr:35 " ∧ "   => And
@[inherit_doc] infixr:30 " \\/ " => Or
@[inherit_doc] infixr:30 " ∨  "  => Or
@[inherit_doc] notation:max "¬" p:40 => Not p

@[inherit_doc] infixl:35 " && " => and
@[inherit_doc] infixl:30 " || " => or
@[inherit_doc] notation:max "!" b:40 => not b

@[inherit_doc] infix:50 " ∈ " => Membership.mem
/-- `a ∉ b` is negated elementhood. It is notation for `¬ (a ∈ b)`. -/
notation:50 a:50 " ∉ " b:50 => ¬ (a ∈ b)

@[inherit_doc] infixr:67 " :: " => List.cons
@[inherit_doc HOrElse.hOrElse] syntax:20 term:21 " <|> " term:20 : term
@[inherit_doc HAndThen.hAndThen] syntax:60 term:61 " >> " term:60 : term
@[inherit_doc] infixl:55  " >>= " => Bind.bind
@[inherit_doc] notation:60 a:60 " <*> " b:61 => Seq.seq a fun _ : Unit => b
@[inherit_doc] notation:60 a:60 " <* " b:61 => SeqLeft.seqLeft a fun _ : Unit => b
@[inherit_doc] notation:60 a:60 " *> " b:61 => SeqRight.seqRight a fun _ : Unit => b
@[inherit_doc] infixr:100 " <$> " => Functor.map

macro_rules | `($x <|> $y) => `(binop_lazy% HOrElse.hOrElse $x $y)
macro_rules | `($x >> $y)  => `(binop_lazy% HAndThen.hAndThen $x $y)

namespace Lean

/--
`binderIdent` matches an `ident` or a `_`. It is used for identifiers in binding
position, where `_` means that the value should be left unnamed and inaccessible.
-/
syntax binderIdent := ident <|> hole

namespace Parser.Tactic

/--
A case tag argument has the form `tag x₁ ... xₙ`; it refers to tag `tag` and renames
the last `n` hypotheses to `x₁ ... xₙ`.
-/
syntax caseArg := binderIdent binderIdent*

end Parser.Tactic
end Lean

@[inherit_doc dite] syntax (name := termDepIfThenElse)
  ppRealGroup(ppRealFill(ppIndent("if " Lean.binderIdent " : " term " then") ppSpace term)
    ppDedent(ppSpace) ppRealFill("else " term)) : term

macro_rules
  | `(if $h:ident : $c then $t else $e) => do
    let mvar ← Lean.withRef c `(?m)
    `(let_mvar% ?m := $c; wait_if_type_mvar% ?m; dite $mvar (fun $h:ident => $t) (fun $h:ident => $e))
  | `(if _%$h : $c then $t else $e) => do
    let mvar ← Lean.withRef c `(?m)
    `(let_mvar% ?m := $c; wait_if_type_mvar% ?m; dite $mvar (fun _%$h => $t) (fun _%$h => $e))

@[inherit_doc ite] syntax (name := termIfThenElse)
  ppRealGroup(ppRealFill(ppIndent("if " term " then") ppSpace term)
    ppDedent(ppSpace) ppRealFill("else " term)) : term

macro_rules
  | `(if $c then $t else $e) => do
    let mvar ← Lean.withRef c `(?m)
    `(let_mvar% ?m := $c; wait_if_type_mvar% ?m; ite $mvar $t $e)

/--
`if let pat := d then t else e` is a shorthand syntax for:
```
match d with
| pat => t
| _ => e
```
It matches `d` against the pattern `pat` and the bindings are available in `t`.
If the pattern does not match, it returns `e` instead.
-/
syntax (name := termIfLet)
  ppRealGroup(ppRealFill(ppIndent("if " "let " term " := " term " then") ppSpace term)
    ppDedent(ppSpace) ppRealFill("else " term)) : term

macro_rules
  | `(if let $pat := $d then $t else $e) =>
    `(match $d:term with | $pat => $t | _ => $e)

@[inherit_doc cond] syntax (name := boolIfThenElse)
  ppRealGroup(ppRealFill(ppIndent("bif " term " then") ppSpace term)
    ppDedent(ppSpace) ppRealFill("else " term)) : term

macro_rules
  | `(bif $c then $t else $e) => `(cond $c $t $e)

/--
Haskell-like pipe operator `<|`. `f <| x` means the same as the same as `f x`,
except that it parses `x` with lower precedence, which means that `f <| g <| x`
is interpreted as `f (g x)` rather than `(f g) x`.
-/
syntax:min term " <| " term:min : term

macro_rules
  | `($f $args* <| $a) => `($f $args* $a)
  | `($f <| $a) => `($f $a)

/--
Haskell-like pipe operator `|>`. `x |> f` means the same as the same as `f x`,
and it chains such that `x |> f |> g` is interpreted as `g (f x)`.
-/
syntax:min term " |> " term:min1 : term

macro_rules
  | `($a |> $f $args*) => `($f $args* $a)
  | `($a |> $f)        => `($f $a)

/--
Alternative syntax for `<|`. `f $ x` means the same as the same as `f x`,
except that it parses `x` with lower precedence, which means that `f $ g $ x`
is interpreted as `f (g x)` rather than `(f g) x`.
-/
-- Note that we have a whitespace after `$` to avoid an ambiguity with antiquotations.
syntax:min term atomic(" $" ws) term:min : term

macro_rules
  | `($f $args* $ $a) => `($f $args* $a)
  | `($f $ $a) => `($f $a)

@[inherit_doc Subtype] syntax "{ " withoutPosition(ident (" : " term)? " // " term) " }" : term

macro_rules
  | `({ $x : $type // $p }) => ``(Subtype (fun ($x:ident : $type) => $p))
  | `({ $x // $p })         => ``(Subtype (fun ($x:ident : _) => $p))

/--
`without_expected_type t` instructs Lean to elaborate `t` without an expected type.
Recall that terms such as `match ... with ...` and `⟨...⟩` will postpone elaboration until
expected type is known. So, `without_expected_type` is not effective in this case.
-/
macro "without_expected_type " x:term : term => `(let aux := $x; aux)

/--
The syntax `[a, b, c]` is shorthand for `a :: b :: c :: []`, or
`List.cons a (List.cons b (List.cons c List.nil))`. It allows conveniently constructing
list literals.

For lists of length at least 64, an alternative desugaring strategy is used
which uses let bindings as intermediates as in
`let left := [d, e, f]; a :: b :: c :: left` to avoid creating very deep expressions.
Note that this changes the order of evaluation, although it should not be observable
unless you use side effecting operations like `dbg_trace`.
-/
syntax "[" withoutPosition(term,*) "]"  : term

/--
Auxiliary syntax for implementing `[$elem,*]` list literal syntax.
The syntax `%[a,b,c|tail]` constructs a value equivalent to `a::b::c::tail`.
It uses binary partitioning to construct a tree of intermediate let bindings as in
`let left := [d, e, f]; a :: b :: c :: left` to avoid creating very deep expressions.
-/
syntax "%[" withoutPosition(term,* "|" term) "]" : term

namespace Lean

macro_rules
  | `([ $elems,* ]) => do
    -- NOTE: we do not have `TSepArray.getElems` yet at this point
    let rec expandListLit (i : Nat) (skip : Bool) (result : TSyntax `term) : MacroM Syntax := do
      match i, skip with
      | 0,   _     => pure result
      | i+1, true  => expandListLit i false result
      | i+1, false => expandListLit i true  (← ``(List.cons $(⟨elems.elemsAndSeps.get! i⟩) $result))
    if elems.elemsAndSeps.size < 64 then
      expandListLit elems.elemsAndSeps.size false (← ``(List.nil))
    else
      `(%[ $elems,* | List.nil ])

-- Declare `this` as a keyword that unhygienically binds to a scope-less `this` assumption (or other binding).
-- The keyword prevents declaring a `this` binding except through metaprogramming, as is done by `have`/`show`.
/-- Special identifier introduced by "anonymous" `have : ...`, `suffices p ...` etc. -/
macro tk:"this" : term =>
  return (⟨(Syntax.ident tk.getHeadInfo "this".toSubstring `this [])⟩ : TSyntax `term)

/--
Category for carrying raw syntax trees between macros; any content is printed as is by the pretty printer.
The only accepted parser for this category is an antiquotation.
-/
declare_syntax_cat rawStx

instance : Coe Syntax (TSyntax `rawStx) where
  coe stx := ⟨stx⟩

/-- `with_annotate_term stx e` annotates the lexical range of `stx : Syntax` with term info for `e`. -/
scoped syntax (name := withAnnotateTerm) "with_annotate_term " rawStx ppSpace term : term

/--
The attribute `@[deprecated]` on a declaration indicates that the declaration
is discouraged for use in new code, and/or should be migrated away from in
existing code. It may be removed in a future version of the library.

`@[deprecated myBetterDef]` means that `myBetterDef` is the suggested replacement.
-/
syntax (name := deprecated) "deprecated " (ident)? : attr

/--
When `parent_dir` contains the current Lean file, `include_str "path" / "to" / "file"` becomes
a string literal with the contents of the file at `"parent_dir" / "path" / "to" / "file"`. If this
file cannot be read, elaboration fails.
-/
syntax (name := includeStr) "include_str" term : term