-- Author(s): Andrés Goens
-- See Copyright Notice in LICENSE

import Pop.Util
open Util Std.HashMap

namespace Pop

def RequestId := Nat deriving ToString, BEq, Inhabited, Hashable
def Value := Option Nat deriving ToString, BEq, Inhabited
def Address := Nat deriving ToString, BEq, Inhabited
def ThreadId := Nat deriving Ord, LT, LE, ToString, Inhabited, Hashable, DecidableEq
inductive ConditionalValue
  | const : Nat → ConditionalValue
  | tentative : Nat → ConditionalValue
  --| transaction : Nat → ConditionalValue
  | fetchAndAdd : ConditionalValue
  | failed : ConditionalValue
  deriving BEq, Inhabited

def ConditionalValue.update : ConditionalValue → Value → ConditionalValue
  | c@(.const v), some v' => if v == v' then c else .failed
  | c@(.tentative v), some v' => if v == v' then c else .failed
  | (.const _), none => .failed
  | (.tentative _), none => .failed
  | .failed , _ => .failed
  | .fetchAndAdd, some v => .tentative (v + 1)
  | .fetchAndAdd, none => .failed

def ConditionalValue.validate : ConditionalValue → ConditionalValue
  | .tentative v => .const v
  | c => c

def RequestId.toNat : RequestId → Nat := λ x => x
def ThreadId.toNat : ThreadId → Nat := λ x => x
def RequestId.ofNat : Nat → RequestId := λ x => x
def ThreadId.ofNat : Nat → ThreadId := λ x => x
def Address.ofNat : Nat → Address := λ x => x
def Value.ofNat : Nat → Value := λ x => some x
def Value.ofOptionNat : Option Nat → Value := λ x => x

instance : OfNat ThreadId n where  ofNat := ThreadId.ofNat n
instance : OfNat RequestId n where  ofNat := RequestId.ofNat n
instance : OfNat Address n where ofNat := Address.ofNat n
instance : OfNat Value n where ofNat := Value.ofNat n
instance : Coe RequestId Nat where coe := RequestId.toNat

instance : BEq ThreadId := @instBEq ThreadId instThreadIdDecidableEq
instance : Lean.Quote ThreadId where quote := λ n => Lean.quote (ThreadId.toNat n)
instance : ToString ConditionalValue where toString
  | .const n => s!"{n}"
  | .tentative n => s!"{n}?"
  | .fetchAndAdd => s!"(n+1)"
  | .failed => "FAILED"

instance : LawfulBEq ThreadId := inferInstance
instance : LawfulBEq (List ThreadId) := inferInstance

def Address.prettyPrint (addr : Address) : String :=
  match (OfNat.ofNat addr) with
    | 0 => s!"x"
    | 1 => s!"y"
    | 2 => s!"z"
    | 3 => s!"w"
    | addr => s!"v{addr}"

inductive BlockingKinds
  | Read2ReadPred
  | Read2ReadNoPred
  | Read2WritePred
  | Read2WriteNoPred
  | Write2Read
  | Write2Write
  deriving BEq

abbrev BlockingSemantics := List BlockingKinds

def BlockingKinds.toString : BlockingKinds → String
  | .Read2ReadPred => "R → R (P)"
  | .Read2ReadNoPred => "R → R (NP)"
  | .Read2WritePred => "R → W (P)"
  | .Read2WriteNoPred => "R → W (NP)"
  | .Write2Read => "W → R"
  | .Write2Write => "W → W"

instance : ToString BlockingKinds where toString := BlockingKinds.toString

class ArchReq where
  (type : Type 0)
  (instBEq : BEq type)
  (instInhabited : Inhabited type)
  (instToString : ToString type)
  (prettyPrint : type → String := instToString.toString)
  (isPermanentRead : type → Bool := λ _ => false)

variable [ArchReq]

inductive Atomicity where
  | nonatomic : Atomicity
  | transactional : Atomicity
  | atomic : Atomicity
  deriving BEq, Inhabited

instance : ToString Atomicity where toString
  | .nonatomic => ""
  | .transactional => "t"
  | .atomic => "a"

structure ReadRequest where
 addr : Address
 reads_from : Option RequestId
 atomicity : Atomicity
 val : Value
 deriving BEq, Inhabited

structure WriteRequest where
 addr : Address
 val : ConditionalValue
 atomicity : Atomicity
 deriving BEq, Inhabited

instance : BEq ArchReq.type := ArchReq.instBEq
instance : Inhabited ArchReq.type := ArchReq.instInhabited
instance : ToString ArchReq.type := ArchReq.instToString

inductive BasicRequest
 | read : ReadRequest → ArchReq.type → BasicRequest
 | write : WriteRequest → ArchReq.type → BasicRequest
 | fence : ArchReq.type → BasicRequest
 deriving BEq

instance : Inhabited BasicRequest where default := BasicRequest.fence default

def BasicRequest.atomicity : BasicRequest → Atomicity
  | .read rr _ => rr.atomicity
  | .write wr _ => wr.atomicity
  | .fence _ => .nonatomic

def BasicRequest.toString : BasicRequest → String
  | BasicRequest.read  rr ty =>
    let tyStr := match s!"{ty}" with | "" => "" | str => s!". {str}"
    s!"R{rr.atomicity}{tyStr} {rr.addr.prettyPrint}" ++ match rr.val with | none => "" | some v => s!" // {v}"
  | BasicRequest.write  wr ty =>
    let tyStr := match s!"{ty}" with | "" => "" | str => s!". {str}"
    s!"W{wr.atomicity}{tyStr} {wr.addr.prettyPrint} {wr.val}"
  | BasicRequest.fence ty =>
    let tyStr := match s!"{ty}" with | "" => "" | str => s!". {str}"
    s!"Fence{tyStr}"

def BasicRequest.prettyPrint : BasicRequest → String
  | BasicRequest.read rr ty =>
    let valStr := match rr.val with
      | none => ""
      | some val => s!"({val})"
    let tyStr := match s!"{ArchReq.prettyPrint ty}" with
      | "" => ""
      | str => s!".{str}"
    s!"R{rr.atomicity}{tyStr} {rr.addr.prettyPrint}{valStr}"
  | BasicRequest.write  wr ty =>
    let tyStr := match s!"{ArchReq.prettyPrint ty}" with
      | "" => ""
      | str => s!".{str}"
    s!"W{wr.atomicity}{tyStr} {wr.addr.prettyPrint}({wr.val})"
  | BasicRequest.fence ty =>
    let tyStr := match s!"{ArchReq.prettyPrint ty}" with
      | "" => ""
      | str => s!".{str}"
    s!"Fence{tyStr}"

instance : ToString (BasicRequest) where toString := BasicRequest.toString

def BasicRequest.type : BasicRequest → ArchReq.type
  | BasicRequest.read  _ t => t
  | BasicRequest.write  _ t => t
  | BasicRequest.fence t => t

def BasicRequest.readRequest? : BasicRequest → Option ReadRequest
  | BasicRequest.read  rr _ => some rr
  | BasicRequest.write  _ _ => none
  | BasicRequest.fence _ => none

def BasicRequest.writeRequest? : BasicRequest → Option WriteRequest
  | BasicRequest.read  _ _ => none
  | BasicRequest.write  wr _ => some wr
  | BasicRequest.fence _ => none

def BasicRequest.updateType : BasicRequest → (ArchReq.type → ArchReq.type) → BasicRequest
  | .read  rr t, f => .read rr (f t)
  | .write  wr t, f => .write wr (f t)
  | .fence t, f => .fence (f t)

def BasicRequest.setValue : BasicRequest → Value → BasicRequest
  | BasicRequest.read rr rt, v => BasicRequest.read {rr with val := v} rt
  | br, _ => br

def BasicRequest.updateValue : BasicRequest → Value → BasicRequest
  | BasicRequest.write wr rt, v => BasicRequest.write {wr with val := wr.val.update v} rt
  | br, _ => br

def BasicRequest.validateWrite : BasicRequest → BasicRequest
  | BasicRequest.write wr rt => BasicRequest.write {wr with val := wr.val.validate} rt
  | br => br

def BasicRequest.value? : BasicRequest → Value
  | BasicRequest.read rr _ => rr.val
  | BasicRequest.write wr _ => match wr.val with
    | .const n => some n
    | .tentative n => some n
    |  _ => none
  | _ => none

def BasicRequest.conditionalValue? : BasicRequest → Option ConditionalValue
  | .write wr _ => some wr.val
  | _ => none

structure ValidScopes where
  system_scope : List ThreadId
  scopes : ListTree ThreadId
  --scopes_consistent : ∀ s, scopes.elem s → s.sublist system_scope
  --system_scope_is_scope : system_scope ∈ scopes

def ValidScopes.default : ValidScopes :=
    { system_scope := [], scopes := ListTree.leaf [],
     -- scopes_consistent :=
     --     (by
     --      intros s h
     --      simp [ListTree.elem] at h
     --      rw [h]
     --      simp),
     -- system_scope_is_scope :=
     --     (by simp [ (· ∈ ·) ])
    }

instance : Inhabited ValidScopes where default := ValidScopes.default

def ValidScopes.toStringHet (threadType : Option (ThreadId → String)) (scopes : ValidScopes) : String :=
  let scopeFun := match threadType with
    | none => λ _ => ""
    | some f => λ ss =>
       let labs := removeDuplicates $ List.map f ss
       if labs == ["default"] || labs == [] then "" else
       if labs.length == 1 then labs.head! else
       String.intercalate "+" labs
  let scopeLab := λ s : List ThreadId => if s.isEmpty then "" else toString s ++ scopeFun s
  "{" ++ String.intercalate ", " (scopes.scopes.toList.map scopeLab) ++ "}"

def ValidScopes.toString (scopes : ValidScopes) : String := scopes.toStringHet none
instance : ToString ValidScopes where toString := ValidScopes.toString

open Lean in
private def quoteValidScopes : ValidScopes → Term
  | ValidScopes.mk system_scope scopes /-consistent system_is_scope-/ => Syntax.mkCApp ``ValidScopes.mk #[quote system_scope, quote scopes] -- , sorry, sorry]
instance : Lean.Quote ValidScopes where quote := quoteValidScopes

structure Scope {V : ValidScopes} where
  threads : List ThreadId
  valid : threads ∈ V.scopes

instance {V : ValidScopes} : ToString (@Scope V) where toString := λ ⟨threads,_⟩ => s!"{threads}"

instance {V : ValidScopes} : BEq (@Scope V) where
  beq := λ scope₁ scope₂ => scope₁.threads == scope₂.threads

instance {V : ValidScopes} : BEq (@Scope V) where
  beq := λ scope₁ scope₂ => scope₁.threads == scope₂.threads

instance {V : ValidScopes} : LE (@Scope V) where
  le := λ scope₁ scope₂ => List.sublist scope₁.threads scope₂.threads

structure Request where
  id : RequestId
  propagated_to : List ThreadId
  predecessor_at : List ThreadId
  thread : ThreadId
  basic_type : BasicRequest
  occurrence : Nat
  pairedRequest? : Option RequestId
  -- scope : Scope
  -- type : α
  deriving BEq

def Request.default : Request :=
  {id := 0, propagated_to := [], predecessor_at := [], thread := 0,
   occurrence := 0, basic_type := BasicRequest.fence Inhabited.default, pairedRequest? := none}
instance : Inhabited (Request) where default := Request.default

def Request.toString : Request → String
  | req => s!" Request {req.id} {req.basic_type.prettyPrint} : [propagated to {req.propagated_to}, origin thread : {req.thread}, pred. at : {req.predecessor_at}]"
instance : ToString (Request) where toString := Request.toString

def Request.toShortString : Request → String
  | req => s!"{req.id}[{req.basic_type.toString}]"

def BasicRequest.isRead    (r : BasicRequest) : Bool := match r with | read  _ _ => true | _ => false
def BasicRequest.isWrite   (r : BasicRequest) : Bool := match r with | write _ _ => true | _ => false
def BasicRequest.isFence (r : BasicRequest) : Bool := match r with | fence _ => true | _ => false

def BasicRequest.isAtomic (r : BasicRequest) : Bool := match r with | .read rr _ => rr.atomicity == .atomic | .write wr _ => wr.atomicity == .atomic | .fence _ => false
def BasicRequest.isTransactional (r : BasicRequest) : Bool := match r with | .read rr _ => rr.atomicity == .transactional | .write wr _ => wr.atomicity == .transactional | .fence _ => false
def Request.isRead    (r : Request) : Bool := r.basic_type.isRead
def Request.isWrite   (r : Request) : Bool := r.basic_type.isWrite
def Request.isFence (r : Request) : Bool := r.basic_type.isFence
def Request.isMem     (r : Request) : Bool := !r.basic_type.isFence
def Request.isPermanentRead (r : Request) : Bool := r.isRead && ArchReq.isPermanentRead r.basic_type.type

def Request.value? (r : Request) : Value := r.basic_type.value?
def Request.setValue (r : Request) (v : Value) : Request := { r with basic_type := r.basic_type.setValue v}
def Request.updateValue (r : Request) (v : Value) : Request :=
  { r with basic_type := r.basic_type.updateValue v}
def Request.validateWrite (r : Request) : Request := { r with basic_type := r.basic_type.validateWrite}
def Request.isSatisfied (r : Request) : Bool := match r.basic_type with
  | .read rr _ => rr.val.isSome
  | _ => false

def Request.isAtomic (r : Request) : Bool := r.basic_type.isAtomic
def Request.isTransactional (r : Request) : Bool := r.basic_type.isTransactional

def BasicRequest.address? (r : BasicRequest) : Option Address := match r with
  | read  req _ => some req.addr
  | write req _ => some req.addr
  | _ => none

def Request.address? (r : Request) : Option Address := r.basic_type.address?

def Request.equivalent (r₁ r₂ : Request) : Bool :=
  if r₁.isFence then r₁.basic_type == r₂.basic_type
  else r₁.address? == r₂.address? && r₁.value? == r₂.value? && r₁.thread == r₂.thread &&
       ((r₁.isWrite && r₂.isWrite) || (r₁.isRead && r₂.isRead))

-- Read, Write
def SatisfiedRead := RequestId × RequestId deriving ToString, BEq

--instance [BEq α] : Membership (List α) (ListTree α) where
--  mem lst tree := tree.elem lst = true

def decideThreadsValid (threads : List ThreadId) (V : ValidScopes) : Decidable (threads ∈ V.scopes) :=
  if h : V.scopes.elem threads then
    Decidable.isTrue h
  else
    Decidable.isFalse h

instance {threads : List ThreadId} {V : ValidScopes} : Decidable (threads ∈ V.scopes) := decideThreadsValid threads V

def ValidScopes.validate (V : ValidScopes) (threads : List ThreadId) : Option (@Scope V) :=
    if h : threads ∈ V.scopes then
        some { threads := threads, valid := h }
    else
        none

-- Gives the subscopes of S, including S.
def ValidScopes.subscopes (V : ValidScopes) (S : @Scope V) : List (@Scope V) :=
  let children := V.scopes.nodesBelow S.threads
  filterNones $ children.map V.validate

def ValidScopes.containThread (V: ValidScopes) (t : ThreadId) : List (@Scope V) :=
  let containing := V.scopes.nodesAbove [t]
  filterNones $ containing.map V.validate

def ValidScopes.systemScope {V : ValidScopes } : @Scope V :=
  {threads := V.system_scope, valid := sorry} -- V.system_scope_is_scope}

instance {V : ValidScopes} : Inhabited (@Scope V) where
 default := V.systemScope

def ValidScopes.isUnscoped (V : ValidScopes) : Bool :=
  V.scopes == (ListTree.leaf V.system_scope)

def ValidScopes.jointScope : (V : ValidScopes) → ThreadId → ThreadId → (@Scope V)
 | valid, t₁, t₂ => match valid.scopes.meet t₁ t₂ with
   | some scope => {threads := scope, valid := sorry}
   | none => panic! s!"can't find the joint scope of {t₁} and {t₂} in {valid.scopes}"-- can we get rid of this case distinction?

def ValidScopes.reqThreadScope (V : ValidScopes ) (req : Request) : (@Scope V) :=
   V.jointScope req.thread req.thread

def ValidScopes.intersection : (V : ValidScopes) → @Scope V → @Scope V → Option (@Scope V)
  | V, s1, s2 => V.validate $ s1.threads.intersection s2.threads

def Request.propagatedTo (r : Request) (t : ThreadId) : Bool := r.propagated_to.elem t

def Request.fullyPropagated {V : ValidScopes}  (r : Request) (s : optParam (@Scope V) V.systemScope) : Bool :=
  let propToList := s.threads.map (λ t => Request.propagatedTo r t)
  propToList.foldl (init:= true) (. && .)

def Request.isPredecessorAt (req : Request) (thId : ThreadId) : Bool :=
  req.predecessor_at.contains thId

def Request.makePredecessorAt (req : Request) (thId : ThreadId) : Request :=
  if req.isPredecessorAt thId then req else { req with predecessor_at := thId :: req.predecessor_at}

/-
 We have scoped order constraints, i.e. a different set of order constraints
 for each scope. Order constraints specify a partial order on requests, and
 we represent them with a Bool value for a pair of (r₁,r₂) : RequestId × RequestId,
 which is true ↔ there is an order constraint r₁ →s r₂, for the scope s.

 However, we have a property (by construction) that if s' ≤ s and r₁ →s r₂, then
 also r₁ →s' r₂. Can we use this to find a more compact representation?
-/
structure OrderConstraints {V : ValidScopes} where
  val : Std.HashMap (List ThreadId) (Std.HashMap (RequestId × RequestId) Bool)
  default : Bool

def OrderConstraints.empty {V : ValidScopes} (numReqs : optParam Nat 10) : @OrderConstraints V :=
 let scopes := V.scopes.toList
 { default := false, val :=
 Std.mkHashMap (capacity := scopes.length) |> scopes.foldl λ acc s => acc.insert s (Std.mkHashMap (capacity := numReqs))
 }

-- TODO: make scope an optional parameter and just do the intersection by default?
-- Would need to move around things in Arch typeclass...
def OrderConstraints.lookup {V : ValidScopes} (ordc : @OrderConstraints V)
  (S : @Scope V) (req₁ req₂ : RequestId) : Bool :=
  let sc_ordc := ordc.val.find? S.threads
  match sc_ordc with
    | none => ordc.default
    | some hashmap =>
      hashmap.findD (req₁, req₂) ordc.default

def OrderConstraints.predecessors {V : ValidScopes} (S : @Scope V) (req : RequestId)
    (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
    let sc_oc := constraints.lookup S -- hope this gets optimized accordingly...
    reqs.filter (λ x => sc_oc x req)

def OrderConstraints.successors {V : ValidScopes} (S : @Scope V) (req : RequestId)
  (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
  let sc_oc := constraints.lookup S -- hope this gets optimized accordingly...
  reqs.filter (λ x => sc_oc req x)

 def OrderConstraints.transitiveSuccessors {V : ValidScopes} (S : @Scope V) (req : RequestId)
   (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
   let sc_oc := constraints.lookup S
   Id.run do
     let mut succ := []
     let mut succ' := [req]
     while succ != succ' do
       succ := succ'
       succ' := reqs.filter
         λ x => succ'.any
           λ s => x == s || sc_oc s x
     return succ'

def OrderConstraints.between {V : ValidScopes} (S : @Scope V) (req₁ req₂ : RequestId)
  (reqs : List RequestId) (constraints : @OrderConstraints V)  : List RequestId :=
  let preds₁ := constraints.predecessors S req₁ reqs
  let preds₂ := constraints.predecessors S req₂ reqs
  preds₂.removeAll (req₁::preds₁)

-- TODO: is this really a quasi top sort?
def OrderConstraints.qtopSort {V : ValidScopes} (S : @Scope V)
  (reqs : List Request) (constraints : @OrderConstraints V)  : List Request :=
  reqs.toArray.qsort (λ r₁ r₂ => constraints.lookup S r₁.id r₂.id) |>.toList

/-
def SystemState.betweenRequests (state : SystemState) (req₁ req₂ : Request) : List Request :=
  let betweenIds := state.orderConstraints.between
    req₁.id req₂.id (reqIds state.requests)
  state.idsToReqs betweenIds
  -/

def OrderConstraints.compare {V₁ V₂ : ValidScopes} ( oc₁ : @OrderConstraints V₁) (oc₂ : @OrderConstraints V₂)
  (requests : List RequestId) : Bool :=
  if V₁.scopes.toList != V₂.scopes.toList
    then false
    else
      let scopes₁ := V₁.scopes.toList.map V₁.validate
      let scopes₂ := V₂.scopes.toList.map V₂.validate
      let scopes := scopes₁.zip scopes₂ -- pretty hacky: should get types to match
      let reqPairs := List.join $ requests.map λ r₁ => requests.foldl (init := []) λ reqs r₂ => (r₁,r₂)::reqs
      let keys := List.join $ scopes.map λ s => reqPairs.foldl (init := []) λ ks (r₁,r₂) => (s,r₁,r₂)::ks
      keys.all λ (s,r₁,r₂) => match s with
        | (some s₁, some s₂) => (oc₁.lookup s₁ r₁ r₂ == oc₂.lookup s₂ r₁ r₂)
        | _ => panic! s!"invalid scopes {scopes₁} or {scopes₂}"

def OrderConstraints.addSingleScope {V : ValidScopes} (constraints : @OrderConstraints V)
  (scope : @Scope V) (reqs : List (RequestId × RequestId)) (val := true) : @OrderConstraints V :=
  match constraints.val.find? scope.threads with
   | none => constraints
   | some sc_oc =>
       let sc_oc' := reqs.foldl (init := sc_oc) λ oc req => oc.insert req val
       let val' := constraints.val.insert scope.threads sc_oc'
       { constraints with val := val' }

-- Updates `constraints` to add all pairs in `reqs` to the scope `scope` and each
-- of its suscopes. The optional value `val` is what the constraint is updated to,
-- and defaults to `true`.
def OrderConstraints.addSubscopes {V : ValidScopes} (constraints : @OrderConstraints V)
(scope : @Scope V) (reqs : List (RequestId × RequestId)) (val := true) : @OrderConstraints V :=
  let subscopes := V.subscopes scope
  --dbg_trace s!"{scope.threads}.subscopes: {subscopes.map λ s => s.threads}"
  subscopes.foldl (init := constraints) λ oc sc => oc.addSingleScope sc reqs (val := val)

def OrderConstraints.swap {V : ValidScopes} (oc : @OrderConstraints V)
  (scope : @Scope V) (req₁ req₂ : RequestId) : @OrderConstraints V :=
  let c₁₂ := oc.lookup scope req₁ req₂
  let c₂₁ := oc.lookup scope req₂ req₁
  Id.run do
    if c₁₂ == c₂₁ then
      panic! "cycle {req₁.id} ↔ {req₂.id} detected in order constraints."
    let mut add := []
    let mut remove := []
    if c₁₂ then
      add :=( req₂,req₁) :: add
      remove :=( req₁,req₂) :: remove
    if c₂₁ then
      add :=( req₁,req₂) :: add
      remove :=( req₂,req₁) :: remove
    let mut oc' := oc
    oc' := oc'.addSubscopes scope add
    oc' := oc'.addSubscopes scope remove (val := false)
    return oc'

def OrderConstraints.groupsToString : List Request → List Request → String
  | [],_ => ""
  | _,[] => ""
  | reqs₁, reqs₂ =>
    let vars₁ := removeDuplicates $ reqs₁  |>.map Request.address?
    let vars₂ := removeDuplicates $ reqs₂  |>.map Request.address?
    let vars := vars₁.filter vars₂.contains
    let colorFun := λ r => if vars.contains r.address? && r.address?.isSome then
      colorString Color.magenta r.toShortString else r.toShortString
    let (r₁strings, r₂strings) := (reqs₁.map colorFun, reqs₂.map colorFun)
    "{" ++ (String.intercalate ", " $ r₁strings) ++
                    "} → {" ++ (String.intercalate ", " $ r₂strings) ++ "}"

def OrderConstraints.toString {V : ValidScopes} (constraints : @OrderConstraints V) (scope : @Scope V) (reqs : List Request) : String := Id.run do
   let reqsSorted := constraints.qtopSort scope reqs
   let mut pairs := []
   for req in reqsSorted do
     let deps := reqsSorted.filter λ req' => constraints.lookup scope req.id req'.id
       if deps.isEmpty then
         continue
       pairs := pairs ++ [ (req,deps) ]
   let mut res : List (List Request × List Request) := []
   for (req,deps) in pairs do
     if res.any λ (lhs,_) => lhs.contains req then
       continue
     let mut lhs := [req]
     for req' in reqsSorted do
       if req' == req then
         continue
       if pairs.lookup req' == some deps then
         lhs := req'::lhs
     res := res ++ [(lhs,deps)]
   String.intercalate ";   " $ res.map λ (lhs,rhs) => OrderConstraints.groupsToString lhs rhs

private def opReqId? : Option (Request) → Option RequestId := Option.map λ r => r.id

private def valConsistent (vals :  Array (Option (Request))) : Bool :=
  let valOpIds := vals.map opReqId?
  let valConsistent := λ idx opVal => match opVal with
    | none => true
    | some val => val == idx.val
  let consistentVals := valOpIds.mapIdx valConsistent
  consistentVals.foldl (. && .) true

structure RequestArray where
  val : Array (Option (Request))
  coherent : valConsistent val = true

instance : BEq (RequestArray) where beq := λ arr₁ arr₂ => arr₁.val == arr₂.val

def RequestArray.getReq? : RequestArray → RequestId → Option (Request)
  | arr, rId => match arr.val[rId.toNat]? with
    | some (some req) => some req
    | _ => none

def RequestArray.getReq! : RequestArray → RequestId → Request
  | arr, rId => arr.val[rId.toNat]?.get!.get!

def RequestArray.printReq : RequestArray → RequestId → String
  | arr, rId => match arr.getReq? rId with
    | none => ""
    | some r => r.toShortString

def RequestArray.seen : RequestArray → List RequestId
  | arr => List.range arr.val.size

def RequestArray.map {β : Type} : RequestArray → (Request → β) → Array β
 | rarr, f => filterNonesArr $ rarr.val.map λ opreq => Option.map f opreq
-- instance : GetElem RequestArray RequestId (Option Request) where getElem

theorem emptyArrayCoherent : valConsistent (Array.mk ([] : List (Option (Request)))) := by
  sorry -- metavariable screws up simp

def RequestArray.empty : RequestArray :=
  { val := Array.mk [], coherent := emptyArrayCoherent }

def RequestArray.toString : RequestArray → String
  | arr => String.intercalate ",\n" $ List.map Request.toString $ filterNones arr.val.toList

instance : ToString (RequestArray) where toString := RequestArray.toString

def RequestArray.filter : RequestArray → (Request → Bool) → List Request
  | ra, f =>
  let fOp : Option Request → Bool
    | some r => f r
    | none => false
  filterNones $ Array.toList $ ra.val.filter fOp

def RequestArray.prettyPrint (arr : RequestArray) (numThreads : Nat) (order : @OrderConstraints V) (colWidth := 25) (highlight : optParam (Option $ ThreadId × RequestId) none) : String := Id.run do
  let mut threads := []
  let mut res := ""
  for thId in (List.range numThreads) do
    if thId != 0 then
      res := res ++ "||"
    res := res ++ s!" T{thId}" ++ (String.mk $ List.replicate (colWidth - 3) ' ')
    let mut thread := []
    for req in arr.filter (λ r => !(r.isWrite && r.value? == some 0)) do
      if highlight == some (thId, req.id) then
        thread := thread ++ [(Color.yellow, req)]
      else if req.thread == thId then
        thread := thread ++ [(Color.cyan, req)]
      else if req.propagatedTo thId then
        thread := thread ++ [(Color.black, req)]
    threads := threads ++ [thread]
  res := res ++ "|\n" ++ (String.mk $ List.replicate (colWidth * numThreads + 2 * (numThreads - 1)) '-') ++ "\n"
  threads := threads.map
    (λ th => th.toArray.qsort
      (λ r₁ r₂ => order.lookup (V.jointScope r₁.2.thread r₂.2.thread) r₁.2.id r₂.2.id)
        |>.toList)
  while threads.any (!·.isEmpty) do
    let mut sep := false
    for thread in threads do
      if sep then
        res := res ++ "||"
      else
        sep := true
      res := res ++ match thread.head? with
        | none => (String.mk $ List.replicate colWidth ' ')
        | some (color,r) => " " ++ (colorString color r.toShortString) ++ (String.mk $ List.replicate (colWidth - r.toShortString.length - 1) ' ')
    res := res ++ "|\n"
    threads := threads.map List.tail
  return res

def reqIds : (RequestArray) → List RequestId
 | arr =>
   let opIds :=  Array.toList $ arr.val.map (Option.map Request.id)
   filterNones opIds

def growArray {α : Type} (a : Array (Option α)) (n : Nat) : Array (Option α) :=
  --dbg_trace s!"growing array of size {a.size} by {n}"
  a.append (Array.mkArray (a.size - n) none)

private def RequestArray._insert : RequestArray → Request → Array (Option (Request))
  | arr, req =>
    --dbg_trace "growing [{arr}] of size {arr.val.size} to {req.id.toNat + 1} for Request {req}"
    let vals' := growArray arr.val (req.id.toNat + 1)
    let i := req.id.toNat.toUSize
    if h : i.toNat < vals'.size
    then vals'.uset i (some req) h
    -- If we use `i.toNat == vals'.size` then Lean won't unfold the typeclass
    -- instance of BEq.beq (which is Nat.beq) and we can't use Nat.beq_eq.
    -- Maybe ask on Zulip?
    else if h: (Nat.beq i.toNat vals'.size) then
      let hless : i.toNat < vals'.size + 1 := by
        {apply Nat.lt_of_succ_le
         apply Nat.le_of_eq
         rw [Nat.succ_eq_add_one]
         rw [Nat.beq_eq] at h
         rw [h]
         }
      let idfin := Fin.mk i.toNat hless
      vals'.insertAt idfin (some req)
    else unreachable! -- because of growArray before

-- can't be proving these things right now
theorem RequestArrayInsertConsistent (arr : RequestArray) (req : Request) :
  valConsistent (arr._insert req) = true := by sorry
  -- unfold RequestArray._insert
  -- simp

def RequestArray.insertAtPosition : RequestArray → Option (Request) → USize → RequestArray
  | arr, opReq, i =>
    let val' := if h : i.toNat < arr.val.size
      then arr.val.uset i opReq h
      else match opReq with
        | some req => arr._insert req
        | none => arr.val
      -- RequestArrayInsertConsistent arr req
    { val := val', coherent := sorry}

-- Inserst request at the position given by its id.
-- Will overwrite another request with that same id.
def RequestArray.insert : RequestArray → Request → RequestArray
  | arr, req =>
    let i := req.id.toNat.toUSize
    arr.insertAtPosition (some req) i

def RequestArray.remove : RequestArray → RequestId → RequestArray
  | arr, reqId =>
  match arr.getReq? reqId with
    | none => arr
    | some req =>
      let i := req.id.toNat.toUSize
      arr.insertAtPosition none i

structure SystemState where
  requests : RequestArray
  removed : List (Request) -- TODO: remove, def. "active" to ignore satisfied reads
  scopes : ValidScopes
  satisfied : List SatisfiedRead
  threadTypes : ThreadId → String
  orderConstraints : @OrderConstraints scopes
  removedCoherent : ∀ id : RequestId, id ∈ (removed.map Request.id) → id ∈ reqIds requests

def SystemState.beq (state₁ state₂ : SystemState)
  -- (samesystem : state₁.system = state₂.system)
  : Bool :=
  state₁.requests == state₂.requests &&
  state₁.removed == state₂.removed &&
  state₁.satisfied == state₂.satisfied &&
  -- this will be expensive!
  state₁.orderConstraints.compare state₂.orderConstraints (reqIds state₁.requests)

instance : BEq (SystemState) where beq := SystemState.beq

def SystemState.findMaybeRemoved? (state : SystemState) (rId : RequestId) : Option Request :=
  match state.requests.getReq? rId with
    | some r => some r
    | none => state.removed.find? (·.id == rId)

def SystemState.oderConstraintsString (state : SystemState)
(scope : optParam (@Scope state.scopes) state.scopes.systemScope) : String :=
  state.orderConstraints.toString scope $ filterNones $ state.requests.val.toList

def SystemState.threads : SystemState → List ThreadId
 | s => s.scopes.system_scope

def SystemState.prettyPrint (state : SystemState) (highlight : optParam (Option $ ThreadId × RequestId) none) : String :=
  let ocString := if state.scopes.scopes.toList.length == 1
    then s!"constraints: {state.oderConstraintsString}\n"
    else String.intercalate "\n" $ state.scopes.scopes.toList.map
      λ scope => s!"constraints (scope {scope}) : {state.oderConstraintsString (state.scopes.validate scope).get!}"
  let satisfiedStr := state.satisfied.map
    λ (r₁, r₂) => s!"{(state.findMaybeRemoved? r₁).get!.toShortString} with {state.requests.printReq r₂}"
  s!"requests:\n{state.requests.toString}\n\n"++
  s!"{state.requests.prettyPrint state.threads.length state.orderConstraints (highlight := highlight)}\n"  ++
  s!"removed: {state.removed.toString}\n" ++
  s!"satisfied: {satisfiedStr}\n" ++
  ocString

def SystemState.toString : SystemState → String
  | state =>
  let ocString := if state.scopes.scopes.toList.length == 1
    then s!"constraints: {state.oderConstraintsString}\n"
    else String.intercalate "\n" $ state.scopes.scopes.toList.map
      λ scope => s!"constraints (scope {scope}) : {state.oderConstraintsString (state.scopes.validate scope).get!}"
  let satisfiedStr := state.satisfied.map
    λ (r₁, r₂) => s!"{(state.findMaybeRemoved? r₁).get!.toShortString} with {state.requests.printReq r₂}"
  s!"requests:\n{state.requests}\n"  ++
  s!"removed: {state.removed.toString}\n" ++
  s!"satisfied: {satisfiedStr}\n" ++
  ocString

def SystemState.orderPredecessors (state : SystemState) (scope : @Scope state.scopes)
  (reqId : RequestId) : List RequestId :=
  state.orderConstraints.predecessors scope reqId (reqIds state.requests)

instance : ToString (SystemState) where toString := SystemState.toString

theorem emptyCoherent (requests : RequestArray) :
  ∀ id : RequestId, id ∈ [] → id ∈ reqIds requests := by
  intros id h
  contradiction

theorem empty2Coherent (seen : List RequestId) :
  ∀ id₁ id₂ : RequestId, (id₁,id₂) ∈ [] → id₁ ∈ seen ∧ id₂ ∈ seen := by
  intros
  contradiction

def SystemState.init (S : ValidScopes) (threadTypes : ThreadId → String): SystemState :=
  { requests := RequestArray.empty, removed := [],
    scopes := S, satisfied := [], orderConstraints := OrderConstraints.empty,
    removedCoherent := emptyCoherent RequestArray.empty, threadTypes
  }

def SystemState.default := SystemState.init ValidScopes.default (λ _ => "default")
instance : Inhabited (SystemState) where default := SystemState.default

def SystemState.seen : SystemState → List RequestId
  | state => state.requests.seen

def SystemState.idsToReqs : SystemState → List RequestId → List (Request)
  | state, ids => filterNones $ ids.map (λ id => state.requests.getReq? id)

def SystemState.isSatisfied : SystemState → RequestId → Bool
  | state, rid =>
  !(state.satisfied.filter λ (srd,_) => srd == rid).isEmpty

def SystemState.reqPropagatedTo : SystemState → RequestId → ThreadId → Bool
  | state, rid, tid => match state.requests.getReq? rid with
    | none => false
    | some req => req.propagatedTo tid

def SystemState.updateRequest : SystemState → Request → SystemState
  | state, request =>
   let requests' := state.requests.insert request
   SystemState.mk requests' state.removed state.scopes state.satisfied
   state.threadTypes state.orderConstraints sorry
   --{requests := requests', seen := state.seen, removed := state.removed,
   -- scopes := state.scopes, satisfied := state.satisfied,
   -- orderConstraints := state.orderConstraints,
   -- seenCoherent := state.seenCoherent, removedCoherent := state.removedCoherent,
   -- satisfiedCoherent := state.satisfiedCoherent}
def SystemState.allRequests (state : SystemState) : List Request := state.removed ++ filterNones state.requests.val.toList

class Arch where
  (req : ArchReq)
  (orderCondition : ValidScopes → Request → Request → Bool)
  (blockingSemantics : Request → BlockingSemantics)
  (scopeIntersection : (valid : ValidScopes) → Request → Request → @Scope valid := λ v _ _ => v.systemScope)
  (predecessorConstraints : SystemState → RequestId → RequestId → Bool := λ _ _ _ => true)
  (acceptConstraints : SystemState → BasicRequest → ThreadId → Bool := λ _ _ _ => true)
  (acceptEffects : SystemState → RequestId → ThreadId → SystemState := λ st _ _ => st)
  (propagateConstraints : SystemState → RequestId → ThreadId → Bool := λ _ _ _ => true)
  (propagateEffects : SystemState → RequestId → ThreadId → SystemState := λ st _ _ => st)
  (satisfyReadConstraints : SystemState → RequestId → RequestId → Bool := λ _ _ _ => true)
  (satisfyReadEffects : SystemState → RequestId → RequestId → SystemState := λ st _ _ => st)

def Request.blockingSemantics  [inst : Arch] (req : @Request inst.req) : BlockingSemantics := Arch.blockingSemantics req

end Pop


/-
Copyright (c) 2020 Sebastian Ullrich. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich
-/

import Lean.PrettyPrinter.Delaborator.Basic
import Lean.PrettyPrinter.Delaborator.SubExpr
import Lean.PrettyPrinter.Delaborator.TopDownAnalyze
import Lean.Parser

namespace Lean.PrettyPrinter.Delaborator
open Lean.Meta
open Lean.Parser.Term
open SubExpr

def maybeAddBlockImplicit (ident : Syntax) : DelabM Syntax := do
  if ← getPPOption getPPAnalysisBlockImplicit then `(@$ident:ident) else ident

def unfoldMDatas : Expr → Expr
  | Expr.mdata _ e _ => unfoldMDatas e
  | e                => e

@[builtinDelab fvar]
def delabFVar : Delab := do
let Expr.fvar id _ ← getExpr | unreachable!
try
  let l ← getLocalDecl id
  maybeAddBlockImplicit (mkIdent l.userName)
catch _ =>
  -- loose free variable, use internal name
  maybeAddBlockImplicit $ mkIdent id.name

-- loose bound variable, use pseudo syntax
@[builtinDelab bvar]
def delabBVar : Delab := do
  let Expr.bvar idx _ ← getExpr | unreachable!
  pure $ mkIdent $ Name.mkSimple $ "#" ++ toString idx

@[builtinDelab mvar]
def delabMVar : Delab := do
  let Expr.mvar n _ ← getExpr | unreachable!
  let mvarDecl ← getMVarDecl n
  let n :=
    match mvarDecl.userName with
    | Name.anonymous => n.name.replacePrefix `_uniq `m
    | n => n
  `(?$(mkIdent n))

@[builtinDelab sort]
def delabSort : Delab := do
  let Expr.sort l _ ← getExpr | unreachable!
  match l with
  | Level.zero _ => `(Prop)
  | Level.succ (Level.zero _) _ => `(Type)
  | _ => match l.dec with
    | some l' => `(Type $(Level.quote l' max_prec))
    | none    => `(Sort $(Level.quote l max_prec))

def unresolveNameGlobal (n₀ : Name) : DelabM Name := do
  if n₀.hasMacroScopes then return n₀
  let mut initialNames := #[]
  if !(← getPPOption getPPFullNames) then initialNames := initialNames ++ getRevAliases (← getEnv) n₀
  initialNames := initialNames.push (rootNamespace ++ n₀)
  for initialName in initialNames do
    match (← unresolveNameCore initialName) with
    | none => continue
    | some n => return n
  return n₀ -- if can't resolve, return the original
where
  unresolveNameCore (n : Name) : DelabM (Option Name) := do
    let mut revComponents := n.components'
    let mut candidate := Name.anonymous
    for i in [:revComponents.length] do
      match revComponents with
      | [] => return none
      | cmpt::rest => candidate := cmpt ++ candidate; revComponents := rest
      match (← resolveGlobalName candidate) with
      | [(potentialMatch, _)] => if potentialMatch == n₀ then return some candidate else continue
      | _ => continue
    return none

-- NOTE: not a registered delaborator, as `const` is never called (see [delab] description)
def delabConst : Delab := do
  let Expr.const c₀ ls _ ← getExpr | unreachable!
  let ctx ← read
  let c₀ := if (← getPPOption getPPPrivateNames) then c₀ else (privateToUserName? c₀).getD c₀

  let mut c ← unresolveNameGlobal c₀
  let stx ←
    if ls.isEmpty || !(← getPPOption getPPUniverses) then
      if (← getLCtx).usesUserName c then
        -- `c` is also a local declaration
        if c == c₀ && !(← read).inPattern then
          -- `c` is the fully qualified named. So, we append the `_root_` prefix
          c := `_root_ ++ c
        else
          c := c₀
      return mkIdent c
    else
      `($(mkIdent c).{$[$(ls.toArray.map quote)],*})

  maybeAddBlockImplicit stx

structure ParamKind where
  name        : Name
  bInfo       : BinderInfo
  defVal      : Option Expr := none
  isAutoParam : Bool := false

def ParamKind.isRegularExplicit (param : ParamKind) : Bool :=
  param.bInfo.isExplicit && !param.isAutoParam && param.defVal.isNone

/-- Return array with n-th element set to kind of n-th parameter of `e`. -/
partial def getParamKinds : DelabM (Array ParamKind) := do
  let e ← getExpr
  try
    withTransparency TransparencyMode.all do
      forallTelescopeArgs e.getAppFn e.getAppArgs fun params _ => do
        params.mapM fun param => do
          let l ← getLocalDecl param.fvarId!
          pure { name := l.userName, bInfo := l.binderInfo, defVal := l.type.getOptParamDefault?, isAutoParam := l.type.isAutoParam }
  catch _ => pure #[] -- recall that expr may be nonsensical
where
  forallTelescopeArgs f args k := do
    forallBoundedTelescope (← inferType f) args.size fun xs b =>
      if xs.isEmpty || xs.size == args.size then
        -- we still want to consider optParams
        forallTelescopeReducing b fun ys b => k (xs ++ ys) b
      else
        forallTelescopeArgs (mkAppN f $ args.shrink xs.size) (args.extract xs.size args.size) fun ys b =>
          k (xs ++ ys) b

@[builtinDelab app]
def delabAppExplicit : Delab := whenPPOption getPPExplicit do
  let paramKinds ← getParamKinds
  let (fnStx, _, argStxs) ← withAppFnArgs
    (do
      let fn ← getExpr
      let stx ← if fn.isConst then delabConst else delab
      let needsExplicit := paramKinds.any (fun param => !param.isRegularExplicit) && stx.getKind != `Lean.Parser.Term.explicit
      let stx ← if needsExplicit then `(@$stx) else pure stx
      pure (stx, paramKinds.toList, #[]))
    (fun ⟨fnStx, paramKinds, argStxs⟩ => do
      let isInstImplicit := match paramKinds with
                            | [] => false
                            | param :: _ => param.bInfo == BinderInfo.instImplicit
      let argStx ← if ← getPPOption getPPAnalysisHole then `(_)
                   else if isInstImplicit == true then
                     let stx ← if ← getPPOption getPPInstances then delab else `(_)
                     if ← getPPOption getPPInstanceTypes then
                       let typeStx ← withType delab
                       `(($stx : $typeStx))
                     else stx
                   else delab
      pure (fnStx, paramKinds.tailD [], argStxs.push argStx))
  Syntax.mkApp fnStx argStxs

def shouldShowMotive (motive : Expr) (opts : Options) : MetaM Bool := do
  getPPMotivesAll opts
  <||> (← getPPMotivesPi opts <&&> returnsPi motive)
  <||> (← getPPMotivesNonConst opts <&&> isNonConstFun motive)

def withMDataOptions [Inhabited α] (x : DelabM α) : DelabM α := do
  match ← getExpr with
  | Expr.mdata m .. =>
    let mut posOpts := (← read).optionsPerPos
    let pos ← getPos
    for (k, v) in m do
      if (`pp).isPrefixOf k then
        let opts := posOpts.find? pos |>.getD {}
        posOpts := posOpts.insert pos (opts.insert k v)
    withReader ({ · with optionsPerPos := posOpts }) $ withMDataExpr x
  | _ => x

partial def withMDatasOptions [Inhabited α] (x : DelabM α) : DelabM α := do
  if (← getExpr).isMData then withMDataOptions (withMDatasOptions x) else x

def isRegularApp : DelabM Bool := do
  let e ← getExpr
  if not (unfoldMDatas e.getAppFn).isConst then return false
  if ← withNaryFn (withMDatasOptions (getPPOption getPPUniverses <||> getPPOption getPPAnalysisBlockImplicit)) then return false
  for i in [:e.getAppNumArgs] do
    if ← withNaryArg i (getPPOption getPPAnalysisNamedArg) then return false
  return true

def unexpandRegularApp (stx : Syntax) : Delab := do
  let Expr.const c .. ← pure (unfoldMDatas (← getExpr).getAppFn) | unreachable!
  let fs ← appUnexpanderAttribute.getValues (← getEnv) c
  fs.firstM fun f =>
    match f stx |>.run () with
    | EStateM.Result.ok stx _ => pure stx
    | _ => failure

-- abbrev coe {α : Sort u} {β : Sort v} (a : α) [CoeT α a β] : β
-- abbrev coeFun {α : Sort u} {γ : α → Sort v} (a : α) [CoeFun α γ] : γ a
def unexpandCoe (stx : Syntax) : Delab := whenPPOption getPPCoercions do
  if not (← isCoe (← getExpr)) then failure
  let e ← getExpr
  match stx with
  | `($fn $arg)   => arg
  | `($fn $args*) => `($(args.get! 0) $(args.eraseIdx 0)*)
  | _             => failure

def unexpandStructureInstance (stx : Syntax) : Delab := whenPPOption getPPStructureInstances do
  let env ← getEnv
  let e ← getExpr
  let some s ← pure $ e.isConstructorApp? env | failure
  guard $ isStructure env s.induct;
  /- If implicit arguments should be shown, and the structure has parameters, we should not
     pretty print using { ... }, because we will not be able to see the parameters. -/
  let fieldNames := getStructureFields env s.induct
  let mut fields := #[]
  guard $ fieldNames.size == stx[1].getNumArgs
  let args := e.getAppArgs
  let fieldVals := args.extract s.numParams args.size
  for idx in [:fieldNames.size] do
    let fieldName := fieldNames[idx]
    let fieldId := mkIdent fieldName
    let fieldPos ← nextExtraPos
    let fieldId := annotatePos fieldPos fieldId
    addFieldInfo fieldPos (s.induct ++ fieldName) fieldName fieldId fieldVals[idx]
    let field ← `(structInstField|$fieldId:ident := $(stx[1][idx]):term)
    fields := fields.push field
  let tyStx ← withType do
    if (← getPPOption getPPStructureInstanceType) then delab >>= pure ∘ some else pure none
  if fields.isEmpty then
    `({ $[: $tyStx]? })
  else
    let lastField := fields.back
    fields := fields.pop
    `({ $[$fields, ]* $lastField $[: $tyStx]? })

@[builtinDelab app]
def delabAppImplicit : Delab := do
  -- TODO: always call the unexpanders, make them guard on the right # args?
  let paramKinds ← getParamKinds
  if ← getPPOption getPPExplicit then
    if paramKinds.any (fun param => !param.isRegularExplicit) then failure

  let (fnStx, _, argStxs) ← withAppFnArgs
    (do
      let fn ← getExpr
      let stx ← if fn.isConst then delabConst else delab
      pure (stx, paramKinds.toList, #[]))
    (fun (fnStx, paramKinds, argStxs) => do
      let arg ← getExpr
      let opts ← getOptions
      let mkNamedArg (name : Name) (argStx : Syntax) : DelabM Syntax := do
        `(Parser.Term.namedArgument| ($(← mkIdent name):ident := $argStx:term))
      let argStx? : Option Syntax ←
        if ← getPPOption getPPAnalysisSkip then pure none
        else if ← getPPOption getPPAnalysisHole then `(_)
        else
          match paramKinds with
          | [] => delab
          | param :: rest =>
            if param.defVal.isSome && rest.isEmpty then
              let v := param.defVal.get!
              if !v.hasLooseBVars && v == arg then none else delab
            else if !param.isRegularExplicit && param.defVal.isNone then
              if ← getPPOption getPPAnalysisNamedArg <||> (param.name == `motive <&&> shouldShowMotive arg opts) then mkNamedArg param.name (← delab) else none
            else delab
      let argStxs := match argStx? with
        | none => argStxs
        | some stx => argStxs.push stx
      pure (fnStx, paramKinds.tailD [], argStxs))
  let stx := Syntax.mkApp fnStx argStxs

  if ← isRegularApp then
    (guard (← getPPOption getPPNotation) *> unexpandRegularApp stx)
    <|> (guard (← getPPOption getPPStructureInstances) *> unexpandStructureInstance stx)
    <|> (guard (← getPPOption getPPNotation) *> unexpandCoe stx)
    <|> pure stx
  else pure stx

/-- State for `delabAppMatch` and helpers. -/
structure AppMatchState where
  info        : MatcherInfo
  matcherTy   : Expr
  params      : Array Expr := #[]
  motive      : Option (Syntax × Expr) := none
  motiveNamed : Bool := false
  discrs      : Array Syntax := #[]
  varNames    : Array (Array Name) := #[]
  rhss        : Array Syntax := #[]
  -- additional arguments applied to the result of the `match` expression
  moreArgs    : Array Syntax := #[]
/--
  Extract arguments of motive applications from the matcher type.
  For the example below: `#[#[`([])], #[`(a::as)]]` -/
private partial def delabPatterns (st : AppMatchState) : DelabM (Array (Array Syntax)) :=
  withReader (fun ctx => { ctx with inPattern := true, optionsPerPos := {} }) do
    let ty ← instantiateForall st.matcherTy st.params
    forallTelescope ty fun params _ => do
      -- skip motive and discriminators
      let alts := Array.ofSubarray params[1 + st.discrs.size:]
      alts.mapIdxM fun idx alt => do
        let ty ← inferType alt
        -- TODO: this is a hack; we are accessing the expression out-of-sync with the position
        -- Currently, we reset `optionsPerPos` at the beginning of `delabPatterns` to avoid
        -- incorrectly considering annotations.
        withTheReader SubExpr ({ · with expr := ty }) $
          usingNames st.varNames[idx] do
            withAppFnArgs (pure #[]) (fun pats => do pure $ pats.push (← delab))
where
  usingNames {α} (varNames : Array Name) (x : DelabM α) : DelabM α :=
    usingNamesAux 0 varNames x
  usingNamesAux {α} (i : Nat) (varNames : Array Name) (x : DelabM α) : DelabM α :=
    if i < varNames.size then
      withBindingBody varNames[i] <| usingNamesAux (i+1) varNames x
    else
      x

/-- Skip `numParams` binders, and execute `x varNames` where `varNames` contains the new binder names. -/
private partial def skippingBinders {α} (numParams : Nat) (x : Array Name → DelabM α) : DelabM α :=
  loop numParams #[]
where
  loop : Nat → Array Name → DelabM α
    | 0,   varNames => x varNames
    | n+1, varNames => do
      let rec visitLambda : DelabM α := do
        let varName ← (← getExpr).bindingName!.eraseMacroScopes
        -- Pattern variables cannot shadow each other
        if varNames.contains varName then
          let varName := (← getLCtx).getUnusedName varName
          withBindingBody varName do
            loop n (varNames.push varName)
        else
          withBindingBodyUnusedName fun id => do
            loop n (varNames.push id.getId)
      let e ← getExpr
      if e.isLambda then
        visitLambda
      else
        -- eta expand `e`
        let e ← forallTelescopeReducing (← inferType e) fun xs _ => do
          if xs.size == 1 && (← inferType xs[0]).isConstOf ``Unit then
            -- `e` might be a thunk create by the dependent pattern matching compiler, and `xs[0]` may not even be a pattern variable.
            -- If it is a pattern variable, it doesn't look too bad to use `()` instead of the pattern variable.
            -- If it becomes a problem in the future, we should modify the dependent pattern matching compiler, and make sure
            -- it adds an annotation to distinguish these two cases.
            mkLambdaFVars xs (mkApp e (mkConst ``Unit.unit))
          else
            mkLambdaFVars xs (mkAppN e xs)
        withTheReader SubExpr (fun ctx => { ctx with expr := e }) visitLambda

/--
  Delaborate applications of "matchers" such as
  ```
  List.map.match_1 : {α : Type _} →
    (motive : List α → Sort _) →
      (x : List α) → (Unit → motive List.nil) → ((a : α) → (as : List α) → motive (a :: as)) → motive x
  ```
-/
@[builtinDelab app]
def delabAppMatch : Delab := whenPPOption getPPNotation <| whenPPOption getPPMatch do
  -- incrementally fill `AppMatchState` from arguments
  let st ← withAppFnArgs
    (do
      let (Expr.const c us _) ← getExpr | failure
      let (some info) ← getMatcherInfo? c | failure
      { matcherTy := (← getConstInfo c).instantiateTypeLevelParams us, info := info : AppMatchState })
    (fun st => do
      if st.params.size < st.info.numParams then
        pure { st with params := st.params.push (← getExpr) }
      else if st.motive.isNone then
         -- store motive argument separately
         let lamMotive ← getExpr
         let piMotive ← lambdaTelescope lamMotive fun xs body => mkForallFVars xs body
         -- TODO: pp.analyze has not analyzed `piMotive`, only `lamMotive`
         -- Thus the binder types won't have any annotations
         let piStx ← withTheReader SubExpr (fun cfg => { cfg with expr := piMotive }) delab
         let named ← getPPOption getPPAnalysisNamedArg
         pure { st with motive := (piStx, lamMotive), motiveNamed := named }
      else if st.discrs.size < st.info.numDiscrs then
        pure { st with discrs := st.discrs.push (← delab) }
      else if st.rhss.size < st.info.altNumParams.size then
        /- We save the variables names here to be able to implement safe_shadowing.
           The pattern delaboration must use the names saved here. -/
        let (varNames, rhs) ← skippingBinders st.info.altNumParams[st.rhss.size] fun varNames => do
          let rhs ← delab
          return (varNames, rhs)
        pure { st with rhss := st.rhss.push rhs, varNames := st.varNames.push varNames }
      else
        pure { st with moreArgs := st.moreArgs.push (← delab) })

  if st.discrs.size < st.info.numDiscrs || st.rhss.size < st.info.altNumParams.size then
    -- underapplied
    failure

  match st.discrs, st.rhss with
  | #[discr], #[] =>
    let stx ← `(nomatch $discr)
    Syntax.mkApp stx st.moreArgs
  | _,        #[] => failure
  | _,        _   =>
    let pats ← delabPatterns st
    let stx ← do
      let (piStx, lamMotive) := st.motive.get!
      let opts ← getOptions
      -- TODO: disable the match if other implicits are needed?
      if ← st.motiveNamed <||> shouldShowMotive lamMotive opts then
        `(match $[$st.discrs:term],* : $piStx with $[| $pats,* => $st.rhss]*)
      else
        `(match $[$st.discrs:term],* with $[| $pats,* => $st.rhss]*)
    Syntax.mkApp stx st.moreArgs

/--
  Delaborate applications of the form `(fun x => b) v` as `let_fun x := v; b`
-/
def delabLetFun : Delab := do
  let stxV ← withAppArg delab
  withAppFn do
    let Expr.lam n t b _ ← getExpr | unreachable!
    let n ← getUnusedName n b
    let stxB ← withBindingBody n delab
    if ← getPPOption getPPLetVarTypes <||> getPPOption getPPAnalysisLetVarType then
      let stxT ← withBindingDomain delab
      `(let_fun $(mkIdent n) : $stxT := $stxV; $stxB)
    else
      `(let_fun $(mkIdent n) := $stxV; $stxB)

@[builtinDelab mdata]
def delabMData : Delab := do
  if let some _ := Lean.Meta.Match.inaccessible? (← getExpr) then
    let s ← withMDataExpr delab
    if (← read).inPattern then
      `(.($s)) -- We only include the inaccessible annotation when we are delaborating patterns
    else
      return s
  else if isLetFun (← getExpr) then
    withMDataExpr <| delabLetFun
  else if let some _ := isLHSGoal? (← getExpr) then
    withMDataExpr <| withAppFn <| withAppArg <| delab
  else
    withMDataOptions delab

/--
Check for a `Syntax.ident` of the given name anywhere in the tree.
This is usually a bad idea since it does not check for shadowing bindings,
but in the delaborator we assume that bindings are never shadowed.
-/
partial def hasIdent (id : Name) : Syntax → Bool
  | Syntax.ident _ _ id' _ => id == id'
  | Syntax.node _ args     => args.any (hasIdent id)
  | _                      => false

/--
Return `true` iff current binder should be merged with the nested
binder, if any, into a single binder group:
* both binders must have same binder info and domain
* they cannot be inst-implicit (`[a b : A]` is not valid syntax)
* `pp.binderTypes` must be the same value for both terms
* prefer `fun a b` over `fun (a b)`
-/
private def shouldGroupWithNext : DelabM Bool := do
  let e ← getExpr
  let ppEType ← getPPOption (getPPBinderTypes e)
  let go (e' : Expr) := do
    let ppE'Type ← withBindingBody `_ $ getPPOption (getPPBinderTypes e)
    pure $ e.binderInfo == e'.binderInfo &&
      e.bindingDomain! == e'.bindingDomain! &&
      e'.binderInfo != BinderInfo.instImplicit &&
      ppEType == ppE'Type &&
      (e'.binderInfo != BinderInfo.default || ppE'Type)
  match e with
  | Expr.lam _ _     e'@(Expr.lam _ _ _ _) _     => go e'
  | Expr.forallE _ _ e'@(Expr.forallE _ _ _ _) _ => go e'
  | _ => pure false
where
  getPPBinderTypes (e : Expr) :=
    if e.isForall then getPPPiBinderTypes else getPPFunBinderTypes

private partial def delabBinders (delabGroup : Array Syntax → Syntax → Delab) : optParam (Array Syntax) #[] → Delab
  -- Accumulate names (`Syntax.ident`s with position information) of the current, unfinished
  -- binder group `(d e ...)` as determined by `shouldGroupWithNext`. We cannot do grouping
  -- inside-out, on the Syntax level, because it depends on comparing the Expr binder types.
  | curNames => do
    if ← shouldGroupWithNext then
      -- group with nested binder => recurse immediately
      withBindingBodyUnusedName fun stxN => delabBinders delabGroup (curNames.push stxN)
    else
      -- don't group => delab body and prepend current binder group
      let (stx, stxN) ← withBindingBodyUnusedName fun stxN => do (← delab, stxN)
      delabGroup (curNames.push stxN) stx

@[builtinDelab lam]
def delabLam : Delab :=
  delabBinders fun curNames stxBody => do
    let e ← getExpr
    let stxT ← withBindingDomain delab
    let ppTypes ← getPPOption getPPFunBinderTypes
    let expl ← getPPOption getPPExplicit
    let usedDownstream ← curNames.any (fun n => hasIdent n.getId stxBody)

    -- leave lambda implicit if possible
    -- TODO: for now we just always block implicit lambdas when delaborating. We can revisit.
    -- Note: the current issue is that it requires state, i.e. if *any* previous binder was implicit,
    -- it doesn't seem like we can leave a subsequent binder implicit.
    let blockImplicitLambda := true
    /-
    let blockImplicitLambda := expl ||
      e.binderInfo == BinderInfo.default ||
      -- Note: the following restriction fixes many issues with roundtripping,
      -- but this condition may still not be perfectly in sync with the elaborator.
      e.binderInfo == BinderInfo.instImplicit ||
      Elab.Term.blockImplicitLambda stxBody ||
      usedDownstream
    -/

    if !blockImplicitLambda then
      pure stxBody
    else
      let group ← match e.binderInfo, ppTypes with
        | BinderInfo.default,     true   =>
          -- "default" binder group is the only one that expects binder names
          -- as a term, i.e. a single `Syntax.ident` or an application thereof
          let stxCurNames ←
            if curNames.size > 1 then
              `($(curNames.get! 0) $(curNames.eraseIdx 0)*)
            else
              pure $ curNames.get! 0;
          `(funBinder| ($stxCurNames : $stxT))
        | BinderInfo.default,        false  => pure curNames.back  -- here `curNames.size == 1`
        | BinderInfo.implicit,       true   => `(funBinder| {$curNames* : $stxT})
        | BinderInfo.implicit,       false  => `(funBinder| {$curNames*})
        | BinderInfo.strictImplicit, true   => `(funBinder| ⦃$curNames* : $stxT⦄)
        | BinderInfo.strictImplicit, false  => `(funBinder| ⦃$curNames*⦄)
        | BinderInfo.instImplicit,   _     =>
          if usedDownstream then `(funBinder| [$curNames.back : $stxT])  -- here `curNames.size == 1`
          else  `(funBinder| [$stxT])
        | _                      , _     => unreachable!;
      match stxBody with
      | `(fun $binderGroups* => $stxBody) => `(fun $group $binderGroups* => $stxBody)
      | _                                 => `(fun $group => $stxBody)

@[builtinDelab forallE]
def delabForall : Delab :=
  delabBinders fun curNames stxBody => do
    let e ← getExpr
    let prop ← try isProp e catch _ => false
    let stxT ← withBindingDomain delab
    let group ← match e.binderInfo with
    | BinderInfo.implicit       => `(bracketedBinderF|{$curNames* : $stxT})
    | BinderInfo.strictImplicit => `(bracketedBinderF|⦃$curNames* : $stxT⦄)
    -- here `curNames.size == 1`
    | BinderInfo.instImplicit   => `(bracketedBinderF|[$curNames.back : $stxT])
    | _                         =>
      -- heuristic: use non-dependent arrows only if possible for whole group to avoid
      -- noisy mix like `(α : Type) → Type → (γ : Type) → ...`.
      let dependent := curNames.any $ fun n => hasIdent n.getId stxBody
      -- NOTE: non-dependent arrows are available only for the default binder info
      if dependent then
        if prop && !(← getPPOption getPPPiBinderTypes) then
          return ← `(∀ $curNames:ident*, $stxBody)
        else
          `(bracketedBinderF|($curNames* : $stxT))
      else
        return ← curNames.foldrM (fun _ stxBody => `($stxT → $stxBody)) stxBody
    if prop then
      match stxBody with
      | `(∀ $groups*, $stxBody) => `(∀ $group $groups*, $stxBody)
      | _                       => `(∀ $group, $stxBody)
    else
      `($group:bracketedBinder → $stxBody)

@[builtinDelab letE]
def delabLetE : Delab := do
  let Expr.letE n t v b _ ← getExpr | unreachable!
  let n ← getUnusedName n b
  let stxV ← descend v 1 delab
  let stxB ← withLetDecl n t v fun fvar =>
    let b := b.instantiate1 fvar
    descend b 2 delab
  if ← getPPOption getPPLetVarTypes <||> getPPOption getPPAnalysisLetVarType then
    let stxT ← descend t 0 delab
    `(let $(mkIdent n) : $stxT := $stxV; $stxB)
  else `(let $(mkIdent n) := $stxV; $stxB)

@[builtinDelab lit]
def delabLit : Delab := do
  let Expr.lit l _ ← getExpr | unreachable!
  match l with
  | Literal.natVal n => pure $ quote n
  | Literal.strVal s => pure $ quote s

-- `@OfNat.ofNat _ n _` ~> `n`
@[builtinDelab app.OfNat.ofNat]
def delabOfNat : Delab := whenPPOption getPPCoercions do
  let (Expr.app (Expr.app _ (Expr.lit (Literal.natVal n) _) _) _ _) ← getExpr | failure
  return quote n

-- `@OfDecimal.ofDecimal _ _ m s e` ~> `m*10^(sign * e)` where `sign == 1` if `s = false` and `sign = -1` if `s = true`
@[builtinDelab app.OfScientific.ofScientific]
def delabOfScientific : Delab := whenPPOption getPPCoercions do
  let expr ← getExpr
  guard <| expr.getAppNumArgs == 5
  let Expr.lit (Literal.natVal m) _ ← pure (expr.getArg! 2) | failure
  let Expr.lit (Literal.natVal e) _ ← pure (expr.getArg! 4) | failure
  let s ← match expr.getArg! 3 with
    | Expr.const `Bool.true _ _  => pure true
    | Expr.const `Bool.false _ _ => pure false
    | _ => failure
  let str  := toString m
  if s && e == str.length then
    return Syntax.mkScientificLit ("0." ++ str)
  else if s && e < str.length then
    let mStr := str.extract 0 (str.length - e)
    let eStr := str.extract (str.length - e) str.length
    return Syntax.mkScientificLit (mStr ++ "." ++ eStr)
  else
    return Syntax.mkScientificLit (str ++ "e" ++ (if s then "-" else "") ++ toString e)

/--
Delaborate a projection primitive. These do not usually occur in
user code, but are pretty-printed when e.g. `#print`ing a projection
function.
-/
@[builtinDelab proj]
def delabProj : Delab := do
  let Expr.proj _ idx _ _ ← getExpr | unreachable!
  let e ← withProj delab
  -- not perfectly authentic: elaborates to the `idx`-th named projection
  -- function (e.g. `e.1` is `Prod.fst e`), which unfolds to the actual
  -- `proj`.
  let idx := Syntax.mkLit fieldIdxKind (toString (idx + 1));
  `($(e).$idx:fieldIdx)

/-- Delaborate a call to a projection function such as `Prod.fst`. -/
@[builtinDelab app]
def delabProjectionApp : Delab := whenPPOption getPPStructureProjections $ do
  let e@(Expr.app fn _ _) ← getExpr | failure
  let Expr.const c@(Name.str _ f _) _ _ ← pure fn.getAppFn | failure
  let env ← getEnv
  let some info ← pure $ env.getProjectionFnInfo? c | failure
  -- can't use with classes since the instance parameter is implicit
  guard $ !info.fromClass
  -- projection function should be fully applied (#struct params + 1 instance parameter)
  -- TODO: support over-application
  guard $ e.getAppNumArgs == info.numParams + 1
  -- If pp.explicit is true, and the structure has parameters, we should not
  -- use field notation because we will not be able to see the parameters.
  let expl ← getPPOption getPPExplicit
  guard $ !expl || info.numParams == 0
  let appStx ← withAppArg delab
  `($(appStx).$(mkIdent f):ident)

@[builtinDelab app.dite]
def delabDIte : Delab := whenPPOption getPPNotation do
  -- Note: we keep this as a delaborator for now because it actually accesses the expression.
  guard $ (← getExpr).getAppNumArgs == 5
  let c ← withAppFn $ withAppFn $ withAppFn $ withAppArg delab
  let (t, h) ← withAppFn $ withAppArg $ delabBranch none
  let (e, _) ← withAppArg $ delabBranch h
  `(if $(mkIdent h):ident : $c then $t else $e)
where
  delabBranch (h? : Option Name) : DelabM (Syntax × Name) := do
    let e ← getExpr
    guard e.isLambda
    let h ← match h? with
      | some h => return (← withBindingBody h delab, h)
      | none   => withBindingBodyUnusedName fun h => do
        return (← delab, h.getId)

@[builtinDelab app.namedPattern]
def delabNamedPattern : Delab := do
  -- Note: we keep this as a delaborator because it accesses the DelabM context
  guard (← read).inPattern
  guard $ (← getExpr).getAppNumArgs == 3
  let x ← withAppFn $ withAppArg delab
  let p ← withAppArg delab
  guard x.isIdent
  `($x:ident@$p:term)

partial def delabDoElems : DelabM (List Syntax) := do
  let e ← getExpr
  if e.isAppOfArity `Bind.bind 6 then
    -- Bind.bind.{u, v} : {m : Type u → Type v} → [self : Bind m] → {α β : Type u} → m α → (α → m β) → m β
    let α := e.getAppArgs[2]
    let ma ← withAppFn $ withAppArg delab
    withAppArg do
      match (← getExpr) with
      | Expr.lam _ _ body _ =>
        withBindingBodyUnusedName fun n => do
          if body.hasLooseBVars then
            prependAndRec `(doElem|let $n:term ← $ma:term)
          else if α.isConstOf `Unit || α.isConstOf `PUnit then
            prependAndRec `(doElem|$ma:term)
          else
            prependAndRec `(doElem|let _ ← $ma:term)
      | _ => failure
  else if e.isLet then
    let Expr.letE n t v b _ ← getExpr | unreachable!
    let n ← getUnusedName n b
    let stxT ← descend t 0 delab
    let stxV ← descend v 1 delab
    withLetDecl n t v fun fvar =>
      let b := b.instantiate1 fvar
      descend b 2 $
        prependAndRec `(doElem|let $(mkIdent n) : $stxT := $stxV)
  else
    let stx ← delab
    [←`(doElem|$stx:term)]
  where
    prependAndRec x : DelabM _ := List.cons <$> x <*> delabDoElems

@[builtinDelab app.Bind.bind]
def delabDo : Delab := whenPPOption getPPNotation do
  guard <| (← getExpr).isAppOfArity `Bind.bind 6
  let elems ← delabDoElems
  let items ← elems.toArray.mapM (`(doSeqItem|$(·):doElem))
  `(do $items:doSeqItem*)

def reifyName : Expr → DelabM Name
  | Expr.const ``Lean.Name.anonymous .. => Name.anonymous
  | Expr.app (Expr.app (Expr.const ``Lean.Name.mkStr ..) n _) (Expr.lit (Literal.strVal s) _) _ => do
    (← reifyName n).mkStr s
  | Expr.app (Expr.app (Expr.const ``Lean.Name.mkNum ..) n _) (Expr.lit (Literal.natVal i) _) _ => do
    (← reifyName n).mkNum i
  | _ => failure

@[builtinDelab app.Lean.Name.mkStr]
def delabNameMkStr : Delab := whenPPOption getPPNotation do
  let n ← reifyName (← getExpr)
  -- not guaranteed to be a syntactically valid name, but usually more helpful than the explicit version
  mkNode ``Lean.Parser.Term.quotedName #[Syntax.mkNameLit s!"`{n}"]

@[builtinDelab app.Lean.Name.mkNum]
def delabNameMkNum : Delab := delabNameMkStr

end Lean.PrettyPrinter.Delaborator


import Mathlib.Tactic.UnsetOption
import Mathlib.Tactic.RunCmd

set_option pp.all true

example : True := by
  run_tac
    let t : Option Bool := (← Lean.MonadOptions.getOptions).get? `pp.all
    -- should be true as set
    guard (t == true)
  trivial

section

unset_option pp.all

example : True := by
  run_tac
    let t : Option Bool := (← Lean.MonadOptions.getOptions).get? `pp.all
    -- should be none as unset
    guard (t == Option.none)
  trivial

end

example : True := by
  run_tac
    let t : Option Bool := (← Lean.MonadOptions.getOptions).get? `pp.all
    -- should be true as only unset within section
    guard (t == true)
  trivial


import tactic.lint
import algebra.continued_fractions.computation.approximations
--set_option pp.all true
-- set_option profiler true
lemma another (g : 1000 = 2*500): 1000 = 2*500 ∧ 1000 = 2*500 :=
begin
  let h :ℕ :=1,
  exact ⟨rfl, rfl⟩
end
#print another
#lint

lemma foo (p : Prop) : p → p :=
assume hp : p,
have hp2 : p, from hp,
show p, from hp
#print foo

lemma fun_problem (p : Prop) : ¬ (p ↔ ¬ p) :=
assume hpnp,
have hnp : ¬ p, from
  assume hp : p,
  have hnp : ¬ p, from hpnp.mp hp,
  show false, from hnp hp,
have hp : p, from
  have unnecessary : ¬ p, from hnp,
  show p, from hpnp.mpr hnp,
show false, from hnp hp

open tactic declaration expr

meta def find_unused_have_macro : expr → tactic (list name)
| (app a a_1) := (++) <$> find_unused_have_macro a <*> find_unused_have_macro a_1
| (lam var_name bi var_type body) :=  find_unused_have_macro body
| (pi var_name bi var_type body) := find_unused_have_macro body
| (elet var_name type assignment body) := find_unused_have_macro body
| (macro md [lam ppnm _ _ bd]) := do
       (++) (if bd.has_zero_var then [] else [ppnm]) <$>
        find_unused_have_macro bd
| (macro md l) := do ls ← l.mmap find_unused_have_macro, return ls.join
| _ := return []

meta def find_unused_let_macro : expr → tactic (list name)
| (app a a_1) := (++) <$> find_unused_let_macro a <*> find_unused_let_macro a_1
| (lam var_name bi var_type body) :=  find_unused_let_macro body
| (pi var_name bi var_type body) := find_unused_let_macro body
| (elet var_name type assignment body) := do
  --trace body,
       (++) (if body.has_zero_var then [] else [var_name]) <$>
        find_unused_let_macro body

| (macro md [lam ppnm _ _ bd]) :=find_unused_let_macro bd
| (macro md l) := do ls ← l.mmap find_unused_let_macro, return ls.join
| _ := return []

meta def unused_of_decl : declaration → tactic (list name)
| (defn a a_1 a_2 bd a_4 a_5) := find_unused_let_macro bd
| (thm a a_1 a_2 bd) := find_unused_let_macro bd.get
| _ := return []

run_cmd
do d ← get_decl `generalized_continued_fraction.le_of_succ_succ_nth_continuants_aux_b,
unused_of_decl  d

@[linter] meta def linter.unused_lets : linter :=
{ test := λ d,
  (do
  --trace d.to_name,
  ns ← unused_of_decl d,
   if ns.length = 0 then return none else return (", ".intercalate (ns.map to_string))),
  no_errors_found := "all good",
  errors_found := "DECLS HAVE UNNEEDED LETS",
  is_fast := tt,
  auto_decls := ff }
lemma tmp : ∃ n, n = 1 :=
let a := 1, b:=1 in
begin
  set t := 2,
  use a,
end
#print tmp
#lint only unused_lets


import ..utils.util
import all

section main
open tactic

meta def main : io unit := do {
  args ← io.cmdline_args,
  let dest : string := ((args.nth 0).get_or_else "./data/mathlib_decls.log"),
  let ignore_decls_fn : environment → declaration → bool :=
    (λ e d, declaration.is_auto_or_internal e d || bnot (declaration.is_theorem d) || d.to_name.is_aux),
  f ← io.mk_file_handle dest io.mode.append,
  io.run_tactic' $ do {
    env ← get_env,
    decls ← list.filter (λ d, !(ignore_decls_fn env d)) <$> lint_mathlib_decls,
    for_ decls $ λ decl, do {
      let decl_name := decl.to_name.to_string,
      tactic.unsafe_run_io $ io.fs.put_str_ln f decl_name,
      tactic.trace format!"DECL: {decl_name}"
    }
  }
}

end main


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

! This file was ported from Lean 3 source module data.rbtree.basic
! leanprover-community/mathlib commit 5cb17dd1617d2dc55eb17777c3dcded3306fadb5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Rbtree.Init
import Mathbin.Logic.IsEmpty
import Mathbin.Tactic.Interactive

universe u

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
unsafe def tactic.interactive.blast_disjs : tactic Unit :=
  sorry
#align tactic.interactive.blast_disjs tactic.interactive.blast_disjs

namespace Rbnode

variable {α : Type u}

open Color Nat

inductive IsNodeOf : Rbnode α → Rbnode α → α → Rbnode α → Prop
  | of_red (l v r) : is_node_of (red_node l v r) l v r
  | of_black (l v r) : is_node_of (black_node l v r) l v r
#align rbnode.is_node_of Rbnode.IsNodeOf

def Lift (lt : α → α → Prop) : Option α → Option α → Prop
  | some a, some b => lt a b
  | _, _ => True
#align rbnode.lift Rbnode.Lift

inductive IsSearchable (lt : α → α → Prop) : Rbnode α → Option α → Option α → Prop
  | leaf_s {lo hi} (hlt : Lift lt lo hi) : is_searchable leaf lo hi
  |
  red_s {l r v lo hi} (hs₁ : is_searchable l lo (some v)) (hs₂ : is_searchable r (some v) hi) :
    is_searchable (red_node l v r) lo hi
  |
  black_s {l r v lo hi} (hs₁ : is_searchable l lo (some v)) (hs₂ : is_searchable r (some v) hi) :
    is_searchable (black_node l v r) lo hi
#align rbnode.is_searchable Rbnode.IsSearchable

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
unsafe def is_searchable_tactic : tactic Unit :=
  sorry
#align rbnode.is_searchable_tactic rbnode.is_searchable_tactic

open Rbnode (Mem)

open IsSearchable

section IsSearchableLemmas

variable {lt : α → α → Prop}

theorem lo_lt_hi {t : Rbnode α} {lt} [IsTrans α lt] :
    ∀ {lo hi}, IsSearchable lt t lo hi → Lift lt lo hi :=
  by
  induction t <;> intro lo hi hs
  case leaf => cases hs; assumption
  all_goals
    cases hs
    have h₁ := t_ih_lchild hs_hs₁
    have h₂ := t_ih_rchild hs_hs₂
    cases lo <;> cases hi <;> simp [lift] at *
    apply trans_of lt h₁ h₂
#align rbnode.lo_lt_hi Rbnode.lo_lt_hi

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_of_isSearchable_of_incomp [IsStrictWeakOrder α lt] {t} :
    ∀ {lo hi hi'} (hc : ¬lt hi' hi ∧ ¬lt hi hi') (hs : IsSearchable lt t lo (some hi)),
      IsSearchable lt t lo (some hi') :=
  by
  classical
    induction t <;> intros <;>
      run_tac
        is_searchable_tactic
    · cases lo <;> simp_all [lift]
      apply lt_of_lt_of_incomp
      assumption
      exact ⟨hc.2, hc.1⟩
    all_goals apply t_ih_rchild hc hs_hs₂
#align rbnode.is_searchable_of_is_searchable_of_incomp Rbnode.isSearchable_of_isSearchable_of_incomp

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_of_incomp_of_isSearchable [IsStrictWeakOrder α lt] {t} :
    ∀ {lo lo' hi} (hc : ¬lt lo' lo ∧ ¬lt lo lo') (hs : IsSearchable lt t (some lo) hi),
      IsSearchable lt t (some lo') hi :=
  by
  classical
    induction t <;> intros <;>
      run_tac
        is_searchable_tactic
    · cases hi <;> simp_all [lift]
      apply lt_of_incomp_of_lt
      assumption
      assumption
    all_goals apply t_ih_lchild hc hs_hs₁
#align rbnode.is_searchable_of_incomp_of_is_searchable Rbnode.isSearchable_of_incomp_of_isSearchable

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_some_low_of_isSearchable_of_lt {t} [IsTrans α lt] :
    ∀ {lo hi lo'} (hlt : lt lo' lo) (hs : IsSearchable lt t (some lo) hi),
      IsSearchable lt t (some lo') hi :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · cases hi <;> simp_all [lift]
    apply trans_of lt hlt
    assumption
  all_goals apply t_ih_lchild hlt hs_hs₁
#align rbnode.is_searchable_some_low_of_is_searchable_of_lt Rbnode.isSearchable_some_low_of_isSearchable_of_lt

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_none_low_of_isSearchable_some_low {t} :
    ∀ {y hi} (hlt : IsSearchable lt t (some y) hi), IsSearchable lt t none hi :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · simp [lift]
  all_goals apply t_ih_lchild hlt_hs₁
#align rbnode.is_searchable_none_low_of_is_searchable_some_low Rbnode.isSearchable_none_low_of_isSearchable_some_low

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_some_high_of_isSearchable_of_lt {t} [IsTrans α lt] :
    ∀ {lo hi hi'} (hlt : lt hi hi') (hs : IsSearchable lt t lo (some hi)),
      IsSearchable lt t lo (some hi') :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · cases lo <;> simp_all [lift]
    apply trans_of lt
    assumption
    assumption
  all_goals apply t_ih_rchild hlt hs_hs₂
#align rbnode.is_searchable_some_high_of_is_searchable_of_lt Rbnode.isSearchable_some_high_of_isSearchable_of_lt

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic rbnode.is_searchable_tactic -/
theorem isSearchable_none_high_of_isSearchable_some_high {t} :
    ∀ {lo y} (hlt : IsSearchable lt t lo (some y)), IsSearchable lt t lo none :=
  by
  induction t <;> intros <;>
    run_tac
      is_searchable_tactic
  · cases lo <;> simp [lift]
  all_goals apply t_ih_rchild hlt_hs₂
#align rbnode.is_searchable_none_high_of_is_searchable_some_high Rbnode.isSearchable_none_high_of_isSearchable_some_high

theorem range [IsStrictWeakOrder α lt] {t : Rbnode α} {x} :
    ∀ {lo hi}, IsSearchable lt t lo hi → Mem lt x t → Lift lt lo (some x) ∧ Lift lt (some x) hi :=
  by
  classical
    induction t
    case leaf => simp [mem]
    all_goals
      -- red_node and black_node are identical
      intro lo hi h₁ h₂
      cases h₁
      simp only [mem] at h₂
      have val_hi : lift lt (some t_val) hi :=
        by
        apply lo_lt_hi
        assumption
      have lo_val : lift lt lo (some t_val) :=
        by
        apply lo_lt_hi
        assumption
      cases_type*or.1
      · have h₃ : lift lt lo (some x) ∧ lift lt (some x) (some t_val) :=
          by
          apply t_ih_lchild
          assumption
          assumption
        cases' h₃ with lo_x x_val
        constructor
        show lift lt lo (some x)
        · assumption
        show lift lt (some x) hi
        · cases' hi with hi <;> simp [lift] at *
          apply trans_of lt x_val val_hi
      · cases h₂
        cases' lo with lo <;> cases' hi with hi <;> simp [lift] at *
        · apply lt_of_incomp_of_lt _ val_hi
          simp [*]
        · apply lt_of_lt_of_incomp lo_val
          simp [*]
        constructor
        · apply lt_of_lt_of_incomp lo_val
          simp [*]
        · apply lt_of_incomp_of_lt _ val_hi
          simp [*]
      · have h₃ : lift lt (some t_val) (some x) ∧ lift lt (some x) hi :=
          by
          apply t_ih_rchild
          assumption
          assumption
        cases' h₃ with val_x x_hi
        cases' lo with lo <;> cases' hi with hi <;> simp [lift] at *
        · assumption
        · apply trans_of lt lo_val val_x
        constructor
        · apply trans_of lt lo_val val_x
        · assumption
#align rbnode.range Rbnode.range

theorem lt_of_mem_left [IsStrictWeakOrder α lt] {y : α} {t l r : Rbnode α} :
    ∀ {lo hi}, IsSearchable lt t lo hi → IsNodeOf t l y r → ∀ {x}, Mem lt x l → lt x y :=
  by
  intro _ _ hs hn x hm; cases hn <;> cases hs
  all_goals exact (range hs_hs₁ hm).2
#align rbnode.lt_of_mem_left Rbnode.lt_of_mem_left

theorem lt_of_mem_right [IsStrictWeakOrder α lt] {y : α} {t l r : Rbnode α} :
    ∀ {lo hi}, IsSearchable lt t lo hi → IsNodeOf t l y r → ∀ {z}, Mem lt z r → lt y z :=
  by
  intro _ _ hs hn z hm; cases hn <;> cases hs
  all_goals exact (range hs_hs₂ hm).1
#align rbnode.lt_of_mem_right Rbnode.lt_of_mem_right

theorem lt_of_mem_left_right [IsStrictWeakOrder α lt] {y : α} {t l r : Rbnode α} :
    ∀ {lo hi},
      IsSearchable lt t lo hi → IsNodeOf t l y r → ∀ {x z}, Mem lt x l → Mem lt z r → lt x z :=
  by
  intro _ _ hs hn x z hm₁ hm₂; cases hn <;> cases hs
  all_goals
    have h₁ := range hs_hs₁ hm₁
    have h₂ := range hs_hs₂ hm₂
    exact trans_of lt h₁.2 h₂.1
#align rbnode.lt_of_mem_left_right Rbnode.lt_of_mem_left_right

end IsSearchableLemmas

inductive IsRedBlack : Rbnode α → Color → Nat → Prop
  | leaf_rb : is_red_black leaf black 0
  |
  red_rb {v l r n} (rb_l : is_red_black l black n) (rb_r : is_red_black r black n) :
    is_red_black (red_node l v r) red n
  |
  black_rb {v l r n c₁ c₂} (rb_l : is_red_black l c₁ n) (rb_r : is_red_black r c₂ n) :
    is_red_black (black_node l v r) black (succ n)
#align rbnode.is_red_black Rbnode.IsRedBlack

open IsRedBlack

theorem depth_min : ∀ {c n} {t : Rbnode α}, IsRedBlack t c n → n ≤ depth min t :=
  by
  intro c n' t h
  induction h
  case leaf_rb => exact le_refl _
  case red_rb =>
    simp [depth]
    have : min (depth min h_l) (depth min h_r) ≥ h_n := by apply le_min <;> assumption
    apply le_succ_of_le
    assumption
  case black_rb =>
    simp [depth]
    apply succ_le_succ
    apply le_min <;> assumption
#align rbnode.depth_min Rbnode.depth_min

private def upper : Color → Nat → Nat
  | red, n => 2 * n + 1
  | black, n => 2 * n
#align rbnode.upper rbnode.upper

private theorem upper_le : ∀ c n, upper c n ≤ 2 * n + 1
  | red, n => le_refl _
  | black, n => by apply le_succ
#align rbnode.upper_le rbnode.upper_le

theorem depth_max' : ∀ {c n} {t : Rbnode α}, IsRedBlack t c n → depth max t ≤ upper c n :=
  by
  intro c n' t h
  induction h
  case leaf_rb => simp [max, depth, upper, Nat.mul_zero]
  case
    red_rb =>
    suffices succ (max (depth max h_l) (depth max h_r)) ≤ 2 * h_n + 1 by simp_all [depth, upper]
    apply succ_le_succ
    apply max_le <;> assumption
  case
    black_rb =>
    have : depth max h_l ≤ 2 * h_n + 1 := le_trans h_ih_rb_l (upper_le _ _)
    have : depth max h_r ≤ 2 * h_n + 1 := le_trans h_ih_rb_r (upper_le _ _)
    suffices new : max (depth max h_l) (depth max h_r) + 1 ≤ 2 * h_n + 2 * 1
    · simp_all [depth, upper, succ_eq_add_one, Nat.left_distrib]
    apply succ_le_succ
    apply max_le <;> assumption
#align rbnode.depth_max' Rbnode.depth_max'

theorem depth_max {c n} {t : Rbnode α} (h : IsRedBlack t c n) : depth max t ≤ 2 * n + 1 :=
  le_trans (depth_max' h) (upper_le _ _)
#align rbnode.depth_max Rbnode.depth_max

theorem balanced {c n} {t : Rbnode α} (h : IsRedBlack t c n) : depth max t ≤ 2 * depth min t + 1 :=
  by
  have : 2 * depth min t + 1 ≥ 2 * n + 1 :=
    by
    apply succ_le_succ
    apply Nat.mul_le_mul_left
    apply depth_min h
  apply le_trans
  apply depth_max h
  apply this
#align rbnode.balanced Rbnode.balanced

end Rbnode


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((a3).read i3) ≠ (v1) → (a3) = ((a3).write i3 (v1)) → False := by
  arr


/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Compiler.LCNF.InferType

namespace Lean.Compiler.LCNF

/-!
# Compatible Types

We used to type check LCNF after each compiler pass. However, we disable this capability because cast management was too costly.
The casts may be needed to ensure the result of each pass is still typeable.
However, these sanity checks are useful for catching silly mistakes.
Thus, we have added an "LCNF type linter". When turned on, this "linter" option instructs the compiler to perform compatibility type checking
in the LCNF code after some compiler passes.
Recall most casts are only needed in functions that make heavy use of dependent types.
We claim it is "defensible" to say this sanity checker is a linter. If the sanity checker fails, it means the user is "abusing" dependent types
and performance may suffer at runtime.
Here is an example of code that "abuses" dependent types:
```
def Tuple (α : Type u) : Nat → Type u
  | 0   => PUnit
  | 1   => α
  | n+2 => α × Tuple α (n+1)

def mkConstTuple (a : α) : (n : Nat) → Tuple α n
  | 0 => ⟨⟩
  | 1 => a
  | n+2 => (a, mkConstTuple a (n+1))

def Tuple.map (f : α → β) (xs : Tuple α n) : Tuple β n :=
  match n with
  | 0 => ⟨⟩
  | 1 => f xs
  | _+2 => match xs with
    | (a, xs) => (f a, Tuple.map f xs)
```
-/

/--
Quick check for `compatibleTypes`. It is not monadic, but it is incomplete
because it does not eta-expand type formers. See comment at `compatibleTypes`.
Remark: if the result is `true`, then `a` and `b` are indeed compatible.
If it is `false`, we must use the full-check.
-/
partial def compatibleTypesQuick (a b : Expr) : Bool :=
  if a.isErased || b.isErased then
    true
  else
    let a' := a.headBeta
    let b' := b.headBeta
    if a != a' || b != b' then
      compatibleTypesQuick a' b'
    else if a == b then
      true
    else
      match a, b with
      -- Note that even after reducing to head-beta, we can still have `.app` terms. For example,
      -- an inductive constructor application such as `List Int`
      | .app f a, .app g b => compatibleTypesQuick f g && compatibleTypesQuick a b
      | .forallE _ d₁ b₁ _, .forallE _ d₂ b₂ _ => compatibleTypesQuick d₁ d₂ && compatibleTypesQuick b₁ b₂
      | .lam _ d₁ b₁ _, .lam _ d₂ b₂ _ => compatibleTypesQuick d₁ d₂ && compatibleTypesQuick b₁ b₂
      | .sort u, .sort v => Level.isEquiv u v
      | .const n us, .const m vs => n == m && List.isEqv us vs Level.isEquiv
      | _, _ => false

/--
Complete check for `compatibleTypes`. It eta-expands type formers. See comment at `compatibleTypes`.
-/
partial def InferType.compatibleTypesFull (a b : Expr) : InferTypeM Bool := do
  if a.isErased || b.isErased then
    return true
  else
    let a' := a.headBeta
    let b' := b.headBeta
    if a != a' || b != b' then
      compatibleTypesFull a' b'
    else if a == b then
      return true
    else
      match a, b with
      -- Note that even after reducing to head-beta, we can still have `.app` terms. For example,
      -- an inductive constructor application such as `List Int`
      | .app f a, .app g b => compatibleTypesFull f g <&&> compatibleTypesFull a b
      | .forallE n d₁ b₁ bi, .forallE _ d₂ b₂ _ =>
        unless (← compatibleTypesFull d₁ d₂) do return false
        withLocalDecl n d₁ bi fun x =>
          compatibleTypesFull (b₁.instantiate1 x) (b₂.instantiate1 x)
      | .lam n d₁ b₁ bi, .lam _ d₂ b₂ _ =>
        unless (← compatibleTypesFull d₁ d₂) do return false
        withLocalDecl n d₁ bi fun x =>
          compatibleTypesFull (b₁.instantiate1 x) (b₂.instantiate1 x)
      | .sort u, .sort v => return Level.isEquiv u v
      | .const n us, .const m vs => return n == m && List.isEqv us vs Level.isEquiv
      | _, _ =>
        if a.isLambda then
          let some b ← etaExpand? b | return false
          compatibleTypesFull a b
        else if b.isLambda then
          let some a ← etaExpand? a | return false
          compatibleTypesFull a b
        else
          return false
where
  etaExpand? (e : Expr) : InferTypeM (Option Expr) := do
    match (← inferType e).headBeta with
    | .forallE n d _ bi =>
      /-
      In principle, `.app e (.bvar 0)` may not be a valid LCNF type sub-expression
      because `d` may not be a type former type, See remark `compatibleTypes` for
      a justification why this is ok.
      -/
      return some (.lam n d (.app e (.bvar 0)) bi)
    | _ => return none

/--
Return true if the LCNF types `a` and `b` are compatible.
Remark: `a` and `b` can be type formers (e.g., `List`, or `fun (α : Type) => Nat → Nat × α`)
Remark: We may need to eta-expand type formers to establish whether they are compatible or not.
For example, suppose we have
```
fun (x : B) => Id B ◾ ◾
Id B ◾
```
We must eta-expand `Id B ◾` to `fun (x : B) => Id B ◾ x`. Note that, we use `x` instead of `◾` to
make the implementation simpler and skip the check whether `B` is a type former type. However,
this simplification should not affect correctness since `◾` is compatible with everything.
Remark: see comment at `isErasedCompatible`.
Remark: because of "erasure confusion" see note above, we assume `◾` (aka `lcErasure`) is compatible with everything.
This is a simplification. We used to use `isErasedCompatible`, but this only address item 1.
For item 2, we would have to modify the `toLCNFType` function and make sure a type former is erased if the expected
type is not always a type former (see `S.mk` type and example in the note above).
-/
def InferType.compatibleTypes (a b : Expr) : InferTypeM Bool := do
  if compatibleTypesQuick a b then
    return true
  else
    compatibleTypesFull a b

end Lean.Compiler.LCNF