/-
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.FindExpr
import Lean.Parser.Term
import Lean.Elab.App
import Lean.Elab.Binders

namespace Lean.Elab.Term.StructInst

open Std (HashMap)
open Meta

/-
  Structure instances are of the form:

      "{" >> optional (atomic (termParser >> " with "))
          >> manyIndent (group ((structInstFieldAbbrev <|> structInstField) >> optional ", "))
          >> optEllipsis
          >> optional (" : " >> termParser)
          >> " }"
-/

@[builtinMacro Lean.Parser.Term.structInst] def expandStructInstExpectedType : Macro := fun stx =>
  let expectedArg := stx[4]
  if expectedArg.isNone then
    Macro.throwUnsupported
  else
    let expected := expectedArg[1]
    let stxNew   := stx.setArg 4 mkNullNode
    `(($stxNew : $expected))

/-
If `stx` is of the form `{ s with ... }` and `s` is not a local variable, expand into `let src := s; { src with ... }`.

Note that this one is not a `Macro` because we need to access the local context.
-/
private def expandNonAtomicExplicitSource (stx : Syntax) : TermElabM (Option Syntax) :=
  withFreshMacroScope do
    let sourceOpt := stx[1]
    if sourceOpt.isNone then
      pure none
    else
      let source := sourceOpt[0]
      match (← isLocalIdent? source) with
      | some _ => pure none
      | none   =>
        if source.isMissing then
          throwAbortTerm
        else
          let src ← `(src)
          let sourceOpt := sourceOpt.setArg 0 src
          let stxNew    := stx.setArg 1 sourceOpt
          `(let src := $source; $stxNew)

inductive Source where
  | none     -- structure instance source has not been provieded
  | implicit (stx : Syntax) -- `..`
  | explicit (stx : Syntax) (src : Expr) -- `src with`
  deriving Inhabited

def Source.isNone : Source → Bool
  | Source.none => true
  | _           => false

def setStructSourceSyntax (structStx : Syntax) : Source → Syntax
  | Source.none           => (structStx.setArg 1 mkNullNode).setArg 3 mkNullNode
  | Source.implicit stx   => (structStx.setArg 1 mkNullNode).setArg 3 stx
  | Source.explicit stx _ => (structStx.setArg 1 stx).setArg 3 mkNullNode

private def getStructSource (stx : Syntax) : TermElabM Source :=
  withRef stx do
    let explicitSource := stx[1]
    let implicitSource := stx[3]
    if explicitSource.isNone && implicitSource[0].isNone then
      return Source.none
    else if explicitSource.isNone then
      return Source.implicit implicitSource
    else if implicitSource[0].isNone then
      let fvar? ← isLocalIdent? explicitSource[0]
      match fvar? with
      | none      => unreachable! -- expandNonAtomicExplicitSource must have been used when we get here
      | some src  => return Source.explicit explicitSource src
    else
      throwError "invalid structure instance `with` and `..` cannot be used together"

/-
  We say a `{ ... }` notation is a `modifyOp` if it contains only one
  ```
  def structInstArrayRef := leading_parser "[" >> termParser >>"]"
  ```
-/
private def isModifyOp? (stx : Syntax) : TermElabM (Option Syntax) := do
  let s? ← stx[2].getArgs.foldlM (init := none) fun s? p =>
    /- p is of the form `(group ((structInstFieldAbbrev <|> structInstField) >> optional ", "))` -/
    let arg := p[0]
    if arg.getKind == ``Lean.Parser.Term.structInstField then
      /- Remark: the syntax for `structInstField` is
         ```
         def structInstLVal   := leading_parser (ident <|> numLit <|> structInstArrayRef) >> many (group ("." >> (ident <|> numLit)) <|> structInstArrayRef)
         def structInstField  := leading_parser structInstLVal >> " := " >> termParser
         ```
      -/
      let lval := arg[0]
      let k    := lval[0].getKind
      if k == ``Lean.Parser.Term.structInstArrayRef then
        match s? with
        | none   => pure (some arg)
        | some s =>
          if s.getKind == ``Lean.Parser.Term.structInstArrayRef then
            throwErrorAt arg "invalid \{...} notation, at most one `[..]` at a given level"
          else
            throwErrorAt arg "invalid \{...} notation, can't mix field and `[..]` at a given level"
      else
        match s? with
        | none   => pure (some arg)
        | some s =>
          if s.getKind == ``Lean.Parser.Term.structInstArrayRef then
            throwErrorAt arg "invalid \{...} notation, can't mix field and `[..]` at a given level"
          else
            pure s?
    else
      pure s?
  match s? with
  | none   => pure none
  | some s => if s[0][0].getKind == ``Lean.Parser.Term.structInstArrayRef then pure s? else pure none

private def elabModifyOp (stx modifyOp source : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
  let cont (val : Syntax) : TermElabM Expr := do
    let lval := modifyOp[0][0]
    let idx  := lval[1]
    let self := source[0]
    let stxNew ← `($(self).modifyOp (idx := $idx) (fun s => $val))
    trace[Elab.struct.modifyOp] "{stx}\n===>\n{stxNew}"
    withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
  trace[Elab.struct.modifyOp] "{modifyOp}\nSource: {source}"
  let rest := modifyOp[0][1]
  if rest.isNone then
    cont modifyOp[2]
  else
    let s ← `(s)
    let valFirst  := rest[0]
    let valFirst  := if valFirst.getKind == ``Lean.Parser.Term.structInstArrayRef then valFirst else valFirst[1]
    let restArgs  := rest.getArgs
    let valRest   := mkNullNode restArgs[1:restArgs.size]
    let valField  := modifyOp.setArg 0 <| Syntax.node ``Parser.Term.structInstLVal #[valFirst, valRest]
    let valSource := source.modifyArg 0 fun _ => s
    let val       := stx.setArg 1 valSource
    let val       := val.setArg 2 <| mkNullNode #[mkNullNode #[valField, mkNullNode]]
    trace[Elab.struct.modifyOp] "{stx}\nval: {val}"
    cont val

/- Get structure name and elaborate explicit source (if available) -/
private def getStructName (stx : Syntax) (expectedType? : Option Expr) (sourceView : Source) : TermElabM (Name × Expr) := do
  tryPostponeIfNoneOrMVar expectedType?
  let useSource : Unit → TermElabM (Name × Expr) := fun _ =>
    match sourceView, expectedType? with
    | Source.explicit _ src, _ => do
      let srcType ← inferType src
      let srcType ← whnf srcType
      tryPostponeIfMVar srcType
      match srcType.getAppFn with
      | Expr.const constName _ _ => return (constName, srcType)
      | _ => throwUnexpectedExpectedType srcType "source"
    | _, some expectedType => throwUnexpectedExpectedType expectedType
    | _, none              => throwUnknownExpectedType
  match expectedType? with
  | none => useSource ()
  | some expectedType =>
    let expectedType ← whnf expectedType
    match expectedType.getAppFn with
    | Expr.const constName _ _ => return (constName, expectedType)
    | _                        => useSource ()
where
  throwUnknownExpectedType :=
    throwError "invalid \{...} notation, expected type is not known"
  throwUnexpectedExpectedType type (kind := "expected") := do
    let type ← instantiateMVars type
    if type.getAppFn.isMVar then
      throwUnknownExpectedType
    else
      throwError "invalid \{...} notation, {kind} type is not of the form (C ...){indentExpr type}"

inductive FieldLHS where
  | fieldName  (ref : Syntax) (name : Name)
  | fieldIndex (ref : Syntax) (idx : Nat)
  | modifyOp   (ref : Syntax) (index : Syntax)
  deriving Inhabited

instance : ToFormat FieldLHS := ⟨fun lhs =>
  match lhs with
  | FieldLHS.fieldName _ n  => fmt n
  | FieldLHS.fieldIndex _ i => fmt i
  | FieldLHS.modifyOp _ i   => "[" ++ i.prettyPrint ++ "]"⟩

inductive FieldVal (σ : Type) where
  | term  (stx : Syntax) : FieldVal σ
  | nested (s : σ)       : FieldVal σ
  | default              : FieldVal σ -- mark that field must be synthesized using default value
  deriving Inhabited

structure Field (σ : Type) where
  ref : Syntax
  lhs : List FieldLHS
  val : FieldVal σ
  expr? : Option Expr := none
  deriving Inhabited

def Field.isSimple {σ} : Field σ → Bool
  | { lhs := [_], .. } => true
  | _                  => false

inductive Struct where
  | mk (ref : Syntax) (structName : Name) (fields : List (Field Struct)) (source : Source)
  deriving Inhabited

abbrev Fields := List (Field Struct)

/- true if all fields of the given structure are marked as `default` -/
partial def Struct.allDefault : Struct → Bool
  | ⟨_, _, fields, _⟩ => fields.all fun ⟨_, _, val, _⟩ => match val with
    | FieldVal.term _   => false
    | FieldVal.default  => true
    | FieldVal.nested s => allDefault s

def Struct.ref : Struct → Syntax
  | ⟨ref, _, _, _⟩ => ref

def Struct.structName : Struct → Name
  | ⟨_, structName, _, _⟩ => structName

def Struct.fields : Struct → Fields
  | ⟨_, _, fields, _⟩ => fields

def Struct.source : Struct → Source
  | ⟨_, _, _, s⟩ => s

def formatField (formatStruct : Struct → Format) (field : Field Struct) : Format :=
  Format.joinSep field.lhs " . " ++ " := " ++
    match field.val with
    | FieldVal.term v   => v.prettyPrint
    | FieldVal.nested s => formatStruct s
    | FieldVal.default  => "<default>"

partial def formatStruct : Struct → Format
  | ⟨_, structName, fields, source⟩ =>
    let fieldsFmt := Format.joinSep (fields.map (formatField formatStruct)) ", "
    match source with
    | Source.none           => "{" ++ fieldsFmt ++ "}"
    | Source.implicit _     => "{" ++ fieldsFmt ++ " .. }"
    | Source.explicit _ src => "{" ++ format src ++ " with " ++ fieldsFmt ++ "}"

instance : ToFormat Struct     := ⟨formatStruct⟩
instance : ToString Struct := ⟨toString ∘ format⟩

instance : ToFormat (Field Struct) := ⟨formatField formatStruct⟩
instance : ToString (Field Struct) := ⟨toString ∘ format⟩

/-
Recall that `structInstField` elements have the form
```
   def structInstField  := leading_parser structInstLVal >> " := " >> termParser
   def structInstLVal   := leading_parser (ident <|> numLit <|> structInstArrayRef) >> many (("." >> (ident <|> numLit)) <|> structInstArrayRef)
   def structInstArrayRef := leading_parser "[" >> termParser >>"]"
```
-/
-- Remark: this code relies on the fact that `expandStruct` only transforms `fieldLHS.fieldName`
def FieldLHS.toSyntax (first : Bool) : FieldLHS → Syntax
  | FieldLHS.modifyOp   stx _    => stx
  | FieldLHS.fieldName  stx name => if first then mkIdentFrom stx name else mkGroupNode #[mkAtomFrom stx ".", mkIdentFrom stx name]
  | FieldLHS.fieldIndex stx _    => if first then stx else mkGroupNode #[mkAtomFrom stx ".", stx]

def FieldVal.toSyntax : FieldVal Struct → Syntax
  | FieldVal.term stx => stx
  | _                 => unreachable!

def Field.toSyntax : Field Struct → Syntax
  | field =>
    let stx := field.ref
    let stx := stx.setArg 2 field.val.toSyntax
    match field.lhs with
    | first::rest => stx.setArg 0 <| mkNullNode #[first.toSyntax true, mkNullNode <| rest.toArray.map (FieldLHS.toSyntax false) ]
    | _ => unreachable!

private def toFieldLHS (stx : Syntax) : MacroM FieldLHS :=
  if stx.getKind == ``Lean.Parser.Term.structInstArrayRef then
    return FieldLHS.modifyOp stx stx[1]
  else
    -- Note that the representation of the first field is different.
    let stx := if stx.getKind == groupKind then stx[1] else stx
    if stx.isIdent then
      return FieldLHS.fieldName stx stx.getId.eraseMacroScopes
    else match stx.isFieldIdx? with
      | some idx => return FieldLHS.fieldIndex stx idx
      | none     => Macro.throwError "unexpected structure syntax"

private def mkStructView (stx : Syntax) (structName : Name) (source : Source) : MacroM Struct := do
  /- Recall that `stx` is of the form
     ```
     leading_parser "{" >> optional (atomic (termParser >> " with "))
                 >> manyIndent (group ((structInstFieldAbbrev <|> structInstField) >> optional ", "))
                 >> optional ".."
                 >> optional (" : " >> termParser)
                 >> " }"
     ```
  -/
  let fieldsStx ← stx[2].getArgs.mapM fun stx =>
    let stx := stx[0]
    if stx.getKind == ``Lean.Parser.Term.structInstField then
      return stx
    else
      let id := stx[0]
      `(Lean.Parser.Term.structInstField| $id:ident := $id:ident)
  let fields ← fieldsStx.toList.mapM fun fieldStx => do
    let val   := fieldStx[2]
    let first ← toFieldLHS fieldStx[0][0]
    let rest  ← fieldStx[0][1].getArgs.toList.mapM toFieldLHS
    pure { ref := fieldStx, lhs := first :: rest, val := FieldVal.term val : Field Struct }
  pure ⟨stx, structName, fields, source⟩

def Struct.modifyFieldsM {m : Type → Type} [Monad m] (s : Struct) (f : Fields → m Fields) : m Struct :=
  match s with
  | ⟨ref, structName, fields, source⟩ => return ⟨ref, structName, (← f fields), source⟩

@[inline] def Struct.modifyFields (s : Struct) (f : Fields → Fields) : Struct :=
  Id.run <| s.modifyFieldsM f

def Struct.setFields (s : Struct) (fields : Fields) : Struct :=
  s.modifyFields fun _ => fields

private def expandCompositeFields (s : Struct) : Struct :=
  s.modifyFields fun fields => fields.map fun field => match field with
    | { lhs := FieldLHS.fieldName ref (Name.str Name.anonymous _ _) :: rest, .. } => field
    | { lhs := FieldLHS.fieldName ref n@(Name.str _ _ _) :: rest, .. } =>
      let newEntries := n.components.map <| FieldLHS.fieldName ref
      { field with lhs := newEntries ++ rest }
    | _ => field

private def expandNumLitFields (s : Struct) : TermElabM Struct :=
  s.modifyFieldsM fun fields => do
    let env ← getEnv
    let fieldNames := getStructureFields env s.structName
    fields.mapM fun field => match field with
      | { lhs := FieldLHS.fieldIndex ref idx :: rest, .. } =>
        if idx == 0 then throwErrorAt ref "invalid field index, index must be greater than 0"
        else if idx > fieldNames.size then throwErrorAt ref "invalid field index, structure has only #{fieldNames.size} fields"
        else pure { field with lhs := FieldLHS.fieldName ref fieldNames[idx - 1] :: rest }
      | _ => pure field

/- For example, consider the following structures:
   ```
   structure A where
     x : Nat

   structure B extends A where
     y : Nat

   structure C extends B where
     z : Bool
   ```
   This method expands parent structure fields using the path to the parent structure.
   For example,
   ```
   { x := 0, y := 0, z := true : C }
   ```
   is expanded into
   ```
   { toB.toA.x := 0, toB.y := 0, z := true : C }
   ```
-/
private def expandParentFields (s : Struct) : TermElabM Struct := do
  let env ← getEnv
  s.modifyFieldsM fun fields => fields.mapM fun field => match field with
    | { lhs := FieldLHS.fieldName ref fieldName :: rest, .. } =>
      match findField? env s.structName fieldName with
      | none => throwErrorAt ref "'{fieldName}' is not a field of structure '{s.structName}'"
      | some baseStructName =>
        if baseStructName == s.structName then pure field
        else match getPathToBaseStructure? env baseStructName s.structName with
          | some path => do
            let path := path.map fun funName => match funName with
              | Name.str _ s _ => FieldLHS.fieldName ref (Name.mkSimple s)
              | _              => unreachable!
            pure { field with lhs := path ++ field.lhs }
          | _ => throwErrorAt ref "failed to access field '{fieldName}' in parent structure"
    | _ => pure field

private abbrev FieldMap := HashMap Name Fields

private def mkFieldMap (fields : Fields) : TermElabM FieldMap :=
  fields.foldlM (init := {}) fun fieldMap field =>
    match field.lhs with
    | FieldLHS.fieldName _ fieldName :: rest =>
      match fieldMap.find? fieldName with
      | some (prevField::restFields) =>
        if field.isSimple || prevField.isSimple then
          throwErrorAt field.ref "field '{fieldName}' has already beed specified"
        else
          return fieldMap.insert fieldName (field::prevField::restFields)
      | _ => return fieldMap.insert fieldName [field]
    | _ => unreachable!

private def isSimpleField? : Fields → Option (Field Struct)
  | [field] => if field.isSimple then some field else none
  | _       => none

private def getFieldIdx (structName : Name) (fieldNames : Array Name) (fieldName : Name) : TermElabM Nat := do
  match fieldNames.findIdx? fun n => n == fieldName with
  | some idx => pure idx
  | none     => throwError "field '{fieldName}' is not a valid field of '{structName}'"

private def mkProjStx (s : Syntax) (fieldName : Name) : Syntax :=
  Syntax.node ``Lean.Parser.Term.proj #[s, mkAtomFrom s ".", mkIdentFrom s fieldName]

private def mkSubstructSource (structName : Name) (fieldNames : Array Name) (fieldName : Name) (src : Source) : TermElabM Source :=
  match src with
  | Source.explicit stx src => do
    let idx ← getFieldIdx structName fieldNames fieldName
    let stx := stx.modifyArg 0 fun stx => mkProjStx stx fieldName
    return Source.explicit stx (mkProj structName idx src)
  | s => return s

@[specialize] private def groupFields (expandStruct : Struct → TermElabM Struct) (s : Struct) : TermElabM Struct := do
  let env ← getEnv
  let fieldNames := getStructureFields env s.structName
  withRef s.ref do
  s.modifyFieldsM fun fields => do
    let fieldMap ← mkFieldMap fields
    fieldMap.toList.mapM fun ⟨fieldName, fields⟩ => do
      match isSimpleField? fields with
      | some field => pure field
      | none =>
        let substructFields := fields.map fun field => { field with lhs := field.lhs.tail! }
        let substructSource ← mkSubstructSource s.structName fieldNames fieldName s.source
        let field := fields.head!
        match Lean.isSubobjectField? env s.structName fieldName with
        | some substructName =>
          let substruct := Struct.mk s.ref substructName substructFields substructSource
          let substruct ← expandStruct substruct
          pure { field with lhs := [field.lhs.head!], val := FieldVal.nested substruct }
        | none => do
          -- It is not a substructure field. Thus, we wrap fields using `Syntax`, and use `elabTerm` to process them.
          let valStx := s.ref -- construct substructure syntax using s.ref as template
          let valStx := valStx.setArg 4 mkNullNode -- erase optional expected type
          let args   := substructFields.toArray.map fun field => mkNullNode #[field.toSyntax, mkNullNode]
          let valStx := valStx.setArg 2 (mkNullNode args)
          let valStx := setStructSourceSyntax valStx substructSource
          pure { field with lhs := [field.lhs.head!], val := FieldVal.term valStx }

def findField? (fields : Fields) (fieldName : Name) : Option (Field Struct) :=
  fields.find? fun field =>
    match field.lhs with
    | [FieldLHS.fieldName _ n] => n == fieldName
    | _                        => false

@[specialize] private def addMissingFields (expandStruct : Struct → TermElabM Struct) (s : Struct) : TermElabM Struct := do
  let env ← getEnv
  let fieldNames := getStructureFields env s.structName
  let ref := s.ref
  withRef ref do
    let fields ← fieldNames.foldlM (init := []) fun fields fieldName => do
      match findField? s.fields fieldName with
      | some field => return field::fields
      | none       =>
        let addField (val : FieldVal Struct) : TermElabM Fields := do
          return { ref := s.ref, lhs := [FieldLHS.fieldName s.ref fieldName], val := val } :: fields
        match Lean.isSubobjectField? env s.structName fieldName with
        | some substructName => do
          let substructSource ← mkSubstructSource s.structName fieldNames fieldName s.source
          let substruct := Struct.mk s.ref substructName [] substructSource
          let substruct ← expandStruct substruct
          addField (FieldVal.nested substruct)
        | none =>
          match s.source with
          | Source.none           => addField FieldVal.default
          | Source.implicit _     => addField (FieldVal.term (mkHole s.ref))
          | Source.explicit stx _ =>
            -- stx is of the form `optional (try (termParser >> "with"))`
            let src := stx[0]
            let val := mkProjStx src fieldName
            addField (FieldVal.term val)
    return s.setFields fields.reverse

private partial def expandStruct (s : Struct) : TermElabM Struct := do
  let s := expandCompositeFields s
  let s ← expandNumLitFields s
  let s ← expandParentFields s
  let s ← groupFields expandStruct s
  addMissingFields expandStruct s

structure CtorHeaderResult where
  ctorFn     : Expr
  ctorFnType : Expr
  instMVars  : Array MVarId := #[]

private def mkCtorHeaderAux : Nat → Expr → Expr → Array MVarId → TermElabM CtorHeaderResult
  | 0,   type, ctorFn, instMVars => pure { ctorFn := ctorFn, ctorFnType := type, instMVars := instMVars }
  | n+1, type, ctorFn, instMVars => do
    let type ← whnfForall type
    match type with
    | Expr.forallE _ d b c =>
      match c.binderInfo with
      | BinderInfo.instImplicit =>
        let a ← mkFreshExprMVar d MetavarKind.synthetic
        mkCtorHeaderAux n (b.instantiate1 a) (mkApp ctorFn a) (instMVars.push a.mvarId!)
      | _ =>
        let a ← mkFreshExprMVar d
        mkCtorHeaderAux n (b.instantiate1 a) (mkApp ctorFn a) instMVars
    | _ => throwError "unexpected constructor type"

private partial def getForallBody : Nat → Expr → Option Expr
  | i+1, Expr.forallE _ _ b _ => getForallBody i b
  | i+1, _                    => none
  | 0,   type                 => type

private def propagateExpectedType (type : Expr) (numFields : Nat) (expectedType? : Option Expr) : TermElabM Unit :=
  match expectedType? with
  | none              => pure ()
  | some expectedType => do
    match getForallBody numFields type with
      | none           => pure ()
      | some typeBody =>
        unless typeBody.hasLooseBVars do
          discard <| isDefEq expectedType typeBody

private def mkCtorHeader (ctorVal : ConstructorVal) (expectedType? : Option Expr) : TermElabM CtorHeaderResult := do
  let us ← mkFreshLevelMVars ctorVal.levelParams.length
  let val  := Lean.mkConst ctorVal.name us
  let type := (ConstantInfo.ctorInfo ctorVal).instantiateTypeLevelParams us
  let r ← mkCtorHeaderAux ctorVal.numParams type val #[]
  propagateExpectedType r.ctorFnType ctorVal.numFields expectedType?
  synthesizeAppInstMVars r.instMVars
  pure r

def markDefaultMissing (e : Expr) : Expr :=
  mkAnnotation `structInstDefault e

def defaultMissing? (e : Expr) : Option Expr :=
  annotation? `structInstDefault e

def throwFailedToElabField {α} (fieldName : Name) (structName : Name) (msgData : MessageData) : TermElabM α :=
  throwError "failed to elaborate field '{fieldName}' of '{structName}, {msgData}"

def trySynthStructInstance? (s : Struct) (expectedType : Expr) : TermElabM (Option Expr) := do
  if !s.allDefault then
    pure none
  else
    try synthInstance? expectedType catch _ => pure none

private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : TermElabM (Expr × Struct) := withRef s.ref do
  let env ← getEnv
  let ctorVal := getStructureCtor env s.structName
  let { ctorFn := ctorFn, ctorFnType := ctorFnType, .. } ← mkCtorHeader ctorVal expectedType?
  let (e, _, fields) ← s.fields.foldlM (init := (ctorFn, ctorFnType, [])) fun (e, type, fields) field =>
    match field.lhs with
    | [FieldLHS.fieldName ref fieldName] => do
      let type ← whnfForall type
      match type with
      | Expr.forallE _ d b c =>
        let cont (val : Expr) (field : Field Struct) : TermElabM (Expr × Expr × Fields) := do
          pushInfoTree <| InfoTree.node (children := {}) <| Info.ofFieldInfo { lctx := (← getLCtx), val := val, name := fieldName, stx := ref }
          let e     := mkApp e val
          let type  := b.instantiate1 val
          let field := { field with expr? := some val }
          pure (e, type, field::fields)
        match field.val with
        | FieldVal.term stx => cont (← elabTermEnsuringType stx d) field
        | FieldVal.nested s => do
          -- if all fields of `s` are marked as `default`, then try to synthesize instance
          match (← trySynthStructInstance? s d) with
          | some val => cont val { field with val := FieldVal.term (mkHole field.ref) }
          | none     => do let (val, sNew) ← elabStruct s (some d); let val ← ensureHasType d val; cont val { field with val := FieldVal.nested sNew }
        | FieldVal.default  => do let val ← withRef field.ref <| mkFreshExprMVar (some d); cont (markDefaultMissing val) field
      | _ => withRef field.ref <| throwFailedToElabField fieldName s.structName m!"unexpected constructor type{indentExpr type}"
    | _ => throwErrorAt field.ref "unexpected unexpanded structure field"
  pure (e, s.setFields fields.reverse)

namespace DefaultFields

structure Context where
  -- We must search for default values overriden in derived structures
  structs : Array Struct := #[]
  allStructNames : Array Name := #[]
  /--
  Consider the following example:
  ```
  structure A where
    x : Nat := 1

  structure B extends A where
    y : Nat := x + 1
    x := y + 1

  structure C extends B where
    z : Nat := 2*y
    x := z + 3
  ```
  And we are trying to elaborate a structure instance for `C`. There are default values for `x` at `A`, `B`, and `C`.
  We say the default value at `C` has distance 0, the one at `B` distance 1, and the one at `A` distance 2.
  The field `maxDistance` specifies the maximum distance considered in a round of Default field computation.
  Remark: since `C` does not set a default value of `y`, the default value at `B` is at distance 0.

  The fixpoint for setting default values works in the following way.
  - Keep computing default values using `maxDistance == 0`.
  - We increase `maxDistance` whenever we failed to compute a new default value in a round.
  - If `maxDistance > 0`, then we interrupt a round as soon as we compute some default value.
    We use depth-first search.
  - We sign an error if no progress is made when `maxDistance` == structure hierarchy depth (2 in the example above).
  -/
  maxDistance : Nat := 0

structure State where
  progress : Bool := false

partial def collectStructNames (struct : Struct) (names : Array Name) : Array Name :=
  let names := names.push struct.structName
  struct.fields.foldl (init := names) fun names field =>
    match field.val with
    | FieldVal.nested struct => collectStructNames struct names
    | _ => names

partial def getHierarchyDepth (struct : Struct) : Nat :=
  struct.fields.foldl (init := 0) fun max field =>
    match field.val with
    | FieldVal.nested struct => Nat.max max (getHierarchyDepth struct + 1)
    | _ => max

partial def findDefaultMissing? (mctx : MetavarContext) (struct : Struct) : Option (Field Struct) :=
  struct.fields.findSome? fun field =>
   match field.val with
   | FieldVal.nested struct => findDefaultMissing? mctx struct
   | _ => match field.expr? with
     | none      => unreachable!
     | some expr => match defaultMissing? expr with
       | some (Expr.mvar mvarId _) => if mctx.isExprAssigned mvarId then none else some field
       | _                         => none

def getFieldName (field : Field Struct) : Name :=
  match field.lhs with
  | [FieldLHS.fieldName _ fieldName] => fieldName
  | _ => unreachable!

abbrev M := ReaderT Context (StateRefT State TermElabM)

def isRoundDone : M Bool := do
  return (← get).progress && (← read).maxDistance > 0

def getFieldValue? (struct : Struct) (fieldName : Name) : Option Expr :=
  struct.fields.findSome? fun field =>
    if getFieldName field == fieldName then
      field.expr?
    else
      none

partial def mkDefaultValueAux? (struct : Struct) : Expr → TermElabM (Option Expr)
  | Expr.lam n d b c => withRef struct.ref do
    if c.binderInfo.isExplicit then
      let fieldName := n
      match getFieldValue? struct fieldName with
      | none     => pure none
      | some val =>
        let valType ← inferType val
        if (← isDefEq valType d) then
          mkDefaultValueAux? struct (b.instantiate1 val)
        else
          pure none
    else
      let arg ← mkFreshExprMVar d
      mkDefaultValueAux? struct (b.instantiate1 arg)
  | e =>
    if e.isAppOfArity ``id 2 then
      pure (some e.appArg!)
    else
      pure (some e)

def mkDefaultValue? (struct : Struct) (cinfo : ConstantInfo) : TermElabM (Option Expr) :=
  withRef struct.ref do
  let us ← mkFreshLevelMVarsFor cinfo
  mkDefaultValueAux? struct (cinfo.instantiateValueLevelParams us)

/-- If `e` is a projection function of one of the given structures, then reduce it -/
def reduceProjOf? (structNames : Array Name) (e : Expr) : MetaM (Option Expr) := do
  if !e.isApp then pure none
  else match e.getAppFn with
    | Expr.const name _ _ => do
      let env ← getEnv
      match env.getProjectionStructureName? name with
      | some structName =>
        if structNames.contains structName then
          Meta.unfoldDefinition? e
        else
          pure none
      | none => pure none
    | _ => pure none

/-- Reduce default value. It performs beta reduction and projections of the given structures. -/
partial def reduce (structNames : Array Name) : Expr → MetaM Expr
  | e@(Expr.lam _ _ _ _)     => lambdaLetTelescope e fun xs b => do mkLambdaFVars xs (← reduce structNames b)
  | e@(Expr.forallE _ _ _ _) => forallTelescope e fun xs b => do mkForallFVars xs (← reduce structNames b)
  | e@(Expr.letE _ _ _ _ _)  => lambdaLetTelescope e fun xs b => do mkLetFVars xs (← reduce structNames b)
  | e@(Expr.proj _ i b _)    => do
    match (← Meta.project? b i) with
    | some r => reduce structNames r
    | none   => return e.updateProj! (← reduce structNames b)
  | e@(Expr.app f _ _) => do
    match (← reduceProjOf? structNames e) with
    | some r => reduce structNames r
    | none   =>
      let f := f.getAppFn
      let f' ← reduce structNames f
      if f'.isLambda then
        let revArgs := e.getAppRevArgs
        reduce structNames (f'.betaRev revArgs)
      else
        let args ← e.getAppArgs.mapM (reduce structNames)
        return (mkAppN f' args)
  | e@(Expr.mdata _ b _) => do
    let b ← reduce structNames b
    if (defaultMissing? e).isSome && !b.isMVar then
      return b
    else
      return e.updateMData! b
  | e@(Expr.mvar mvarId _) => do
    match (← getExprMVarAssignment? mvarId) with
    | some val => if val.isMVar then reduce structNames val else pure val
    | none     => return e
  | e => return e

partial def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Array Name) (maxDistance : Nat) (fieldName : Name) (mvarId : MVarId) : TermElabM Bool :=
  let rec loop (i : Nat) (dist : Nat) := do
    if dist > maxDistance then
      pure false
    else if h : i < structs.size then do
      let struct := structs.get ⟨i, h⟩
      let defaultName := struct.structName ++ fieldName ++ `_default
      let env ← getEnv
      match env.find? defaultName with
      | some cinfo@(ConstantInfo.defnInfo defVal) => do
        let mctx ← getMCtx
        let val? ← mkDefaultValue? struct cinfo
        match val? with
        | none     => do setMCtx mctx; loop (i+1) (dist+1)
        | some val => do
          let val ← reduce allStructNames val
          match val.find? fun e => (defaultMissing? e).isSome with
          | some _ => setMCtx mctx; loop (i+1) (dist+1)
          | none   =>
            let mvarDecl ← getMVarDecl mvarId
            let val ← ensureHasType mvarDecl.type val
            assignExprMVar mvarId val
            pure true
      | _ => loop (i+1) dist
    else
      pure false
  loop 0 0

partial def step (struct : Struct) : M Unit :=
  unless (← isRoundDone) do
    withReader (fun ctx => { ctx with structs := ctx.structs.push struct }) do
      for field in struct.fields do
        match field.val with
        | FieldVal.nested struct => step struct
        | _ => match field.expr? with
          | none      => unreachable!
          | some expr => match defaultMissing? expr with
            | some (Expr.mvar mvarId _) =>
              unless (← isExprMVarAssigned mvarId) do
                let ctx ← read
                if (← withRef field.ref <| tryToSynthesizeDefault ctx.structs ctx.allStructNames ctx.maxDistance (getFieldName field) mvarId) then
                  modify fun s => { s with progress := true }
            | _ => pure ()

partial def propagateLoop (hierarchyDepth : Nat) (d : Nat) (struct : Struct) : M Unit := do
  match findDefaultMissing? (← getMCtx) struct with
  | none       => pure () -- Done
  | some field =>
    if d > hierarchyDepth then
      throwErrorAt field.ref "field '{getFieldName field}' is missing"
    else withReader (fun ctx => { ctx with maxDistance := d }) do
      modify fun s => { s with progress := false }
      step struct
      if (← get).progress then do
        propagateLoop hierarchyDepth 0 struct
      else
        propagateLoop hierarchyDepth (d+1) struct

def propagate (struct : Struct) : TermElabM Unit :=
  let hierarchyDepth := getHierarchyDepth struct
  let structNames := collectStructNames struct #[]
  (propagateLoop hierarchyDepth 0 struct { allStructNames := structNames }).run' {}

end DefaultFields

private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (source : Source) : TermElabM Expr := do
  let (structName, structType) ← getStructName stx expectedType? source
  unless isStructureLike (← getEnv) structName do
    throwError "invalid \{...} notation, structure type expected{indentExpr structType}"
  let struct ← liftMacroM <| mkStructView stx structName source
  let struct ← expandStruct struct
  trace[Elab.struct] "{struct}"
  let (r, struct) ← elabStruct struct expectedType?
  DefaultFields.propagate struct
  return r

@[builtinTermElab structInst] def elabStructInst : TermElab := fun stx expectedType? => do
  match (← expandNonAtomicExplicitSource stx) with
  | some stxNew => withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
  | none =>
    let sourceView ← getStructSource stx
    match (← isModifyOp? stx), sourceView with
    | some modifyOp, Source.explicit source _ => elabModifyOp stx modifyOp source expectedType?
    | some _,        _                        => throwError "invalid \{...} notation, explicit source is required when using '[<index>] := <value>'"
    | _,             _                        => elabStructInstAux stx expectedType? sourceView

builtin_initialize registerTraceClass `Elab.struct

end Lean.Elab.Term.StructInst


import category_theory.category.basic

import topos
import subobject_classifier
import presheaf
import forcing.semantics

open category_theory category_theory.category category_theory.limits classifier

universes v u

noncomputable theory

variables {C : Type u} [category.{u} C] [small_category C]

namespace forcing

local notation `°`:std.prec.max_plus C := Cᵒᵖ ⥤ Type u
local notation `₸` := ⊤_ (°C)

-- Abbreviation for Yoneda on objects and on maps
abbreviation yob (c : Cᵒᵖ) := yoneda.obj c.unop
abbreviation yom {c d : Cᵒᵖ} (f : c ⟶ d) : yob d ⟶ yob c := yoneda.map f.unop

structure forces {X : °C} (σ : X ⟶ Ω °C) {c : Cᵒᵖ} (x : yob c ⟶ X) :=
(lift : yob c ⟶ s{ σ }s)
(comm' : lift ≫ canonical_incl σ = x. obviously)

restate_axiom forces.comm'
attribute [simp, reassoc] forces.comm

@[ext]
protected lemma lift_ext {X : °C} (σ : X ⟶ Ω °C) {c : Cᵒᵖ} (x : yob c ⟶ X) :
  Π {α β : forces σ x}, α.lift = β.lift → α = β
| ⟨Ra, _⟩ ⟨Sa, _⟩ rfl := rfl

instance subsingleton_forces {X : °C} (σ : X ⟶ Ω °C) {c : Cᵒᵖ} (x : yob c ⟶ X) :
  subsingleton (forces σ x) :=
begin
  fsplit, intros, ext1,
  apply pullback.hom_ext,
  { rw [a.comm, b.comm] },
  { simp }
end

def pforces {X : °C} (σ : X ⟶ Ω °C) {c : Cᵒᵖ} (x : yob c ⟶ X) : Prop :=
  ∃ lift : yob c ⟶ s{ σ }s, lift ≫ canonical_incl σ = x

variables {X : °C} (σ : X ⟶ Ω °C) {c : Cᵒᵖ} (x : yob c ⟶ X)

lemma forces_to_pforces {x : yob c ⟶ X} (α : forces σ x) : pforces σ x := ⟨α.lift, α.comm⟩
lemma pforces_to_forces {x : yob c ⟶ X} (α : pforces σ x) : forces σ x :=
{ lift := (classical.indefinite_description _ α).val,
  comm' := (classical.indefinite_description _ α).prop }

lemma pforces_of_valid (h : validity.is_valid σ) : pforces σ x :=
begin
  rw validity.valid_iff_is_iso at h,
  resetI,
  refine ⟨ x ≫ (as_iso (canonical_incl σ)).inv, _ ⟩,
  rw [assoc, as_iso_inv, is_iso.inv_hom_id, comp_id]
end

lemma valid_yoneda_iff_pforces :
  pforces σ x ↔ validity.is_valid (x ≫ σ) :=
begin
  split,
  { intro h, cases h with w h, dunfold validity.is_valid,
    rw [←h, assoc, canonical_incl_comm, ←assoc, limits.terminal.comp_from w]
  },
  { intro h, dunfold validity.is_valid at h,
    exact ⟨pullback.lift x (terminal.from (yob c)) h, pullback.lift_fst _ _ _⟩ }
end

def π_el.obj (d : (X.elements)ᵒᵖ) := (category_of_elements.π X).obj d.unop
def π_el.map {d e : (X.elements)ᵒᵖ} (f : d ⟶ e) : π_el.obj e ⟶ π_el.obj d :=
(category_of_elements.π X).map f.unop

@[simp] lemma simp_el_yob (d : (X.elements)ᵒᵖ) :
  (functor_to_representables X).obj d = yob (π_el.obj d) :=
begin
   unfold functor_to_representables π_el.obj,
   rw functor.comp_obj,
   simp
end
-- set_option trace.simp_lemmas true
def forall_pforces_to_cocone (u : ∀ (c : Cᵒᵖ) (x : yob c ⟶ X), forces σ x) :
  cocone (functor_to_representables X) :=
{ X := s{ σ }s,
  ι := { app := λ d, (u (π_el.obj d) ((cocone_of_representable X).ι.app d)).lift,
         naturality' :=
          begin
            intros d e f,
            dunfold functor_to_representables,
            simp only [functor.comp_map, functor.left_op_map, category_of_elements.π_map,
                       subtype.val_eq_coe, functor.const_obj_map],
            rw [@comp_id _ _ _ (s{σ}s), ←cancel_mono (canonical_incl σ), assoc, (u _ _).comm,
                (u _ _).comm, cocone_of_representable_ι_app, cocone_of_representable_ι_app],
            dsimp, ext,
            simp only [functor_to_types.comp, yoneda_map_app, yoneda_sections_small_inv_app_apply,
                       op_comp, quiver.hom.op_unop, functor_to_types.map_comp_apply],
            rw f.unop.prop,
          end } }

@[simp] lemma test (u : ∀ (c : Cᵒᵖ) (x : yob c ⟶ X), forces σ x) (d : (functor.elements X)ᵒᵖ) :
  (forall_pforces_to_cocone σ u).ι.app d =
  (u (π_el.obj d) ((cocone_of_representable X).ι.app d)).lift := by { refl }

def forall_pforces_to_split_epi (u : ∀ (c : Cᵒᵖ) (x : yob c ⟶ X), forces σ x) :
  split_epi (canonical_incl σ) :=
{ section_ := is_colimit.desc (colimit_of_representable X) (forall_pforces_to_cocone σ u),
  id' :=
  begin
    apply is_colimit.hom_ext (colimit_of_representable X),
    intro d,
    rw @comp_id _ _ _ X,
    simp
  end
}

-- http://chanavat.site/files/lmfi-thesis.pdf Theorem 2.10
lemma valid_iff_forall_pforces {X : °C} (σ : X ⟶ Ω °C) :
  validity.is_valid σ ↔ ∀ (c : Cᵒᵖ) (x : yob c ⟶ X), pforces σ x :=
begin
  split,
  { rw validity.valid_iff_is_iso, intros h c x,
    cases h.out with incl_inv h,
    use x ≫ incl_inv,
    rw [assoc, h.right, comp_id] },
  { rw validity.valid_iff_section, intro u,
    fsplit, fsplit,
    exact forall_pforces_to_split_epi σ (λ c x, pforces_to_forces σ (u c x)) }
end

lemma monotonicity (h : forces σ x) {b : Cᵒᵖ} (f : c ⟶ b) : forces σ (yom f ≫ x) :=
{ lift := yom f ≫ h.lift,
  comm' := by rw [assoc, h.comm] }

def yob_terminal_iso_terminal [has_terminal C] : (yob (opposite.op (⊤_ C))) ≅ ₸ :=
begin
  rw [←as_empty_cone_X (⊤_ °C), ←as_empty_cone_X (yob (opposite.op (⊤_ C)))],
  apply is_limit.cone_point_unique_up_to_iso,
  { apply category_theory.limits.is_terminal.is_terminal_obj, exact terminal_is_terminal },
  { exact terminal_is_terminal }
end

lemma closed_valid_iff_forces_terminal [has_terminal C] (τ : ₸ ⟶ Ω °C) :
  pforces τ (terminal.from (yob (opposite.op (⊤_ C)))) ↔ validity.is_valid τ :=
begin
  rw validity.valid_iff_section,
  split,
  { intro u, fsplit, fsplit,
    refine ⟨yob_terminal_iso_terminal.inv ≫ (pforces_to_forces _ u).lift, _⟩,
    simp only [eq_iff_true_of_subsingleton],
  },
  { intro h,
    resetI,
    refine ⟨yob_terminal_iso_terminal.hom ≫ (section_ (canonical_incl τ)), _⟩,
    rw [assoc, is_split_epi.id, comp_id],
    exact is_terminal.hom_ext (terminal_is_terminal) _ _ }
end

-- Theorem 2.13 thesis
lemma forcing_bot : ¬ pforces ⊥ x :=
begin
  intro u,
  have i := (category_theory.yoneda_sections_small _ _).hom (pforces_to_forces _ u).lift,
  simp at i,
  have k := (external_iso_internal.bot' X).app c,
  exact pempty.elim ((presheaf.initial.pempty_obj_iso c).hom (k.inv i)),
end

lemma forcing_top : pforces ⊤ x :=
begin
  apply pforces_of_valid,
  rw validity.valid_iff_eq_sub_top,
  exact (external_iso_internal.top_sub X).symm
end

variables (σ) (τ : X ⟶ Ω °C)

lemma forcing_and : pforces (σ ⊓ τ) x ↔ pforces σ x ∧ pforces τ x :=
begin
  split; intro h,
  { split; cases h with u h,
      use u ≫ pullback.lift (canonical_incl (σ ⊓ τ)) (terminal.from _)
                (external_iso_internal.left_square_commutes_fst σ τ),
      rwa [assoc, pullback.lift_fst],
      use u ≫ pullback.lift (canonical_incl (σ ⊓ τ)) (terminal.from _)
                (external_iso_internal.left_square_commutes_snd σ τ),
      rwa [assoc, pullback.lift_fst] },
  { have comm : x ≫ limits.prod.lift σ τ = terminal.from _ ≫ truth_truth °C :=
    begin
      apply limits.prod.hom_ext; rw assoc; rw assoc,
        repeat { rw limits.prod.lift_fst }, cases h.left with u hu,
        rw [←hu, assoc, canonical_incl_comm, ←assoc, terminal.comp_from u],
        repeat { rw limits.prod.lift_snd }, cases h.right with u hu,
        rw [←hu, assoc, canonical_incl_comm, ←assoc, terminal.comp_from u],
    end,
    let l := pullback_cone.is_limit.lift' (external_iso_internal.is_pullback_and_left σ τ)
              x (terminal.from _) comm,
    exact ⟨l.val, l.prop.left ⟩ }
end

end forcing


/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lean.Data.NameMap
import Lake.Util.Compare

open Lean

namespace Lake

export Lean (Name NameMap)

@[inline] def NameMap.empty : NameMap α := RBMap.empty

instance : ForIn m (NameMap α) (Name × α) where
  forIn self init f := self.forIn init f

/-! # Name Helpers -/

namespace Name
open Lean.Name

@[simp] protected theorem beq_false (m n : Name) : (m == n) = false ↔ ¬ (m = n) := by
  rw [← beq_iff_eq m n]; cases m == n <;> simp (config := { decide := true })

@[simp] theorem isPrefixOf_self {n : Name} : n.isPrefixOf n := by
  cases n <;> simp [isPrefixOf]

@[simp] theorem isPrefixOf_append {n m : Name} : ¬ n.hasMacroScopes → ¬ m.hasMacroScopes → n.isPrefixOf (n ++ m) := by
  intro h1 h2
  show n.isPrefixOf (n.append m)
  simp_all [Name.append]
  clear h2; induction m <;> simp [*, Name.appendCore, isPrefixOf]

@[simp] theorem quickCmpAux_iff_eq : ∀ {n n'}, quickCmpAux n n' = .eq ↔ n = n'
| .anonymous, n => by cases n <;> simp [quickCmpAux]
| n, .anonymous => by cases n <;> simp [quickCmpAux]
| .num .., .str .. => by simp [quickCmpAux]
| .str .., .num .. => by simp [quickCmpAux]
| .num p₁ n₁, .num p₂ n₂ => by
  simp only [quickCmpAux]; split <;>
  simp_all [quickCmpAux_iff_eq, show ∀ p, (p → False) ↔ ¬ p from fun _ => .rfl]
| .str p₁ s₁, .str p₂ s₂ => by
  simp only [quickCmpAux]; split <;>
  simp_all [quickCmpAux_iff_eq, show ∀ p, (p → False) ↔ ¬ p from fun _ => .rfl]

instance : LawfulCmpEq Name quickCmpAux where
  eq_of_cmp := quickCmpAux_iff_eq.mp
  cmp_rfl := quickCmpAux_iff_eq.mpr rfl

theorem eq_of_quickCmp {n n' : Name} : n.quickCmp n' = .eq → n = n' := by
  unfold Name.quickCmp
  intro h_cmp; split at h_cmp
  next => exact eq_of_cmp h_cmp
  next => contradiction

theorem quickCmp_rfl {n : Name} : n.quickCmp n = .eq := by
  unfold Name.quickCmp
  split <;> exact cmp_rfl

instance : LawfulCmpEq Name Name.quickCmp where
  eq_of_cmp := eq_of_quickCmp
  cmp_rfl := quickCmp_rfl

open Syntax

def quoteFrom (ref : Syntax) : Name → Term
| .anonymous => mkCIdentFrom ref ``anonymous
| .str p s => mkApp (mkCIdentFrom ref ``mkStr) #[quoteFrom ref p, quote s]
| .num p v => mkApp (mkCIdentFrom ref ``mkNum) #[quoteFrom ref p, quote v]


import Lean.Hygiene

def otherInhabited : Inhabited Nat := ⟨42⟩

def f := Id.run do
  let ⟨n⟩ ← pure otherInhabited
  -- do-notation expands to `pure otherInhabited >>= fun x : Inhabited Nat => ...`
  -- the `x : Inhabited Nat` should not be available for TC synth (i.e., `default` should be 0)
  return default + n

example : f = 42 := rfl

open Lean
def g : Syntax :=
  let rec stx : Syntax := Unhygienic.run `(f 0 1)
  let stx := stx
  match stx with
  | `(f $_args*) => ‹Syntax› -- should not resolve to tmp var created by stx matcher
  | _ => default

example : g = g.stx := rfl


import ..flocq

/- Architecture-dependent parameters for ARM -/

namespace archi
open flocq

def ptr64 : bool := ff

def big_endian : bool := sorry

def align_int64 := 8
def align_float64 := 8

def splitlong := tt

lemma splitlong_ptr32 : splitlong = tt → ptr64 = ff := λ_, rfl

def default_pl_64 : bool × nan_pl 53 :=
(ff, word.repr (2^51))

def choose_binop_pl_64 (s1 : bool) (pl1 : nan_pl 53) (s2 : bool) (pl2 : nan_pl 53) : bool :=
/- Choose second NaN if pl2 is sNaN but pl1 is qNan.
   In all other cases, choose first NaN -/
pl1.unsigned.test_bit 51 && bnot (pl2.unsigned.test_bit 51)

def default_pl_32 : bool × nan_pl 24 :=
(ff,  word.repr (2^22))

def choose_binop_pl_32 (s1 : bool) (pl1 : nan_pl 24) (s2 : bool) (pl2 : nan_pl 24) : bool :=
/- Choose second NaN if pl2 is sNaN but pl1 is qNan.
   In all other cases, choose first NaN -/
pl1.unsigned.test_bit 22 && bnot (pl2.unsigned.test_bit 22)

def float_of_single_preserves_sNaN := ff

/- Which ABI to use : either the standard ARM EABI with floats passed
  in integer registers, or the "hardfloat" variant of the EABI
  that uses FP registers instead. -/

inductive abi_kind | Softfloat | Hardfloat
constant abi : abi_kind

end archi


/-
Copyright (c) E.W.Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Author: E.W.Ayers
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.function
import Mathlib.Lean3Lib.init.data.option.basic
import Mathlib.Lean3Lib.init.util
import Mathlib.Lean3Lib.init.meta.tactic
import Mathlib.Lean3Lib.init.meta.mk_dec_eq_instance
import Mathlib.Lean3Lib.init.meta.json

universes l

namespace Mathlib

/-! A component is a piece of UI which may contain internal state. Use component.mk to build new components.

## Using widgets.

To make a widget, you need to make a custom executor object and then instead of calling `save_info_thunk` you call `save_widget`.

Additionally, you will need a compatible build of the vscode extension or web app to use widgets in vscode.

## How it works:

The design is inspired by React.
If you are familiar with using React or Elm or a similar functional UI framework then that's helpful for this.
The [React article on reconciliation](https://reactjs.org/docs/reconciliation.html) might be helpful.

One can imagine making a UI for a particular object as just being a function `f : α → UI` where `UI` is some inductive datatype for buttons, textboxes, lists and so on.
The process of evaluating `f` is called __rendering__.
So for example `α` could be `tactic_state` and the function renders a goal view.

## HTML

For our purposes, `UI` is an HTML tree and is written `html α : Type`. I'm going to assume some familiarity with HTML for the purposes of this document.
An HTML tree is composed of elements and strings.
Each element has a tag such as "div", "span", "article" and so on and a set of attributes and child html.
Use the helper function `h : string → list (attr α) → list (html α) → html α` to build new pieces of `html`. So for example:

```lean
h "ul" [] [
     h "li" [] ["this is list item 1"],
     h "li" [style [("color", "blue")]] ["this is list item 2"],
     h "hr" [] [],
     h "li" [] [
          h "span" [] ["there is a button here"],
          h "button" [on_click (λ _, 3)] ["click me!"]
     ]
]
```
Has the type `html nat`.
The `nat` type is called the __action__ and whenever the user interacts with the UI, the html will emit an object of type `nat`.
So for example if the user clicks the button above, the html will 'emit' `3`.
The above example is compiled to the following piece of html:

```html
<ul>
  <li>this is list item 1</li>
  <li style="{ color: blue; }">this is list item 2</li>
  <hr/>
  <li>
     <span>There is a button here</span>
     <button onClick="[handler]">click me!</button>
  </li>
</ul>
```

## Components

In order for the UI to react to events, you need to be able to take these actions α and alter some state.
To do this we use __components__. `component` takes two type arguments: `π` and `α`. `α` is called the 'action' and `π` are the 'props'.
The props can be thought of as a kind of wrapped function domain for `component`. So given `C : component nat α`, one can turn this into html with
`html.of_component 4 C : html α`.

The base constructor for a component is `pure`:
```lean
meta def Hello : component string α := component.pure (λ s, ["hello, ", s, ", good day!"])

#html Hello "lean" -- renders "hello, lean, good day!"
```
So here a pure component is just a simple function `π → list (html α)`.
However, one can augment components with __hooks__.
The hooks available for compoenents are listed in the inductive definition for component.

Here we will just look at the `with_state` hook, which can be used to build components with inner state.

```
meta inductive my_action
| increment
| decrement
open my_action

meta def Counter : component unit α :=
component.with_state
     my_action          -- the action of the inner component
     int                -- the state
     (λ _, 0)           -- initialise the state
     (λ _ _ s, s)       -- update the state if the props change
     (λ _ s a,          -- update the state if an action was received
          match a with
          | increment := (s + 1, none) -- replace `none` with `some _` to emit an action
          | decrement := (s - 1, none)
          end
     )
$ component.pure (λ ⟨state, ⟨⟩⟩, [
     button "+" (λ _, increment),
     to_string state,
     button "-" (λ _, decrement)
  ])

#html Counter ()
```

You can add many hooks to a component.

- `filter_map_action` lets you filter or map actions that are emmitted by the component
- `map_props` lets you map the props.
- `with_should_update` will not re-render the child component if the given test returns false. This can be useful for efficiency.
- `with_state` discussed above.`
- `with_mouse` subscribes the component to the mouse state, for example whether or not the mouse is over the component. See the `tests/lean/widget/widget_mouse.lean` test for an example.

Given an active document, Lean (in server mode) maintains a set of __widgets__ for the document.
A widget is a component `c`, some `p : Props` and an internal state-manager which manages the states
of the component and subcomponents and also handles the routing of events from the UI.

## Reconciliation

If a parent component's state changes, this can cause child components to change position or to appear and dissappear.
However we want to preserve the state of these child components where we can.
The UI system will try to match up these child components through a process called __reconciliation__.

Reconciliation will make sure that the states are carried over correctly and will also not rerender subcomponents if they haven't changed their props or state.
To compute whether two components are the same, the system will perform a hash on their VM objects.
Not all VM objects can be hashed, so it's important to make sure that any items that you expect to change over the lifetime of the component are fed through the 'Props' argument.
This is why we need the props argument on `component`.
The reconciliation engine uses the `props_eq` predicate passed to the component constructor to determine whether the props have changed and hence whether the component should be re-rendered.

## Keys

If you have some list of components and the list changes according to some state, it is important to add keys to the components so
that if two components change order in the list their states are preserved.
If you don't provide keys or there are duplicate keys then you may get some strange behaviour in both the Lean widget engine and react.

It is possible to use incorrect HTML tags and attributes, there is (currently) no type checking that the result is a valid piece of HTML.
So for example, the client widget system will error if you add a `text_change_event` attribute to anything other than an element tagged with `input`.

## Styles with Tachyons

The widget system assumes that a stylesheet called 'tachyons' is present.
You can find documentation for this stylesheet at [Tachyons.io](http://tachyons.io/).
Tachyons was chosen because it is very terse and allows arbitrary styling without using inline styles and without needing to dynamically load a stylesheet.

## Further work (up for grabs!)

- Add type checking for html.
- Better error handling when the html tree is malformed.
- Better error handling when keys are malformed.
- Add a 'with_task' which lets long-running operations (eg running `simp`) not block the UI update.
- Timers, animation (ambitious).
- More event handlers
- Drag and drop support.
- The current perf bottleneck is sending the full UI across to the server for every update.
  Instead, it should be possible to send a smaller [JSON Patch](http://jsonpatch.com).
  Which is already supported by `json.hpp` and javascript ecosystem.

-/

namespace widget

inductive mouse_event_kind where
| on_click : mouse_event_kind
| on_mouse_enter : mouse_event_kind
| on_mouse_leave : mouse_event_kind

end Mathlib


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Sebastian Ullrich
-/
import Lean.Util.CollectLevelParams
import Lean.Elab.DeclUtil
import Lean.Elab.DefView
import Lean.Elab.Inductive
import Lean.Elab.Structure
import Lean.Elab.MutualDef
import Lean.Elab.DeclarationRange
namespace Lean.Elab.Command

open Meta

/- Auxiliary function for `expandDeclNamespace?` -/
def expandDeclIdNamespace? (declId : Syntax) : Option (Name × Syntax) :=
  let (id, optUnivDeclStx) := expandDeclIdCore declId
  let scpView := extractMacroScopes id
  match scpView.name with
  | Name.str Name.anonymous s _ => none
  | Name.str pre s _            =>
    let nameNew := { scpView with name := Name.mkSimple s }.review
    if declId.isIdent then
      some (pre, mkIdentFrom declId nameNew)
    else
      some (pre, declId.setArg 0 (mkIdentFrom declId nameNew))
  | _ => none

/- given declarations such as `@[...] def Foo.Bla.f ...` return `some (Foo.Bla, @[...] def f ...)` -/
def expandDeclNamespace? (stx : Syntax) : Option (Name × Syntax) :=
  if !stx.isOfKind `Lean.Parser.Command.declaration then none
  else
    let decl := stx[1]
    let k := decl.getKind
    if k == `Lean.Parser.Command.abbrev ||
       k == `Lean.Parser.Command.def ||
       k == `Lean.Parser.Command.theorem ||
       k == `Lean.Parser.Command.constant ||
       k == `Lean.Parser.Command.axiom ||
       k == `Lean.Parser.Command.inductive ||
       k == `Lean.Parser.Command.classInductive ||
       k == `Lean.Parser.Command.structure then
      match expandDeclIdNamespace? decl[1] with
      | some (ns, declId) => some (ns, stx.setArg 1 (decl.setArg 1 declId))
      | none              => none
    else if k == `Lean.Parser.Command.instance then
      let optDeclId := decl[3]
      if optDeclId.isNone then none
      else match expandDeclIdNamespace? optDeclId[0] with
        | some (ns, declId) => some (ns, stx.setArg 1 (decl.setArg 3 (optDeclId.setArg 0 declId)))
        | none              => none
    else
      none

def elabAxiom (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
  -- leading_parser "axiom " >> declId >> declSig
  let declId             := stx[1]
  let (binders, typeStx) := expandDeclSig stx[2]
  let scopeLevelNames ← getLevelNames
  let ⟨name, declName, allUserLevelNames⟩ ← expandDeclId declId modifiers
  addDeclarationRanges declName stx
  runTermElabM declName fun vars => Term.withLevelNames allUserLevelNames $ Term.elabBinders binders.getArgs fun xs => do
    Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.beforeElaboration
    let type ← Term.elabType typeStx
    Term.synthesizeSyntheticMVarsNoPostponing
    let type ← instantiateMVars type
    let type ← mkForallFVars xs type
    let type ← mkForallFVars vars type (usedOnly := true)
    let (type, _) ← Term.levelMVarToParam type
    let usedParams  := collectLevelParams {} type |>.params
    match sortDeclLevelParams scopeLevelNames allUserLevelNames usedParams with
    | Except.error msg      => throwErrorAt stx msg
    | Except.ok levelParams =>
      let decl := Declaration.axiomDecl {
        name        := declName,
        levelParams := levelParams,
        type        := type,
        isUnsafe    := modifiers.isUnsafe
      }
      Term.ensureNoUnassignedMVars decl
      addDecl decl
      Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.afterTypeChecking
      if isExtern (← getEnv) declName then
        compileDecl decl
      Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.afterCompilation

/-
leading_parser "inductive " >> declId >> optDeclSig >> optional ":=" >> many ctor
leading_parser atomic (group ("class " >> "inductive ")) >> declId >> optDeclSig >> optional ":=" >> many ctor >> optDeriving
-/
private def inductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : CommandElabM InductiveView := do
  checkValidInductiveModifier modifiers
  let (binders, type?) := expandOptDeclSig decl[2]
  let declId           := decl[1]
  let ⟨name, declName, levelNames⟩ ← expandDeclId declId modifiers
  addDeclarationRanges declName decl
  let ctors      ← decl[4].getArgs.mapM fun ctor => withRef ctor do
    -- def ctor := leading_parser " | " >> declModifiers >> ident >> optional inferMod >> optDeclSig
    let ctorModifiers ← elabModifiers ctor[1]
    if ctorModifiers.isPrivate && modifiers.isPrivate then
      throwError "invalid 'private' constructor in a 'private' inductive datatype"
    if ctorModifiers.isProtected && modifiers.isPrivate then
      throwError "invalid 'protected' constructor in a 'private' inductive datatype"
    checkValidCtorModifier ctorModifiers
    let ctorName := ctor.getIdAt 2
    let ctorName := declName ++ ctorName
    let ctorName ← withRef ctor[2] $ applyVisibility ctorModifiers.visibility ctorName
    let inferMod := !ctor[3].isNone
    let (binders, type?) := expandOptDeclSig ctor[4]
    addDocString' ctorName ctorModifiers.docString?
    addAuxDeclarationRanges ctorName ctor ctor[2]
    pure { ref := ctor, modifiers := ctorModifiers, declName := ctorName, inferMod := inferMod, binders := binders, type? := type? : CtorView }
  let classes ← getOptDerivingClasses decl[5]
  pure {
    ref             := decl
    modifiers       := modifiers
    shortDeclName   := name
    declName        := declName
    levelNames      := levelNames
    binders         := binders
    type?           := type?
    ctors           := ctors
    derivingClasses := classes
  }

private def classInductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : CommandElabM InductiveView :=
  inductiveSyntaxToView modifiers decl

def elabInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
  let v ← inductiveSyntaxToView modifiers stx
  elabInductiveViews #[v]

def elabClassInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
  let modifiers := modifiers.addAttribute { name := `class }
  let v ← classInductiveSyntaxToView modifiers stx
  elabInductiveViews #[v]

@[builtinCommandElab declaration]
def elabDeclaration : CommandElab := fun stx =>
  match expandDeclNamespace? stx with
  | some (ns, newStx) => do
    let ns := mkIdentFrom stx ns
    let newStx ← `(namespace $ns:ident $newStx end $ns:ident)
    withMacroExpansion stx newStx $ elabCommand newStx
  | none => do
    let modifiers ← elabModifiers stx[0]
    let decl     := stx[1]
    let declKind := decl.getKind
    if declKind == `Lean.Parser.Command.«axiom» then
      elabAxiom modifiers decl
    else if declKind == `Lean.Parser.Command.«inductive» then
      elabInductive modifiers decl
    else if declKind == `Lean.Parser.Command.classInductive then
      elabClassInductive modifiers decl
    else if declKind == `Lean.Parser.Command.«structure» then
      elabStructure modifiers decl
    else if isDefLike decl then
      elabMutualDef #[stx]
    else
      throwError "unexpected declaration"

/- Return true if all elements of the mutual-block are inductive declarations. -/
private def isMutualInductive (stx : Syntax) : Bool :=
  stx[1].getArgs.all fun elem =>
    let decl     := elem[1]
    let declKind := decl.getKind
    declKind == `Lean.Parser.Command.inductive

private def elabMutualInductive (elems : Array Syntax) : CommandElabM Unit := do
  let views ← elems.mapM fun stx => do
     let modifiers ← elabModifiers stx[0]
     inductiveSyntaxToView modifiers stx[1]
  elabInductiveViews views

/- Return true if all elements of the mutual-block are definitions/theorems/abbrevs. -/
private def isMutualDef (stx : Syntax) : Bool :=
  stx[1].getArgs.all fun elem =>
    let decl := elem[1]
    isDefLike decl

private def isMutualPreambleCommand (stx : Syntax) : Bool :=
  let k := stx.getKind
  k == `Lean.Parser.Command.variable ||
  k == `Lean.Parser.Command.variables ||
  k == `Lean.Parser.Command.universe ||
  k == `Lean.Parser.Command.universes ||
  k == `Lean.Parser.Command.check ||
  k == `Lean.Parser.Command.set_option ||
  k == `Lean.Parser.Command.open

private partial def splitMutualPreamble (elems : Array Syntax) : Option (Array Syntax × Array Syntax) :=
  let rec loop (i : Nat) : Option (Array Syntax × Array Syntax) :=
    if h : i < elems.size then
      let elem := elems.get ⟨i, h⟩
      if isMutualPreambleCommand elem then
        loop (i+1)
      else if i == 0 then
        none -- `mutual` block does not contain any preamble commands
      else
        some (elems[0:i], elems[i:elems.size])
    else
      none -- a `mutual` block containing only preamble commands is not a valid `mutual` block
  loop 0

@[builtinMacro Lean.Parser.Command.mutual]
def expandMutualNamespace : Macro := fun stx => do
  let mut ns?      := none
  let mut elemsNew := #[]
  for elem in stx[1].getArgs do
    match ns?, expandDeclNamespace? elem with
    | _, none                         => elemsNew := elemsNew.push elem
    | none, some (ns, elem)           => ns? := some ns; elemsNew := elemsNew.push elem
    | some nsCurr, some (nsNew, elem) =>
      if nsCurr == nsNew then
        elemsNew := elemsNew.push elem
      else
        Macro.throwErrorAt elem s!"conflicting namespaces in mutual declaration, using namespace '{nsNew}', but used '{nsCurr}' in previous declaration"
  match ns? with
  | some ns =>
    let ns := mkIdentFrom stx ns
    let stxNew := stx.setArg 1 (mkNullNode elemsNew)
    `(namespace $ns:ident $stxNew end $ns:ident)
  | none => Macro.throwUnsupported

@[builtinMacro Lean.Parser.Command.mutual]
def expandMutualElement : Macro := fun stx => do
  let mut elemsNew := #[]
  let mut modified := false
  for elem in stx[1].getArgs do
    match (← expandMacro? elem) with
    | some elemNew => elemsNew := elemsNew.push elemNew; modified := true
    | none         => elemsNew := elemsNew.push elem
  if modified then
    pure $ stx.setArg 1 (mkNullNode elemsNew)
  else
    Macro.throwUnsupported

@[builtinMacro Lean.Parser.Command.mutual]
def expandMutualPreamble : Macro := fun stx =>
  match splitMutualPreamble stx[1].getArgs with
  | none => Macro.throwUnsupported
  | some (preamble, rest) => do
    let secCmd    ← `(section)
    let newMutual := stx.setArg 1 (mkNullNode rest)
    let endCmd    ← `(end)
    pure $ mkNullNode (#[secCmd] ++ preamble ++ #[newMutual] ++ #[endCmd])

@[builtinCommandElab «mutual»]
def elabMutual : CommandElab := fun stx => do
  if isMutualInductive stx then
    elabMutualInductive stx[1].getArgs
  else if isMutualDef stx then
    elabMutualDef stx[1].getArgs
  else
    throwError "invalid mutual block"

/- leading_parser "attribute " >> "[" >> sepBy1 (eraseAttr <|> Term.attrInstance) ", " >> "]" >> many1 ident -/
@[builtinCommandElab «attribute»] def elabAttr : CommandElab := fun stx => do
  let mut attrInsts := #[]
  let mut toErase := #[]
  for attrKindStx in stx[2].getSepArgs do
    if attrKindStx.getKind == ``Lean.Parser.Command.eraseAttr then
      let attrName := attrKindStx[1].getId.eraseMacroScopes
      unless isAttribute (← getEnv) attrName do
        throwError "unknown attribute [{attrName}]"
      toErase := toErase.push attrName
    else
      attrInsts := attrInsts.push attrKindStx
  let attrs ← elabAttrs attrInsts
  let idents := stx[4].getArgs
  for ident in idents do withRef ident <| liftTermElabM none do
    let declName ← resolveGlobalConstNoOverloadWithInfo ident
    Term.applyAttributes declName attrs
    for attrName in toErase do
      Attribute.erase declName attrName

def expandInitCmd (builtin : Bool) : Macro := fun stx =>
  let optHeader := stx[1]
  let doSeq     := stx[2]
  let attrId    := mkIdentFrom stx $ if builtin then `builtinInit else `init
  if optHeader.isNone then
    `(@[$attrId:ident]def initFn : IO Unit := do $doSeq)
  else
    let id   := optHeader[0]
    let type := optHeader[1][1]
    `(def initFn : IO $type := do $doSeq
      @[$attrId:ident initFn]constant $id : $type)

@[builtinMacro Lean.Parser.Command.«initialize»] def expandInitialize : Macro :=
  expandInitCmd (builtin := false)

@[builtinMacro Lean.Parser.Command.«builtin_initialize»] def expandBuiltinInitialize : Macro :=
  expandInitCmd (builtin := true)

end Lean.Elab.Command


import macro

def α_conv (rsm : resolve_map) (σ : syntax_id → name) : syntax → syntax
| (syntax.ident ident) := match rsm.find ident.id with
  -- TODO: renaming of globals?
  | some r@{decl := sum.inl id, ..} := syntax.ident {ident with sp := none, name := ident.name.replace_prefix' r.prefix (σ id)}
  | _   := syntax.ident {ident with sp := none, name := σ ident.id}
  end
| (syntax.node node) := syntax.node {node with args := node.args.map (λ a, α_conv a)}
| (syntax.list ls) := syntax.list (ls.map (λ a, α_conv a))
| a@(syntax.atom _) := a
using_well_founded { dec_tac := tactic.admit }

def α_equiv (rsm : resolve_map) (s₁ s₂ : syntax) :=
∃ σ, α_conv rsm σ s₁ = s₂

@[simp] protected def except.passert {ε} : except ε Prop → Prop
| (except.ok p)    := p
| (except.error _) := true

@[simp] lemma except.passert_pure {ε p} : except.passert (pure p : except ε Prop) = p := rfl

section
open interactive
open interactive.types
open tactic
meta def tactic.interactive.simp_val (p : parse texpr) : tactic unit :=
do e ← i_to_expr_strict p,
   (e', _) ← conv.convert (conv.interactive.simp ff [] []) e,
   exact e'
end

namespace parse_m
variables {r σ α : Type} (cfg : r) (st : σ)

protected def run_cont {β} (x : parse_m r σ α) (cont : σ → α → except string β) : except string β :=
match parse_m.run cfg st x with
| (except.ok a, st)   := cont st a
| (except.error e, _) := except.error e
end

protected def passert_cont (x : parse_m r σ α) (cont : σ → α → Prop) : Prop :=
except.passert $ parse_m.run_cont cfg st x $ λ st a, pure (cont st a)

protected def passert (x : parse_m r σ Prop) : Prop :=
parse_m.passert_cont cfg st x (λ st, id)

variables {cfg} {st}
variables {β γ : Type} (p : σ → β → except string γ)
variables (q : σ → α → except string β)

local attribute [simp] parse_m.run_cont parse_m.run
attribute [reducible] parse_m
attribute [reducible]
  parse_m.monad_run except_t.monad_run state_t.monad_run reader_t.monad_run id.monad_run

variable (x : parse_m r σ α)

@[simp] lemma run_cont_pure (a : α) : parse_m.run_cont cfg st (pure a) q = q st a := rfl

@[simp] lemma run_cont_bind (f : α → parse_m r σ β) :
  parse_m.run_cont cfg st (x >>= f) p =
  parse_m.run_cont cfg st x (λ st' a, parse_m.run_cont cfg st' (f a) p) :=
by simp; cases (by simp_val parse_m.run cfg st x); cases fst; simp [except_t.bind_cont]

@[simp] lemma run_cont_map (f : α → β) :
  parse_m.run_cont cfg st (f <$> x) p =
  parse_m.run_cont cfg st x (λ st' a, p st' (f a)) :=
by simp; cases (by simp_val parse_m.run cfg st x); cases fst; simp [except.map]

@[simp] lemma run_cont_adapt_state {σ' σ''} (f : σ → σ' × σ'') (f') (x : parse_m r σ' α) :
  parse_m.run_cont cfg st (adapt_state f f' x) q =
    let (st',st'') := f st in parse_m.run_cont cfg st' x (λ st', q (f' st' st'')) :=
by cases h : f st with st' st''; simp [adapt_state]; rw [h]; simp; cases (by simp_val parse_m.run cfg st' x); cases fst; simp

@[simp] lemma run_cont_put (p : σ → punit → except string γ) (st') :
  parse_m.run_cont cfg st (put st') p = p st' punit.star :=
by simp [put, monad_state.lift]

@[simp] lemma run_cont_read (p : σ → r → except string γ) :
  parse_m.run_cont cfg st read p = p st cfg :=
by simp [read]

@[simp] lemma run_cont_throw (e) (p : σ → α → except string γ) :
  parse_m.run_cont cfg st (throw e) p = except.error e :=
by simp [throw]

lemma passert_mp {p : parse_m r σ α} {s₀ : σ} {post₁ post₂ : σ → α → except string Prop} :
  except.passert (parse_m.run_cont cfg s₀ p post₁) → (∀ s a, except.passert (post₁ s a) → except.passert (post₂ s a)) → except.passert (parse_m.run_cont cfg s₀ p post₂) :=
begin
  simp,
  intros hpost₁ hmp,
  cases (by simp_val parse_m.run cfg s₀ p); cases fst; simp [parse_m.run_cont] at *,
  apply hmp _ _ hpost₁
end

@[simp] lemma passert_invariant {p : parse_m r σ α} {s₀ : σ} {post : except string Prop} :
  except.passert post → except.passert (parse_m.run_cont cfg s₀ p (λ _ _, post)) :=
begin
  simp,
  cases (by simp_val parse_m.run cfg s₀ p); cases fst; simp [parse_m.run_cont] at *,
  exact id
end

end parse_m

theorem hygienic (s₁ s₂ : syntax) (st : parse_state) :
parse_m.passert st () $
do s₁' ← expand' s₁,
   s₂' ← expand' s₂,
   (_, rst) ← resolve' s₁',
   pure $ α_equiv rst.resolve_map s₁ s₂ → α_equiv rst.resolve_map s₁' s₂' := sorry

lemma expand_idem (s : syntax) (cfg : parse_state) :
parse_m.passert cfg () $
do s' ← expand' s,
   s'' ← expand' s',
   pure $ s'' = s' :=
begin
  -- generalize states (irrelevant) and step counts
  suffices : ∀ st steps steps₂, steps ≤ steps₂ →
(parse_m.passert_cont cfg st (expand steps s) $ λ _ s',
 ∀ st₂, parse_m.passert_cont cfg st₂ (expand steps₂ s') $ λ _ s'',
 s'' = s'),
  { simp [parse_m.passert, parse_m.passert_cont, expand'] at *,
    apply parse_m.passert_mp, apply this, apply le_refl,
    intros st' s' x, apply x },
  simp [parse_m.passert_cont],
  intros st steps steps₂,
  induction steps with steps generalizing s st steps₂,
  -- `expand s` out of steps: trivial
  { intros; simp [expand] },
  { intro hsteps₂,
    -- `expand s'` can do at least one step as well
    cases steps₂ with steps₂, { exfalso, apply nat.not_succ_le_zero _ hsteps₂ },
    -- recursive case 1: holds when expanding all children (when s is not a macro)
    have expand_mmap : ∀ (val : syntax_node syntax),
      parse_m.passert_cont cfg st (mmap (expand steps) (val.args)) $ λ _ args',
      ∀ st₂, parse_m.passert_cont cfg st₂ (mmap (expand steps₂) args') $ λ _ args'',
        args'' = args',
    begin
        intro,
        simp [parse_m.passert_cont] at *,
        induction val.args generalizing st; simp [mmap],
        case list.cons {
          apply parse_m.passert_mp (steps_ih _ st _ (nat.le_of_succ_le_succ hsteps₂)), intros st' s' expand_s',
          clear steps_ih,
          apply parse_m.passert_mp (ih st'), intros st'' args' mmap_args' st₂,
          clear ih,
          apply parse_m.passert_mp (expand_s' _), intros st''' s''' h,
          apply parse_m.passert_mp (mmap_args' _), intros st'''' args this,
          simp * at *,
        }
    end,
    cases hs : s; simp [expand],
    --TODO `case` for ginductives
    --case syntax.node n {
    { cases h : rbmap.find cfg.macros val.m with m,
      case none { simp [expand, h], apply expand_mmap },
      case some {
        cases m, cases m_expand,
        case none { simp [expand, h], apply expand_mmap },
        case some {
          -- recursive case 1: re-expand the expansion of s. `expand s` will do one more step than `expand s'`.
          -- `mk_tag` is so simple that `simp` can automatically transform it to its spec
          simp [expand, mk_tag],
          apply parse_m.passert_mp (steps_ih _ _ _ (nat.le_of_succ_le hsteps₂)), intros st' s' expand_s',
          apply expand_s',
        },
      }
    }
  }
end


example (M : Type → Type) [Monad M] : ExceptT Unit (ReaderT Unit (StateT Unit M)) Unit := do
let ctx ← read;
pure ()


import Lbar.ext_aux2
import Lbar.iota

noncomputable theory

universes v u u'

open opposite category_theory category_theory.limits category_theory.preadditive
open_locale nnreal zero_object

variables (r r' : ℝ≥0)
variables [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r < 1)] [fact (r' < 1)]

open bounded_homotopy_category

variables {r'}
variables (BD : breen_deligne.package)
variables (κ κ₂ : ℝ≥0 → ℕ → ℝ≥0)
variables [∀ (c : ℝ≥0), BD.data.suitable (κ c)] [∀ n, fact (monotone (function.swap κ n))]
variables [∀ (c : ℝ≥0), BD.data.suitable (κ₂ c)] [∀ n, fact (monotone (function.swap κ₂ n))]
variables (M : ProFiltPseuNormGrpWithTinv₁.{u} r')

section preps

variables (V : SemiNormedGroup.{u}) [complete_space V] [separated_space V]
variables (ι : ulift.{u+1} ℕ → ℝ≥0) (hι : monotone ι)

set_option pp.universes true

lemma cofan_point_iso_colimit_conj_eq_desc
  {e : (homotopy_category.colimit_cofan
     (λ (a : ulift ℕ), ((λ (k : ulift ℕ),
     (QprimeFP r' BD.data κ₂ M).obj (ι k)) a).val)).X.is_bounded_above} :
  (cofan_point_iso_colimit
    (λ (k : ulift ℕ), (QprimeFP r' BD.data κ₂ M).obj (ι k))).inv ≫
  of_hom (sigma_shift ι hι (QprimeFP_int r' BD.data κ₂ M)) ≫
    (cofan_point_iso_colimit (λ (k : ulift ℕ),
    (QprimeFP r' BD.data κ₂ M).obj (ι k))).hom =
  begin
    apply sigma.desc,
    intros k,
    refine _ ≫ sigma.ι _ (ulift.up $ ulift.down k + 1),
    refine (QprimeFP r' BD.data κ₂ M).map _,
    refine hom_of_le (hι _),
    exact_mod_cast k.down.le_succ,
  end :=
begin
  ext j,
  dsimp only [cofan_point_iso_colimit],
  rw [colimit.ι_desc, cofan.mk_ι_app,
      colimit.comp_cocone_point_unique_up_to_iso_inv_assoc],
  simp only [← category.assoc], rw [← iso.eq_comp_inv], simp only [category.assoc],
  rw [colimit.comp_cocone_point_unique_up_to_iso_inv],
  dsimp only [sigma_shift, bounded_homotopy_category.cofan, cofan.mk_ι_app,
    of_hom, homotopy_category.colimit_cofan],
  erw [← functor.map_comp, colimit.ι_desc],
  dsimp only [sigma_shift_cone, discrete.nat_trans_app],
  refine functor.map_comp _ _ _,
end

def pi_Ext_iso_Ext_sigma (i : ℤ) :
  (∏ λ (k : ulift ℕ), ((QprimeFP r' BD.data κ₂ M).op ⋙
    (Ext i).flip.obj ((single (Condensed Ab) 0).obj V.to_Cond)).obj (op (ι k))) ≅
  ((Ext i).obj (op (of' (∐ λ (k : ulift ℕ), (QprimeFP_int r' BD.data κ₂ M).obj (ι k))))).obj
    ((single (Condensed Ab) 0).obj (Condensed.of_top_ab ↥V)) :=
(Ext_coproduct_iso
  (λ k : ulift ℕ, (QprimeFP r' BD.data κ₂ M).obj (ι k)) i
  ((single (Condensed Ab) 0).obj V.to_Cond)).symm ≪≫
  ((Ext i).flip.obj ((single (Condensed Ab) 0).obj V.to_Cond)).map_iso
begin
  refine iso.op (cofan_point_iso_colimit
    (λ (k : ulift ℕ), (QprimeFP r' BD.data κ₂ M).obj (ι k)))
end

-- move me
@[simp] lemma _root_.category_theory.op_nsmul
  {C : Type*} [category C] [preadditive C] {X Y : C} (n : ℕ) (f : X ⟶ Y) :
  (n • f).op = n • f.op := rfl

-- move me
@[simp] lemma _root_.category_theory.op_sub
  {C : Type*} [category C] [preadditive C] {X Y : C} (f g : X ⟶ Y) :
  (f - g).op = f.op - g.op := rfl

@[simp] lemma _root_.homological_complex.of_hom_sub
  {C : Type*} [category C] [abelian C]
  (X Y : homological_complex C (complex_shape.up ℤ)) (f g : X ⟶ Y)
  [((homotopy_category.quotient C (complex_shape.up ℤ)).obj X).is_bounded_above]
  [((homotopy_category.quotient C (complex_shape.up ℤ)).obj Y).is_bounded_above] :
  of_hom (f - g) = of_hom f - of_hom g := rfl

@[reassoc]
lemma Ext_coproduct_iso_naturality_inv
  (A : Type u)
  [category.{v} A]
  [abelian A]
  [enough_projectives A]
  [has_coproducts.{v} A]
  [AB4 A]
  {α : Type v}
  (X₁ X₂ : α → bounded_homotopy_category A)
  [uniformly_bounded X₁]
  [uniformly_bounded X₂]
  (g : X₁ ⟶ X₂)
  (i : ℤ) (Y) :
  (Ext_coproduct_iso _ _ _).inv ≫
  ((Ext i).map (sigma.desc (λ b, g b ≫ sigma.ι X₂ b) : ∐ X₁ ⟶ ∐ X₂).op).app Y =
  pi.lift (λ b, pi.π _ b ≫ ((Ext i).map (g b).op).app Y) ≫ (Ext_coproduct_iso _ _ _).inv :=
begin
  rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv],
  apply Ext_coproduct_iso_naturality,
end

end preps


structure Var : Type := (name : String)
instance Var.nameCoe : HasCoe String Var := ⟨Var.mk⟩

structure A : Type := (u : Unit)
structure B : Type := (u : Unit)

def a : A := A.mk ()
def b : B := B.mk ()

def Foo.chalk : A → List Var → Unit := λ _ _ => ()
def Bar.chalk : B → Unit := λ _ => ()

open Foo
open Bar

instance listCoe {α β} [HasCoe α β] : HasCoe (List α) (List β) :=
⟨fun as => as.map coe⟩

/- The following succeeds: -/
#check Foo.chalk a ["foo"] -- succeeds

/-
The following application fails, due to a curious interaction
between coercions and ad-hoc overloading.
-/
#check chalk a ["foo"] -- fails

/-
Note that the first argument clearly distinguishes the two
`chalk` applications, and there are no coercions in play for the first argument.

I am not arguing that we should support this case, merely logging that it surprised me,
and that I can not employ an otherwise desirable use of overloading because of it.

Note: it works if `Foo.chalk` takes `A` and `Var` and we pass `a` and `"foo"`.
-/

/-

Here is the analysis of why it doesn't work.
Given `chalk a ["foo"]` where `chalk` is overloaded,
the current elaborator performs the following steps:

1- Elaborate the arguments `a` and `["foo"]` without an expected
type. Thus, `["foo"]` is elaborated as a list of strings.

2- For each possible interpretation of `chalk`, we try to match the
arguments with the expected types. `Bar.chalk` fails because there is
no coercion from `A` to `B`. `Foo.chalk` fails because there is no
coercion from `List String` to `List Var`. Note that the example would
work if we had the coercion

```
instance listCoe {α β} [HasCoe α β] : HasCoe (List α) (List β) :=
⟨fun as => as.map coe⟩
```
However, users could still be surprised by the fact that the `chalk a ["foo"]` is
elaborated as `Foo.chalk a (coe ["foo"])` instead of `Foo.chalk a [coe "foo"]`.

Here are some alternative elaboration strategies I have considered.
We should discuss them in the next Dev meeting.

1- Instead of elaborating all arguments without an expected type, we
elaborate only the shortest argument prefix that is sufficient for
selecting the right overload candidate. Daniel's comments above
suggest this is the strategy he expected. It would fix this particular
instance, but it would still confuse users. For example, we can create
the alternative problem `chalk ["foo"] a`. Users could say "the second
argument clearly distinguishes the two applications."

2- Elaborate `chalk a ["foo"]` for each possible overload.  This is a
robust solution but may produce an exponential blowup. For example,
suppose we have `f_1 (f_2 (f_3 (f_4 ... (f_n a) ... )))` where all
`f_i` are overloaded. Moreover, every overload has the same result
type. Thus, we cannot prune the search space using the expected
type. This situation does not seem to occur in our code base.  It did
happen in Lean2, when we used to overload symbols such as `+` and `*`.
We should ask Reid how often overloads are used in mathlib, and
whether the exponential blowup is a real problem or not for them.

3- Use Lean3 approach, but when we get a typing error after we
selected the right overload candidate, we re-elaborate it using the
expected type instead of failing. This approach looks too haskish, and
it may still produce an exponential blowup.

I am inclined to (try to) use solution 2 in Lean4. We can have a
threshold on the amount of backtracking, and when it exceeds we
produce an error message stating all overloads that are generating
the huge search space.
-/