/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Daniel Selsam
-/
import Lean.Data.RBMap
import Lean.Meta.SynthInstance
import Lean.Util.FindMVar
import Lean.Util.FindLevelMVar
import Lean.Util.CollectLevelParams
import Lean.Util.ReplaceLevel
import Lean.PrettyPrinter.Delaborator.Options
import Lean.PrettyPrinter.Delaborator.SubExpr
import Lean.Elab.Config

/-!
The top-down analyzer is an optional preprocessor to the delaborator that aims
to determine the minimal annotations necessary to ensure that the delaborated
expression can be re-elaborated correctly. Currently, the top-down analyzer
is neither sound nor complete: there may be edge-cases in which the expression
can still not be re-elaborated correctly, and it may also add many annotations
that are not strictly necessary.
-/

namespace Lean
open Meta SubExpr

register_builtin_option pp.analyze : Bool := {
  defValue := false
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) determine annotations sufficient to ensure round-tripping"
}

register_builtin_option pp.analyze.checkInstances : Bool := {
  -- TODO: It would be great to make this default to `true`, but currently, `MessageData` does not
  -- include the `LocalInstances`, so this will be very over-aggressive in inserting instances
  -- that would otherwise be easy to synthesize. We may consider threading the instances in the future,
  -- or at least tracking a bool for whether the instances have been lost.
  defValue := false
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) confirm that instances can be re-synthesized"
}

register_builtin_option pp.analyze.typeAscriptions : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) add type ascriptions when deemed necessary"
}

register_builtin_option pp.analyze.trustSubst : Bool := {
  defValue := false
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) always 'pretend' applications that can delab to ▸ are 'regular'"
}

register_builtin_option pp.analyze.trustOfNat : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) always 'pretend' `OfNat.ofNat` applications can elab bottom-up"
}

register_builtin_option pp.analyze.trustOfScientific : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) always 'pretend' `OfScientific.ofScientific` applications can elab bottom-up"
}

-- TODO: this is an arbitrary special case of a more general principle.
register_builtin_option pp.analyze.trustSubtypeMk : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) assume the implicit arguments of Subtype.mk can be inferred"
}

register_builtin_option pp.analyze.trustId : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) always assume an implicit `fun x => x` can be inferred"
}

register_builtin_option pp.analyze.trustKnownFOType2TypeHOFuns : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) omit higher-order functions whose values seem to be knownType2Type"
}

register_builtin_option pp.analyze.omitMax : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) omit universe `max` annotations (these constraints can actually hurt)"
}

register_builtin_option pp.analyze.knowsType : Bool := {
  defValue := true
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) assume the type of the original expression is known"
}

register_builtin_option pp.analyze.explicitHoles : Bool := {
  defValue := false
  group    := "pp.analyze"
  descr    := "(pretty printer analyzer) use `_` for explicit arguments that can be inferred"
}

def getPPAnalyze                            (o : Options) : Bool := o.get pp.analyze.name pp.analyze.defValue
def getPPAnalyzeCheckInstances              (o : Options) : Bool := o.get pp.analyze.checkInstances.name pp.analyze.checkInstances.defValue
def getPPAnalyzeTypeAscriptions             (o : Options) : Bool := o.get pp.analyze.typeAscriptions.name pp.analyze.typeAscriptions.defValue
def getPPAnalyzeTrustSubst                  (o : Options) : Bool := o.get pp.analyze.trustSubst.name pp.analyze.trustSubst.defValue
def getPPAnalyzeTrustOfNat                  (o : Options) : Bool := o.get pp.analyze.trustOfNat.name pp.analyze.trustOfNat.defValue
def getPPAnalyzeTrustOfScientific           (o : Options) : Bool := o.get pp.analyze.trustOfScientific.name pp.analyze.trustOfScientific.defValue
def getPPAnalyzeTrustId                     (o : Options) : Bool := o.get pp.analyze.trustId.name pp.analyze.trustId.defValue
def getPPAnalyzeTrustSubtypeMk              (o : Options) : Bool := o.get pp.analyze.trustSubtypeMk.name pp.analyze.trustSubtypeMk.defValue
def getPPAnalyzeTrustKnownFOType2TypeHOFuns (o : Options) : Bool := o.get pp.analyze.trustKnownFOType2TypeHOFuns.name pp.analyze.trustKnownFOType2TypeHOFuns.defValue
def getPPAnalyzeOmitMax                     (o : Options) : Bool := o.get pp.analyze.omitMax.name pp.analyze.omitMax.defValue
def getPPAnalyzeKnowsType                   (o : Options) : Bool := o.get pp.analyze.knowsType.name pp.analyze.knowsType.defValue
def getPPAnalyzeExplicitHoles               (o : Options) : Bool := o.get pp.analyze.explicitHoles.name pp.analyze.explicitHoles.defValue

def getPPAnalysisSkip            (o : Options) : Bool := o.get `pp.analysis.skip false
def getPPAnalysisHole            (o : Options) : Bool := o.get `pp.analysis.hole false
def getPPAnalysisNamedArg        (o : Options) : Bool := o.get `pp.analysis.namedArg false
def getPPAnalysisLetVarType      (o : Options) : Bool := o.get `pp.analysis.letVarType false
def getPPAnalysisNeedsType       (o : Options) : Bool := o.get `pp.analysis.needsType false
def getPPAnalysisBlockImplicit   (o : Options) : Bool := o.get `pp.analysis.blockImplicit false

namespace PrettyPrinter.Delaborator

def returnsPi (motive : Expr) : MetaM Bool := do
  lambdaTelescope motive fun _ b => return b.isForall

def isNonConstFun (motive : Expr) : MetaM Bool := do
  match motive with
  | Expr.lam _    _ b _ => isNonConstFun b
  | _ => return motive.hasLooseBVars

def isSimpleHOFun (motive : Expr) : MetaM Bool :=
  return not (← returnsPi motive) && not (← isNonConstFun motive)

def isType2Type (motive : Expr) : MetaM Bool := do
  match ← inferType motive with
  | Expr.forallE _ (Expr.sort ..) (Expr.sort ..) .. => return true
  | _ => return false

def isFOLike (motive : Expr) : MetaM Bool := do
  let f := motive.getAppFn
  return f.isFVar || f.isConst

def isIdLike (arg : Expr) : Bool :=
  -- TODO: allow `id` constant as well?
  match arg with
  | Expr.lam _ _ (Expr.bvar ..) .. => true
  | _ => false

def isStructureInstance (e : Expr) : MetaM Bool := do
  match e.isConstructorApp? (← getEnv) with
  | some s => return isStructure (← getEnv) s.induct
  | none   => return false

namespace TopDownAnalyze

partial def hasMVarAtCurrDepth (e : Expr) : MetaM Bool := do
  let mctx ← getMCtx
  return Option.isSome <| e.findMVar? fun mvarId =>
    match mctx.findDecl? mvarId with
    | some mdecl => mdecl.depth == mctx.depth
    | _ => false

partial def hasLevelMVarAtCurrDepth (e : Expr) : MetaM Bool := do
  let mctx ← getMCtx
  return Option.isSome <| e.findLevelMVar? fun mvarId =>
    mctx.findLevelDepth? mvarId == some mctx.depth

private def valUnknown (e : Expr) : MetaM Bool := do
  hasMVarAtCurrDepth (← instantiateMVars e)

private def typeUnknown (e : Expr) : MetaM Bool := do
  valUnknown (← inferType e)

def isHBinOp (e : Expr) : Bool := Id.run do
  -- TODO: instead of tracking these explicitly,
  -- consider a more general solution that checks for defaultInstances
  if e.getAppNumArgs != 6 then return false
  let f := e.getAppFn
  if !f.isConst then return false

  -- Note: we leave out `HPow.hPow because we expect its homogeneous
  -- version will change soon
  let ops := #[
    `HOr.hOr, `HXor.hXor, `HAnd.hAnd,
    `HAppend.hAppend, `HOrElse.hOrElse, `HAndThen.hAndThen,
    `HAdd.hAdd, `HSub.hSub, `HMul.hMul, `HDiv.hDiv, `HMod.hMod,
    `HShiftLeft.hShiftLeft, `HShiftRight]
  ops.any fun op => op == f.constName!

def replaceLPsWithVars (e : Expr) : MetaM Expr := do
  if !e.hasLevelParam then return e
  let lps := collectLevelParams {} e |>.params
  let mut replaceMap : HashMap Name Level := {}
  for lp in lps do replaceMap := replaceMap.insert lp (← mkFreshLevelMVar)
  return e.replaceLevel fun
    | Level.param n .. => replaceMap.find! n
    | l => if !l.hasParam then some l else none

def isDefEqAssigning (t s : Expr) : MetaM Bool := do
  withReader (fun ctx => { ctx with config := { ctx.config with assignSyntheticOpaque := true }}) $
    Meta.isDefEq t s

def checkpointDefEq (t s : Expr) : MetaM Bool := do
  Meta.checkpointDefEq (mayPostpone := false) do
    isDefEqAssigning t s

def isHigherOrder (type : Expr) : MetaM Bool := do
  forallTelescopeReducing type fun xs b => return xs.size > 0 && b.isSort

def isFunLike (e : Expr) : MetaM Bool := do
  forallTelescopeReducing (← inferType e) fun xs _ => return xs.size > 0

def isSubstLike (e : Expr) : Bool :=
  e.isAppOfArity ``Eq.ndrec 6 || e.isAppOfArity ``Eq.rec 6

def nameNotRoundtrippable (n : Name) : Bool :=
  n.hasMacroScopes || isPrivateName n || containsNum n
where
  containsNum
    | Name.str p .. => containsNum p
    | Name.num ..   => true
    | Name.anonymous => false

def mvarName (mvar : Expr) : MetaM Name :=
  return (←  mvar.mvarId!.getDecl).userName

def containsBadMax : Level → Bool
  | Level.succ u ..   => containsBadMax u
  | Level.max u v ..  => (u.hasParam && v.hasParam) || containsBadMax u || containsBadMax v
  | Level.imax u v .. => (u.hasParam && v.hasParam) || containsBadMax u || containsBadMax v
  | _                 => false

open SubExpr

structure Context where
  knowsType   : Bool
  knowsLevel  : Bool -- only constants look at this
  inBottomUp  : Bool := false
  parentIsApp : Bool := false
  subExpr     : SubExpr
  deriving Inhabited

structure State where
  annotations : OptionsPerPos := {}
  postponed   : Array (Expr × Expr) := #[] -- not currently used

abbrev AnalyzeM := ReaderT Context (StateRefT State MetaM)

instance (priority := low) : MonadReaderOf SubExpr AnalyzeM where
  read := Context.subExpr <$> read

instance (priority := low) : MonadWithReaderOf SubExpr AnalyzeM where
  withReader f x := fun ctx => x { ctx with subExpr := f ctx.subExpr }

def tryUnify (e₁ e₂ : Expr) : AnalyzeM Unit := do
  try
    let r ← isDefEqAssigning e₁ e₂
    if !r then modify fun s => { s with postponed := s.postponed.push (e₁, e₂) }
    pure ()
  catch _ =>
    modify fun s => { s with postponed := s.postponed.push (e₁, e₂) }

partial def inspectOutParams (arg mvar : Expr) : AnalyzeM Unit := do
  let argType  ← inferType arg -- HAdd α α α
  let mvarType ← inferType mvar
  let fType ← inferType argType.getAppFn -- Type → Type → outParam Type
  let mType ← inferType mvarType.getAppFn
  inspectAux fType mType 0 argType.getAppArgs mvarType.getAppArgs
where
  inspectAux (fType mType : Expr) (i : Nat) (args mvars : Array Expr) := do
    let fType ← whnf fType
    let mType ← whnf mType
    if not (i < args.size) then return ()
    match fType, mType with
    | Expr.forallE _ fd fb _, Expr.forallE _ _  mb _ => do
      -- TODO: do I need to check (← okBottomUp? args[i] mvars[i] fuel).isSafe here?
      -- if so, I'll need to take a callback
      if fd.isOutParam then
        tryUnify (args[i]!) (mvars[i]!)
      inspectAux (fb.instantiate1 args[i]!) (mb.instantiate1 mvars[i]!) (i+1) args mvars
    | _, _ => return ()

partial def isTrivialBottomUp (e : Expr) : AnalyzeM Bool := do
  let opts ← getOptions
  return e.isFVar
         || e.isConst || e.isMVar || e.isNatLit || e.isStringLit || e.isSort
         || (getPPAnalyzeTrustOfNat opts && e.isAppOfArity ``OfNat.ofNat 3)
         || (getPPAnalyzeTrustOfScientific opts && e.isAppOfArity ``OfScientific.ofScientific 5)

partial def canBottomUp (e : Expr) (mvar? : Option Expr := none) (fuel : Nat := 10) : AnalyzeM Bool := do
  -- Here we check if `e` can be safely elaborated without its expected type.
  -- These are incomplete (and possibly unsound) heuristics.
  -- TODO: do I need to snapshot the state before calling this?
  match fuel with
  | 0 => return false
  | fuel + 1 =>
    if ← isTrivialBottomUp e then return true
    let f := e.getAppFn
    if !f.isConst && !f.isFVar then return false
    let args := e.getAppArgs
    let fType ← replaceLPsWithVars (← inferType e.getAppFn)
    let (mvars, bInfos, resultType) ← forallMetaBoundedTelescope fType e.getAppArgs.size
    for i in [:mvars.size] do
      if bInfos[i]! == BinderInfo.instImplicit then
        inspectOutParams args[i]! mvars[i]!
      else if bInfos[i]! == BinderInfo.default then
        if ← isTrivialBottomUp args[i]! then tryUnify args[i]! mvars[i]!
        else if ← typeUnknown mvars[i]! <&&> canBottomUp args[i]! (some mvars[i]!) fuel then tryUnify args[i]! mvars[i]!
    if ← (pure (isHBinOp e) <&&> (valUnknown mvars[0]! <||> valUnknown mvars[1]!)) then tryUnify mvars[0]! mvars[1]!
    if mvar?.isSome then tryUnify resultType (← inferType mvar?.get!)
    return !(← valUnknown resultType)

def withKnowing (knowsType knowsLevel : Bool) (x : AnalyzeM α) : AnalyzeM α := do
  withReader (fun ctx => { ctx with knowsType := knowsType, knowsLevel := knowsLevel }) x

builtin_initialize analyzeFailureId : InternalExceptionId ← registerInternalExceptionId `analyzeFailure

def checkKnowsType : AnalyzeM Unit := do
  if not (← read).knowsType then
    throw $ Exception.internal analyzeFailureId

def annotateBoolAt (n : Name) (pos : Pos) : AnalyzeM Unit := do
  let opts := (← get).annotations.findD pos {} |>.setBool n true
  trace[pp.analyze.annotate] "{pos} {n}"
  modify fun s => { s with annotations := s.annotations.insert pos opts }

def annotateBool (n : Name) : AnalyzeM Unit := do
  annotateBoolAt n (← getPos)

structure App.Context where
  f               : Expr
  fType           : Expr
  args            : Array Expr
  mvars           : Array Expr
  bInfos          : Array BinderInfo
  forceRegularApp : Bool

structure App.State where
  bottomUps       : Array Bool
  higherOrders    : Array Bool
  funBinders      : Array Bool
  provideds       : Array Bool
  namedArgs       : Array Name := #[]

abbrev AnalyzeAppM := ReaderT App.Context (StateT App.State AnalyzeM)

mutual

  partial def analyze (parentIsApp : Bool := false) : AnalyzeM Unit := do
    checkMaxHeartbeats "Delaborator.topDownAnalyze"
    trace[pp.analyze] "{(← read).knowsType}.{(← read).knowsLevel}"
    let e ← getExpr
    let opts ← getOptions
    if ← (pure !e.isAtomic) <&&> pure !(getPPProofs opts) <&&> (try Meta.isProof e catch _ => pure false) then
      if getPPProofsWithType opts then
        withType $ withKnowing true true $ analyze
      return ()
    else
      withReader (fun ctx => { ctx with parentIsApp := parentIsApp }) do
        match (← getExpr) with
        | Expr.app ..     => analyzeApp
        | Expr.forallE .. => analyzePi
        | Expr.lam ..     => analyzeLam
        | Expr.const ..   => analyzeConst
        | Expr.sort ..    => analyzeSort
        | Expr.proj ..    => analyzeProj
        | Expr.fvar ..    => analyzeFVar
        | Expr.mdata ..   => analyzeMData
        | Expr.letE ..    => analyzeLet
        | Expr.lit ..     => pure ()
        | Expr.mvar ..    => pure ()
        | Expr.bvar ..    => pure ()
  where
    analyzeApp := do
      let mut willKnowType := (← read).knowsType
      if !(← read).knowsType && !(← canBottomUp (← getExpr)) then
        annotateBool `pp.analysis.needsType
        withType $ withKnowing true false $ analyze
        willKnowType := true

      else if ← (pure !(← read).knowsType <||> pure (← read).inBottomUp) <&&> isStructureInstance (← getExpr) then
        withType do
          annotateBool `pp.structureInstanceTypes
          withKnowing true false $ analyze
        willKnowType := true

      withKnowing willKnowType true $ analyzeAppStaged (← getExpr).getAppFn (← getExpr).getAppArgs

    analyzeAppStaged (f : Expr) (args : Array Expr) : AnalyzeM Unit := do
      let fType ← replaceLPsWithVars (← inferType f)
      let (mvars, bInfos, resultType) ← forallMetaBoundedTelescope fType args.size
      let rest := args.extract mvars.size args.size
      let args := args.shrink mvars.size

      -- Unify with the expected type
      if (← read).knowsType then tryUnify (← inferType (mkAppN f args)) resultType

      let forceRegularApp : Bool :=
        (getPPAnalyzeTrustSubst (← getOptions) && isSubstLike (← getExpr))
        || (getPPAnalyzeTrustSubtypeMk (← getOptions) && (← getExpr).isAppOfArity ``Subtype.mk 4)

      analyzeAppStagedCore { f, fType, args, mvars, bInfos, forceRegularApp } |>.run' {
        bottomUps    := mkArray args.size false,
        higherOrders := mkArray args.size false,
        provideds    := mkArray args.size false,
        funBinders   := mkArray args.size false
      }

      if not rest.isEmpty then
        -- Note: this shouldn't happen for type-correct terms
        if !args.isEmpty then
          analyzeAppStaged (mkAppN f args) rest

    maybeAddBlockImplicit : AnalyzeM Unit := do
      -- See `MonadLift.noConfusion for an example where this is necessary.
      if !(← read).parentIsApp then
        let type ← inferType (← getExpr)
        if type.isForall && type.bindingInfo! == BinderInfo.implicit then
          annotateBool `pp.analysis.blockImplicit

    analyzeConst : AnalyzeM Unit := do
      let Expr.const _ ls .. ← getExpr | unreachable!
      if !(← read).knowsLevel && !ls.isEmpty then
        -- TODO: this is a very crude heuristic, motivated by https://github.com/leanprover/lean4/issues/590
        unless getPPAnalyzeOmitMax (← getOptions) && ls.any containsBadMax do
        annotateBool `pp.universes
      maybeAddBlockImplicit

    analyzePi : AnalyzeM Unit := do
      withBindingDomain $ withKnowing true false analyze
      withBindingBody Name.anonymous analyze

    analyzeLam : AnalyzeM Unit := do
      if !(← read).knowsType then annotateBool `pp.funBinderTypes
      withBindingDomain $ withKnowing true false analyze
      withBindingBody Name.anonymous analyze

    analyzeLet : AnalyzeM Unit := do
      let Expr.letE _ _ v _    .. ← getExpr | unreachable!
      if !(← canBottomUp v) then
        annotateBool `pp.analysis.letVarType
        withLetVarType $ withKnowing true false analyze
        withLetValue $ withKnowing true true analyze
      else
        withReader (fun ctx => { ctx with inBottomUp := true }) do
          withLetValue $ withKnowing true true analyze

      withLetBody analyze

    analyzeSort  : AnalyzeM Unit := pure ()
    analyzeProj  : AnalyzeM Unit := withProj analyze
    analyzeFVar  : AnalyzeM Unit := maybeAddBlockImplicit
    analyzeMData : AnalyzeM Unit := withMDataExpr analyze

  partial def analyzeAppStagedCore : AnalyzeAppM Unit := do
    collectBottomUps
    checkOutParams
    collectHigherOrders
    hBinOpHeuristic
    collectTrivialBottomUps
    discard <| processPostponed (mayPostpone := true)
    applyFunBinderHeuristic
    analyzeFn
    for i in [:(← read).args.size] do analyzeArg i
    maybeSetExplicit

  where
    collectBottomUps := do
      let { args, mvars, bInfos, ..} ← read
      for target in [fun _ => none, fun i => some mvars[i]!] do
        for i in [:args.size] do
          if bInfos[i]! == BinderInfo.default then
            if ← typeUnknown mvars[i]! <&&> canBottomUp args[i]! (target i) then
              tryUnify args[i]! mvars[i]!
              modify fun s => { s with bottomUps := s.bottomUps.set! i true }

    checkOutParams := do
      let { args, mvars, bInfos, ..} ← read
      for i in [:args.size] do
        if bInfos[i]! == BinderInfo.instImplicit then inspectOutParams args[i]! mvars[i]!

    collectHigherOrders := do
      let { args, mvars, bInfos, ..} ← read
      for i in [:args.size] do
        if not (bInfos[i]! == BinderInfo.implicit || bInfos[i]! == BinderInfo.strictImplicit) then continue
        if not (← isHigherOrder (← inferType args[i]!)) then continue
        if getPPAnalyzeTrustId (← getOptions) && isIdLike args[i]! then continue

        if getPPAnalyzeTrustKnownFOType2TypeHOFuns (← getOptions) && not (← valUnknown mvars[i]!)
          && (← isType2Type (args[i]!)) && (← isFOLike (args[i]!)) then continue

        tryUnify args[i]! mvars[i]!
        modify fun s => { s with higherOrders := s.higherOrders.set! i true }

    hBinOpHeuristic := do
      let { mvars, ..} ← read
      if ← (pure (isHBinOp (← getExpr)) <&&> (valUnknown mvars[0]! <||> valUnknown mvars[1]!)) then
        tryUnify mvars[0]! mvars[1]!

    collectTrivialBottomUps := do
      -- motivation: prevent levels from printing in
      -- Boo.mk : {α : Type u_1} → {β : Type u_2} → α → β → Boo.{u_1, u_2} α β
      let { args, mvars, bInfos, ..} ← read
      for i in [:args.size] do
        if bInfos[i]! == BinderInfo.default then
          if ← valUnknown mvars[i]! <&&> isTrivialBottomUp args[i]! then
            tryUnify args[i]! mvars[i]!
            modify fun s => { s with bottomUps := s.bottomUps.set! i true }

    applyFunBinderHeuristic := do
      let { args, mvars, bInfos, .. } ← read

      let rec core (argIdx : Nat) (mvarType : Expr) : AnalyzeAppM Bool := do
        match ← getExpr, mvarType with
        | Expr.lam .., Expr.forallE _ t b .. =>
          let mut annotated := false
          for i in [:argIdx] do
            if ← pure (bInfos[i]! == BinderInfo.implicit) <&&> valUnknown mvars[i]! <&&> withNewMCtxDepth (checkpointDefEq t mvars[i]!) then
              annotateBool `pp.funBinderTypes
              tryUnify args[i]! mvars[i]!
              -- Note: currently we always analyze the lambda binding domains in `analyzeLam`
              -- (so we don't need to analyze it again here)
              annotated := true
              break
          let annotatedBody ← withBindingBody Name.anonymous (core argIdx b)
          return annotated || annotatedBody

        | _, _ => return false

      for i in [:args.size] do
        if bInfos[i]! == BinderInfo.default then
          let b ← withNaryArg i (core i (← inferType mvars[i]!))
          if b then modify fun s => { s with funBinders := s.funBinders.set! i true }

    analyzeFn := do
      -- Now, if this is the first staging, analyze the n-ary function without expected type
      let {f, fType, forceRegularApp ..} ← read
      if !f.isApp then withKnowing false (forceRegularApp || !(← hasLevelMVarAtCurrDepth (← instantiateMVars fType))) $ withNaryFn (analyze (parentIsApp := true))

    annotateNamedArg (n : Name) : AnalyzeAppM Unit := do
      annotateBool `pp.analysis.namedArg
      modify fun s => { s with namedArgs := s.namedArgs.push n }

    analyzeArg (i : Nat) := do
      let { f, args, mvars, bInfos, forceRegularApp ..} ← read
      let { bottomUps, higherOrders, funBinders, ..} ← get
      let arg := args[i]!
      let argType ← inferType arg

      let processNaturalImplicit : AnalyzeAppM Unit := do
        if (← valUnknown mvars[i]! <||> pure higherOrders[i]!) && !forceRegularApp then
          annotateNamedArg (← mvarName mvars[i]!)
          modify fun s => { s with provideds := s.provideds.set! i true }
        else
          annotateBool `pp.analysis.skip

      withNaryArg (f.getAppNumArgs + i) do
        withTheReader Context (fun ctx => { ctx with inBottomUp := ctx.inBottomUp || bottomUps[i]! }) do

          match bInfos[i]! with
          | BinderInfo.default =>
            if ← pure (getPPAnalyzeExplicitHoles (← getOptions)) <&&> pure !(← valUnknown mvars[i]!) <&&> pure !(← readThe Context).inBottomUp <&&> pure !(← isFunLike arg) <&&> pure !funBinders[i]! <&&> checkpointDefEq mvars[i]! arg then
              annotateBool `pp.analysis.hole
            else
              modify fun s => { s with provideds := s.provideds.set! i true }

          | BinderInfo.implicit => processNaturalImplicit
          | BinderInfo.strictImplicit => processNaturalImplicit

          | BinderInfo.instImplicit =>
            -- Note: apparently checking valUnknown here is not sound, because the elaborator
            -- will not happily assign instImplicits that it cannot synthesize
            let mut provided := true
            if !getPPInstances (← getOptions) then
              annotateBool `pp.analysis.skip
              provided := false
            else if getPPAnalyzeCheckInstances (← getOptions) then
              let instResult ← try trySynthInstance argType catch _ => pure LOption.undef
              match instResult with
              | LOption.some inst =>
                if ← checkpointDefEq inst arg then annotateBool `pp.analysis.skip; provided := false
                else annotateNamedArg (← mvarName mvars[i]!)
              | _                 => annotateNamedArg (← mvarName mvars[i]!)
            else annotateBool `pp.analysis.skip; provided := false
            modify fun s => { s with provideds := s.provideds.set! i provided }
          if (← get).provideds[i]! then withKnowing (not (← typeUnknown mvars[i]!)) true analyze
          tryUnify mvars[i]! args[i]!

    maybeSetExplicit := do
      let { f, args, bInfos, ..} ← read
      if (← get).namedArgs.any nameNotRoundtrippable then
        annotateBool `pp.explicit
        for i in [:args.size] do
          if !(← get).provideds[i]! then
            withNaryArg (f.getAppNumArgs + i) do annotateBool `pp.analysis.hole
          if bInfos[i]! == BinderInfo.instImplicit && getPPInstanceTypes (← getOptions) then
            withType (withKnowing true false analyze)

end

end TopDownAnalyze

open TopDownAnalyze SubExpr

def topDownAnalyze (e : Expr) : MetaM OptionsPerPos := do
  let s₀ ← get
  withTraceNode `pp.analyze (fun _ => return e) do
    withReader (fun ctx => { ctx with config := Elab.Term.setElabConfig ctx.config }) do
      let ϕ : AnalyzeM OptionsPerPos := do withNewMCtxDepth analyze; pure (← get).annotations
      try
        let knowsType := getPPAnalyzeKnowsType (← getOptions)
        ϕ { knowsType := knowsType, knowsLevel := knowsType, subExpr := mkRoot e }
          |>.run' { : TopDownAnalyze.State }
      catch e =>
        trace[pp.analyze.error] "failed {e.toMessageData}"
        pure {}
      finally set s₀

builtin_initialize
  registerTraceClass `pp.analyze
  registerTraceClass `pp.analyze.annotate (inherited := true)
  registerTraceClass `pp.analyze.tryUnify (inherited := true)
  registerTraceClass `pp.analyze.error (inherited := true)

end Lean.PrettyPrinter.Delaborator


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

Elaborator for the Lean language: takes commands and produces side effects
-/
prelude
import init.lean.parser.module
import init.lean.expander
import init.lean.expr
import init.lean.options
import init.lean.environment

namespace Lean
-- deprecated Constructor
@[extern "lean_expr_local"]
constant Expr.local (n : Name) (pp : Name) (ty : Expr) (bi : BinderInfo) : Expr := default Expr

namespace Elaborator
-- TODO(Sebastian): move
-- TODO(Sebastian): should be its own Monad?
structure NameGenerator :=
(«prefix» : Name)
(nextIdx : UInt32)

structure SectionVar :=
(uniqName : Name)
(BinderInfo : BinderInfo)
(type : Expr)

/-- Simplified State of the Lean 3 Parser. Maps are replaced with lists for easier interop. -/
structure OldElaboratorState :=
(env : Environment)
(ngen : NameGenerator)
(univs : List (Name × Level))
(vars : List (Name × SectionVar))
(includeVars : List Name)
(Options : Options)
(nextInstIdx : Nat)
(ns : Name)

@[extern "lean_elaborator_elaborate_command"]
constant elaborateCommand (filename : @& String) (e : Expr) (s : @& OldElaboratorState) : Option OldElaboratorState × MessageLog := (none, ⟨[]⟩)

open Parser
open Parser.Combinators
open Parser.Term
open Parser.command
open Parser.command.NotationSpec
open Expander

-- TODO(Sebastian): move
/-- An RBMap that remembers the insertion order. -/
structure OrderedRBMap (α β : Type) (lt : α → α → Bool) :=
(entries : List (α × β))
(map : RBMap α (Nat × β) lt)
(size : Nat)

namespace OrderedRBMap
variables {α β : Type} {lt : α → α → Bool} (m : OrderedRBMap α β lt)

def empty : OrderedRBMap α β lt := {entries := [], map := mkRBMap _ _ _, size := 0}

def insert (k : α) (v : β) : OrderedRBMap α β lt :=
{entries := (k, v)::m.entries, map := m.map.insert k (m.size, v), size := m.size + 1}

def find (a : α) : Option (Nat × β) :=
m.map.find a

def ofList (l : List (α × β)) : OrderedRBMap α β lt :=
l.foldl (λ m p, OrderedRBMap.insert m (Prod.fst p) (Prod.snd p)) OrderedRBMap.empty
end OrderedRBMap

structure ElaboratorConfig extends FrontendConfig :=
(initialParserCfg : ModuleParserConfig)

instance elaboratorConfigCoeFrontendConfig : HasCoe ElaboratorConfig FrontendConfig :=
⟨ElaboratorConfig.toFrontendConfig⟩

/-- Elaborator State that will be reverted at the end of a section or namespace. -/
structure Scope :=
-- "section" or "namespace" (or "MODULE"), currently
(cmd : String)
-- Scope header, should match identifier after `end`. Can be `Name.anonymous` for sections.
(header : Name)
(notations : List NotationMacro := [])
/- The set of local universe variables.
   We remember their insertion order so that we can keep the order when copying them to declarations. -/
(univs : OrderedRBMap Name Level Name.quickLt := OrderedRBMap.empty)
/- The set of local variables. -/
(vars : OrderedRBMap Name SectionVar Name.quickLt := OrderedRBMap.empty)
/- The subset of `vars` that is tagged as always included. -/
(includeVars : RBTree Name Name.quickLt := mkRBTree _ _)
/- The stack of nested active `namespace` commands. -/
(nsStack : List Name := [])
/- The set of active `open` declarations. -/
(openDecls : List openSpec.View := [])
(Options : Options := {})

/-- An `export` command together with the namespace it was declared in. Opening the namespace activates
    the export. -/
structure ScopedExportDecl :=
(inNs : Name)
(spec : openSpec.View)

structure ElaboratorState :=
-- TODO(Sebastian): retrieve from environment
(reservedNotations : List reserveNotation.View := [])
(notations : List NotationMacro := [])
(notationCounter := 0)
/- The current set of `export` declarations (active or inactive). -/
(exportDecls : List ScopedExportDecl := [])

-- Stack of current scopes. The bottom-most Scope is the Module Scope.
(scopes : List Scope)
(messages : MessageLog := MessageLog.empty)
(parserCfg : ModuleParserConfig)
(expanderCfg : Expander.ExpanderConfig)
(env : Environment)
(ngen : NameGenerator)
(nextInstIdx : Nat := 0)

@[derive Monad MonadRec MonadReader MonadState MonadExcept]
def ElaboratorM := RecT Syntax Unit $ ReaderT ElaboratorConfig $ StateT ElaboratorState $ ExceptT Message Id
abbrev Elaborator := Syntax → ElaboratorM Unit

instance elaboratorInh (α : Type) : Inhabited (ElaboratorM α) :=
⟨λ _ _ _, Except.error (default _)⟩

/-- Recursively elaborate any command. -/
def command.elaborate : Elaborator := recurse

def currentScope : ElaboratorM Scope := do
  st ← get,
  match st.scopes with
  | [] := error none "currentScope: unreachable"
  | sc::_ := pure sc

def modifyCurrentScope (f : Scope → Scope) : ElaboratorM Unit := do
  st ← get,
  match st.scopes with
  | [] := error none "modifyCurrentScope: unreachable"
  | sc::scs := set {st with scopes := f sc::scs}

def mangleIdent (id : SyntaxIdent) : Name :=
id.scopes.foldl Name.mkNumeral id.val

partial def levelGetAppArgs : Syntax → ElaboratorM (Syntax × List Syntax)
| stx := do
  match stx.kind with
  | some Level.leading := pure (stx, [])
  | some Level.trailing := match view Level.trailing stx with
    | Level.trailing.View.app lta := do
      (fn, args) ← levelGetAppArgs lta.fn,
      pure (fn, lta.Arg :: args)
    | Level.trailing.View.addLit _ := pure (stx, [])
  | _ := error stx $ "levelGetAppArgs: unexpected input: " ++ toString stx

def levelAdd : Level → Nat → Level
| l 0     := l
| l (n+1) := (levelAdd l n).succ

partial def toLevel : Syntax → ElaboratorM Level
| stx := do
  (fn, args) ← levelGetAppArgs stx,
  sc ← currentScope,
  match fn.kind with
  | some Level.leading := match view Level.leading fn, args with
    | Level.leading.View.hole _, [] := pure $ Level.mvar Name.anonymous
    | Level.leading.View.lit lit, [] := pure $ Level.ofNat lit.toNat
    | Level.leading.View.var id, [] := let id := mangleIdent id in match sc.univs.find id with
      | some _ := pure $ Level.Param id
      | none   := error stx $ "unknown universe variable '" ++ toString id ++ "'"
    | Level.leading.View.max _, (Arg::args) := List.foldr Level.max <$> toLevel Arg <*> args.mmap toLevel
    | Level.leading.View.imax _, (Arg::args) := List.foldr Level.imax <$> toLevel Arg <*> args.mmap toLevel
    | _, _ := error stx "ill-formed universe Level"
  | some Level.trailing := match view Level.trailing fn, args with
    | Level.trailing.View.addLit lta, [] := do
      l ← toLevel lta.lhs,
      pure $ levelAdd l lta.rhs.toNat
    | _, _ := error stx "ill-formed universe Level"
  | _ := error stx $ "toLevel: unexpected input: " ++ toString stx

def Expr.mkAnnotation (ann : Name) (e : Expr) :=
Expr.mdata (MData.empty.setName `annotation ann) e

def dummy : Expr := Expr.const `Prop []

def mkEqns (type : Expr) (eqns : List (Name × List Expr × Expr)): Expr :=
  let eqns := eqns.map $ λ ⟨fn, lhs, rhs⟩, do {
    let fn := Expr.local fn fn type BinderInfo.auxDecl,
    let lhs := Expr.mkApp (Expr.mkAnnotation `@ fn) lhs,
    Expr.app lhs rhs
  } in
  Expr.mkAnnotation `preEquations $ Expr.mkCapp `_ eqns

partial def toPexpr : Syntax → ElaboratorM Expr
| stx@(Syntax.rawNode {kind := k, args := args}) := do
  e ← match k with
  | @identUnivs := do
    let v := view identUnivs stx,
    e ← match v with
    | {id := id, univs := some univs} := Expr.const (mangleIdent id) <$> univs.levels.mmap toLevel
    | {id := id, univs := none}       := pure $ Expr.const (mangleIdent id) [],
    let m := MData.empty.setName `annotation `preresolved,
    let m := v.id.preresolved.enum.foldl (λ (m : MData) ⟨i, n⟩, m.setName (Name.anonymous.mkNumeral i) n) m,
    pure $ Expr.mdata m e
  | @app   := let v := view app stx in
    Expr.app <$> toPexpr v.fn <*> toPexpr v.Arg
  | @lambda := do
    let lam := view lambda stx,
    binders.View.simple bnder ← pure lam.binders
      | error stx "ill-formed lambda",
    (bi, id, type) ← pure bnder.toBinderInfo,
    Expr.lam (mangleIdent id) bi <$> toPexpr type <*> toPexpr lam.body
  | @pi := do
    let v := view pi stx,
    binders.View.simple bnder ← pure v.binders
      | error stx "ill-formed pi",
    (bi, id, type) ← pure bnder.toBinderInfo,
    Expr.pi (mangleIdent id) bi <$> toPexpr type <*> toPexpr v.range
  | @sort := match view sort stx with
    | sort.View.Sort _ := pure $ Expr.sort Level.zero
    | sort.View.Type _ := pure $ Expr.sort $ Level.succ Level.zero
  | @sortApp := do
    let v := view sortApp stx,
    match view sort v.fn with
    | sort.View.Sort _ := Expr.sort <$> toLevel v.Arg
    | sort.View.Type _ := (Expr.sort ∘ Level.succ) <$> toLevel v.Arg
  | @anonymousConstructor := do
    let v := view anonymousConstructor stx,
    p ← toPexpr $ mkApp (review hole {}) (v.args.map SepBy.Elem.View.item),
    pure $ Expr.mkAnnotation `anonymousConstructor p
  | @hole := pure $ Expr.mvar Name.anonymous dummy
  | @«have» := do
    let v := view «have» stx,
    let id := (mangleIdent <$> optIdent.View.id <$> v.id).getOrElse `this,
    let proof := match v.proof with
    | haveProof.View.Term hpt := hpt.Term
    | haveProof.View.from hpf := hpf.from.proof,
    lam ← Expr.lam id BinderInfo.default <$> toPexpr v.prop <*> toPexpr v.body,
    Expr.app (Expr.mkAnnotation `have lam) <$> toPexpr proof
  | @«show» := do
    let v := view «show» stx,
    prop ← toPexpr v.prop,
    proof ← toPexpr v.from.proof,
    pure $ Expr.mkAnnotation `show $ Expr.app (Expr.lam `this BinderInfo.default prop $ Expr.bvar 0) proof
  | @«let» := do
    let v := view «let» stx,
    letLhs.View.id {id := id, binders := [], type := some ty} ← pure v.lhs
      | error stx "ill-formed let",
    Expr.elet (mangleIdent id) <$> toPexpr ty.type <*> toPexpr v.value <*> toPexpr v.body
  | @projection := do
    let v := view projection stx,
    let val := match v.proj with
    | projectionSpec.View.id id := DataValue.ofName id.val
    | projectionSpec.View.num n := DataValue.ofNat n.toNat,
    Expr.mdata (MData.empty.insert `fieldNotation val) <$> toPexpr v.Term
  | @explicit := do
    let v := view explicit stx,
    let ann := match v.mod with
    | explicitModifier.View.explicit _         := `@
    | explicitModifier.View.partialExplicit _ := `@@,
    Expr.mkAnnotation ann <$> toPexpr (review identUnivs v.id)
  | @inaccessible := do
    let v := view inaccessible stx,
    Expr.mkAnnotation `innaccessible <$> toPexpr v.Term  -- sic
  | @borrowed := do
    let v := view borrowed stx,
    Expr.mkAnnotation `borrowed <$> toPexpr v.Term
  | @number := do
    let v := view number stx,
    pure $ Expr.lit $ Literal.natVal v.toNat
  | @stringLit := do
    let v := view stringLit stx,
    pure $ Expr.lit $ Literal.strVal (v.value.getOrElse "NOTAString")
  | @choice := do
    last::rev ← List.reverse <$> args.mmap (λ a, toPexpr a)
      | error stx "ill-formed choice",
    pure $ Expr.mdata (MData.empty.setNat `choice args.length) $
      rev.reverse.foldr Expr.app last
  | @structInst := do
    let v := view structInst stx,
    -- order should be: fields*, sources*, catchall?
    let (fields, other) := v.items.span (λ it, ↑match SepBy.Elem.View.item it with
      | structInstItem.View.field _ := true
      | _ := false),
    let (sources, catchall) := other.span (λ it, ↑match SepBy.Elem.View.item it with
      | structInstItem.View.source {source := some _} := true
      | _ := false),
    catchall ← match catchall with
    | [] := pure false
    | [{item := structInstItem.View.source _}] := pure true
    | {item := it}::_ := error (review structInstItem it) $ "unexpected item in structure instance notation",

    fields ← fields.mmap (λ f, match SepBy.Elem.View.item f with
      | structInstItem.View.field f :=
        Expr.mdata (MData.empty.setName `field $ mangleIdent f.id) <$> toPexpr f.val
      | _ := error stx "toPexpr: unreachable"),
    sources ← sources.mmap (λ src, match SepBy.Elem.View.item src with
      | structInstItem.View.source {source := some src} := toPexpr src
      | _ := error stx "toPexpr: unreachable"),
    sources ← match v.with with
    | none     := pure sources
    | some src := do { src ← toPexpr src.source, pure $ sources ++ [src]},

    let m := MData.empty.setNat "structure instance" fields.length,
    let m := m.setBool `catchall catchall,
    let m := m.setName `struct $
      (mangleIdent <$> structInstType.View.id <$> v.type).getOrElse Name.anonymous,
    let dummy := Expr.sort Level.zero,
    pure $ Expr.mdata m $ (fields ++ sources).foldr Expr.app dummy
  | @«match» := do
    let v := view «match» stx,
    eqns ← (v.equations.map SepBy.Elem.View.item).mmap $ λ (eqn : matchEquation.View), do {
      lhs ← eqn.lhs.mmap $ λ l, toPexpr l.item,
      rhs ← toPexpr eqn.rhs,
      pure (`_matchFn, lhs, rhs)
    },
    type ← toPexpr $ getOptType v.type,
    let eqns := mkEqns type eqns,
    Expr.mdata mdata e ← pure eqns
      | error stx "toPexpr: unreachable",
    let eqns := Expr.mdata (mdata.setBool `match true) e,
    Expr.mkApp eqns <$> v.scrutinees.mmap (λ scr, toPexpr scr.item)
  | _ := error stx $ "toPexpr: unexpected Node: " ++ toString k.name,
  match k with
  | @app := pure e -- no Position
  | _ := do
    cfg ← read,
    match stx.getPos with
    | some pos :=
      let pos := cfg.fileMap.toPosition pos in
      pure $ Expr.mdata ((MData.empty.setNat `column pos.column).setNat `row pos.line) e
    | none := pure e
| stx := error stx $ "toPexpr: unexpected: " ++ toString stx

/-- Returns the active namespace, that is, the concatenation of all active `namespace` commands. -/
def getNamespace : ElaboratorM Name := do
  sc ← currentScope,
  pure $ match sc.nsStack with
  | ns::_ := ns
  | _     := Name.anonymous

def oldElabCommand (stx : Syntax) (cmd : Expr) : ElaboratorM Unit :=
do cfg ← read,
   let pos := cfg.fileMap.toPosition $ stx.getPos.getOrElse (default _),
   let cmd := match cmd with
   | Expr.mdata m e := Expr.mdata ((m.setNat `column pos.column).setNat `row pos.line) e
   | e := e,
   st ← get,
   sc ← currentScope,
   ns ← getNamespace,
   let (st', msgs) := elaborateCommand cfg.filename cmd {
     ns := ns,
     univs := sc.univs.entries.reverse,
     vars := sc.vars.entries.reverse,
     includeVars := sc.includeVars.toList,
     Options := sc.Options,
     ..st},
   match st' with
   | some st' := do modifyCurrentScope $ λ sc, {sc with
       univs := OrderedRBMap.ofList st'.univs,
       vars := OrderedRBMap.ofList st'.vars,
       includeVars := RBTree.ofList st'.includeVars,
       Options := st'.Options,
     },
     modify $ λ st, {..st', ..st}
   | none := pure (),  -- error
   modify $ λ st, {st with messages := st.messages ++ msgs}

def namesToPexpr (ns : List Name) : Expr :=
Expr.mkCapp `_ $ ns.map (λ n, Expr.const n [])

def attrsToPexpr (attrs : List (SepBy.Elem.View attrInstance.View (Option SyntaxAtom))) : ElaboratorM Expr :=
Expr.mkCapp `_ <$> attrs.mmap (λ attr,
  Expr.mkCapp attr.item.Name.val <$> attr.item.args.mmap toPexpr)

def declModifiersToPexpr (mods : declModifiers.View) : ElaboratorM Expr := do
  let mdata : MData := {},
  let mdata := match mods.docComment with
    | some {doc := some doc, ..} := mdata.setString `docString doc.val
    | _ := mdata,
  let mdata := match mods.visibility with
    | some (visibility.View.private _) := mdata.setBool `private true
    | some (visibility.View.protected _) := mdata.setBool `protected true
    | _ := mdata,
  let mdata := mdata.setBool `noncomputable mods.noncomputable.isSome,
  let mdata := mdata.setBool `unsafe mods.unsafe.isSome,
  Expr.mdata mdata <$> attrsToPexpr (match mods.attrs with
    | some attrs := attrs.attrs
    | none       := [])

def identUnivParamsToPexpr (id : identUnivParams.View) : Expr :=
Expr.const (mangleIdent id.id) $ match id.univParams with
  | some params := params.params.map (Level.Param ∘ mangleIdent)
  | none        := []

/-- Execute `elab` and reset local Scope (universes, ...) after it has finished. -/
def locally (elab : ElaboratorM Unit) :
  ElaboratorM Unit := do
  sc ← currentScope,
  elab,
  modifyCurrentScope $ λ _, sc

def simpleBindersToPexpr (bindrs : List simpleBinder.View) : ElaboratorM Expr :=
Expr.mkCapp `_ <$> bindrs.mmap (λ b, do
  let (bi, id, type) := b.toBinderInfo,
  let id := mangleIdent id,
  type ← toPexpr type,
  pure $ Expr.local id id type bi)

def elabDefLike (stx : Syntax) (mods : declModifiers.View) (dl : defLike.View) (kind : Nat) : ElaboratorM Unit :=
match dl with
| {sig := {params := bracketedBinders.View.simple bbs}, ..} := do
  let mdata := MData.empty.setName `command `defs,
  mods ← declModifiersToPexpr mods,
  let kind := Expr.lit $ Literal.natVal kind,
  match dl.oldUnivParams with
  | some uparams :=
    modifyCurrentScope $ λ sc, {sc with univs :=
      (uparams.ids.map mangleIdent).foldl (λ m id, OrderedRBMap.insert m id (Level.Param id)) sc.univs}
  | none := pure (),
  -- do we actually need this??
  let uparams := namesToPexpr $ match dl.oldUnivParams with
  | some uparams := uparams.ids.map mangleIdent
  | none := [],
  let id := mangleIdent dl.Name.id,
  let type := getOptType dl.sig.type,
  type ← toPexpr type,
  let fns := Expr.mkCapp `_ [Expr.local id id type BinderInfo.auxDecl],
  val ← match dl.val with
  | declVal.View.simple val  := toPexpr val.body
  | declVal.View.emptyMatch _ := pure $ mkEqns type []
  | declVal.View.match eqns  := do {
    eqns ← eqns.mmap (λ (eqn : equation.View), do
      lhs ← eqn.lhs.mmap toPexpr,
      rhs ← toPexpr eqn.rhs,
      pure (id, lhs, rhs)
    ),
    pure $ mkEqns type eqns
  },
  params ← simpleBindersToPexpr bbs,
  oldElabCommand stx $ Expr.mdata mdata $ Expr.mkCapp `_ [mods, kind, uparams, fns, params, val]
| _ := error stx "elabDefLike: unexpected input"

def inferModToPexpr (mod : Option inferModifier.View) : Expr :=
Expr.lit $ Literal.natVal $ match mod with
| none := 0
| some $ inferModifier.View.relaxed _ := 1
| some $ inferModifier.View.strict _  := 2

def declaration.elaborate : Elaborator :=
λ stx, locally $ do
  let decl := view «declaration» stx,
  match decl.inner with
  | declaration.inner.View.«axiom» c@{sig := {params := bracketedBinders.View.simple [], type := type}, ..} := do
    let mdata := MData.empty.setName `command `«axiom», -- CommentTo(Kha): It was `constant` here
    mods ← declModifiersToPexpr decl.modifiers,
    let id := identUnivParamsToPexpr c.Name,
    type ← toPexpr type.type,
    oldElabCommand stx $ Expr.mdata mdata $ Expr.mkCapp `_ [mods, id, type]
  | declaration.inner.View.defLike dl := do
      -- The numeric literals below should reflect the enum values
      -- enum class declCmdKind { Theorem, Definition, OpaqueConst, Example, Instance, Var, Abbreviation };
      let kind := match dl.kind with
      | defLike.kind.View.theorem _ := 0
      | defLike.kind.View.def _ := 1
      | defLike.kind.View.«constant» _ := 2
      | defLike.kind.View.abbreviation _ := 6
      | defLike.kind.View.«abbrev» _ := 6,
      elabDefLike stx decl.modifiers dl kind

  -- these are almost macros for `def`, Except the Elaborator handles them specially at a few places
  -- based on the kind
  | declaration.inner.View.example ex :=
    elabDefLike stx decl.modifiers {
      kind := defLike.kind.View.def,
      Name := {id := Name.anonymous},
      sig := {..ex.sig},
      ..ex} 3
  | declaration.inner.View.instance i :=
    elabDefLike stx decl.modifiers {
      kind := defLike.kind.View.def,
      Name := i.Name.getOrElse {id := Name.anonymous},
      sig := {..i.sig},
      ..i} 4

  | declaration.inner.View.inductive ind@{«class» := none, sig := {params := bracketedBinders.View.simple bbs}, ..} := do
    let mdata := MData.empty.setName `command `inductives,
    mods ← declModifiersToPexpr decl.modifiers,
    attrs ← attrsToPexpr (match decl.modifiers.attrs with
      | some attrs := attrs.attrs
      | none       := []),
    let mutAttrs := Expr.mkCapp `_ [attrs],
    match ind.oldUnivParams with
    | some uparams :=
      modifyCurrentScope $ λ sc, {sc with univs :=
        (uparams.ids.map mangleIdent).foldl (λ m id, OrderedRBMap.insert m id (Level.Param id)) sc.univs}
    | none := pure (),
    let uparams := namesToPexpr $ match ind.oldUnivParams with
    | some uparams := uparams.ids.map mangleIdent
    | none := [],
    let id := mangleIdent ind.Name.id,
    let type := getOptType ind.sig.type,
    type ← toPexpr type,
    let indL := Expr.local id id type BinderInfo.default,
    let inds := Expr.mkCapp `_ [indL],
    params ← simpleBindersToPexpr bbs,
    introRules ← ind.introRules.mmap (λ (r : introRule.View), do
      ({params := bracketedBinders.View.simple [], type := some ty}) ← pure r.sig
        | error stx "declaration.elaborate: unexpected input",
      type ← toPexpr ty.type,
      let Name := mangleIdent r.Name,
      pure $ Expr.local Name Name type BinderInfo.default),
    let introRules := Expr.mkCapp `_ introRules,
    let introRules := Expr.mkCapp `_ [introRules],
    let inferKinds := ind.introRules.map $ λ (r : introRule.View), inferModToPexpr r.inferMod,
    let inferKinds := Expr.mkCapp `_ inferKinds,
    let inferKinds := Expr.mkCapp `_ [inferKinds],
    oldElabCommand stx $ Expr.mdata mdata $
      Expr.mkCapp `_ [mods, mutAttrs, uparams, inds, params, introRules, inferKinds]

  | declaration.inner.View.structure s@{keyword := structureKw.View.structure _, sig := {params := bracketedBinders.View.simple bbs}, ..} := do
    let mdata := MData.empty.setName `command `structure,
    mods ← declModifiersToPexpr decl.modifiers,
    match s.oldUnivParams with
    | some uparams :=
      modifyCurrentScope $ λ sc, {sc with univs :=
        (uparams.ids.map mangleIdent).foldl (λ m id, OrderedRBMap.insert m id (Level.Param id)) sc.univs}
    | none := pure (),
    let uparams := namesToPexpr $ match s.oldUnivParams with
    | some uparams := uparams.ids.map mangleIdent
    | none := [],
    let Name := mangleIdent s.Name.id,
    let Name := Expr.local Name Name dummy BinderInfo.default,
    let type := getOptType s.sig.type,
    type ← toPexpr type,
    params ← simpleBindersToPexpr bbs,
    let parents := match s.extends with
    | some ex := ex.parents
    | none    := [],
    parents ← parents.mmap (toPexpr ∘ SepBy.Elem.View.item),
    let parents := Expr.mkCapp `_ parents,
    let mk := match s.ctor with
    | some ctor := mangleIdent ctor.Name
    | none      := `mk,
    let mk := Expr.local mk mk dummy BinderInfo.default,
    let infer := inferModToPexpr (s.ctor >>= structureCtor.View.inferMod),
    fieldBlocks ← s.fieldBlocks.mmap (λ bl, do
      (bi, content) ← match bl with
        | structureFieldBlock.View.explicit {content := structExplicitBinderContent.View.notation _} :=
          error stx "declaration.elaborate: unexpected input"
        | structureFieldBlock.View.explicit {content := structExplicitBinderContent.View.other c} :=
          pure (BinderInfo.default, c)
        | structureFieldBlock.View.implicit {content := c} := pure (BinderInfo.implicit, c)
        | structureFieldBlock.View.strictImplicit {content := c} := pure (BinderInfo.strictImplicit, c)
        | structureFieldBlock.View.instImplicit {content := c} := pure (BinderInfo.instImplicit, c),
      let bi := Expr.local `_ `_ dummy bi,
      let ids := namesToPexpr $ content.ids.map mangleIdent,
      let kind := inferModToPexpr content.inferMod,
      let type := getOptType content.sig.type,
      type ← toPexpr type,
      pure $ Expr.mkCapp `_ [bi, ids, kind, type]),
    let fieldBlocks := Expr.mkCapp `_ fieldBlocks,
    oldElabCommand stx $ Expr.mdata mdata $
      Expr.mkCapp `_ [mods, uparams, Name, params, parents, type, mk, infer, fieldBlocks]
  | _ :=
    error stx "declaration.elaborate: unexpected input"

def variables.elaborate : Elaborator :=
λ stx, do
  let mdata := MData.empty.setName `command `variables,
  let v := view «variables» stx,
  vars ← match v.binders with
  | bracketedBinders.View.simple bbs := bbs.mfilter $ λ b, do
    let (bi, id, type) := b.toBinderInfo,
    if type.isOfKind bindingAnnotationUpdate then do
      sc ← currentScope,
      let id := mangleIdent id,
      match sc.vars.find id with
      | some (_, v) :=
        modifyCurrentScope $ λ sc, {sc with vars :=
          sc.vars.insert id {v with BinderInfo := bi}}
      | none := error (Syntax.ident id) "",
      pure false
    else pure true
  | _ := error stx "variables.elaborate: unexpected input",
  vars ← simpleBindersToPexpr vars,
  oldElabCommand stx $ Expr.mdata mdata vars

def include.elaborate : Elaborator :=
λ stx, do
  let v := view «include» stx,
  -- TODO(Sebastian): error checking
  modifyCurrentScope $ λ sc, {sc with includeVars :=
    v.ids.foldl (λ vars v, vars.insert $ mangleIdent v) sc.includeVars}

-- TODO: RBMap.remove
/-
def omit.elaborate : Elaborator :=
λ stx, do
  let v := View «omit» stx,
  modify $ λ st, {st with localState := {sc with includeVars :=
    v.ids.foldl (λ vars v, vars.remove $ mangleIdent v) sc.includeVars}}
-/

def Module.header.elaborate : Elaborator :=
λ stx, do
  let header := view Module.header stx,
  match header with
  | {«prelude» := some _, imports := []} := pure ()
  | _ := error stx "not implemented: imports"

def precToNat : Option precedence.View → Nat
| (some prec) := prec.Term.toNat
| none        := 0

-- TODO(Sebastian): Command parsers like `structure` will need access to these
def CommandParserConfig.registerNotationTokens (spec : NotationSpec.View) (cfg : CommandParserConfig) :
  Except String CommandParserConfig :=
do spec.rules.mfoldl (λ (cfg : CommandParserConfig) r, match r.symbol with
   | notationSymbol.View.quoted {symbol := some a, prec := prec, ..} :=
     pure {cfg with tokens := cfg.tokens.insert a.val.trim {«prefix» := a.val.trim, lbp := precToNat prec}}
   | _ := throw "registerNotationTokens: unreachable") cfg

def CommandParserConfig.registerNotationParser (k : SyntaxNodeKind) (nota : notation.View)
  (cfg : CommandParserConfig) : Except String CommandParserConfig :=
do -- build and register Parser
   ps ← nota.spec.rules.mmap (λ r : rule.View, do
     psym ← match r.symbol with
     | notationSymbol.View.quoted {symbol := some a ..} :=
       pure (symbol a.val : termParser)
     | _ := throw "registerNotationParser: unreachable",
     ptrans ← match r.transition with
     | some (transition.View.binder b) :=
       pure $ some $ Term.binderIdent.Parser
     | some (transition.View.binders b) :=
       pure $ some $ Term.binders.Parser
     | some (transition.View.Arg {action := none, ..}) :=
       pure $ some Term.Parser
     | some (transition.View.Arg {action := some {kind := actionKind.View.prec prec}, ..}) :=
       pure $ some $ Term.Parser prec.toNat
     | some (transition.View.Arg {action := some {kind := actionKind.View.scoped sc}, ..}) :=
       pure $ some $ Term.Parser $ precToNat sc.prec
     | none := pure $ none
     | _ := throw "registerNotationParser: unimplemented",
     pure $ psym::ptrans.toMonad
   ),
   firstRule::_ ← pure nota.spec.rules | throw "registerNotationParser: unreachable",
   firstTk ← match firstRule.symbol with
   | notationSymbol.View.quoted {symbol := some a ..} :=
     pure a.val.trim
   | _ := throw "registerNotationParser: unreachable",
   let ps := ps.bind id,
   cfg ← match nota.local, nota.spec.prefixArg with
   | none,   none   := pure {cfg with leadingTermParsers :=
     cfg.leadingTermParsers.insert firstTk $ Parser.Combinators.node k ps}
   | some _, none   := pure {cfg with localLeadingTermParsers :=
     cfg.localLeadingTermParsers.insert firstTk $ Parser.Combinators.node k ps}
   | none,   some _ := pure {cfg with trailingTermParsers :=
     cfg.trailingTermParsers.insert firstTk $ Parser.Combinators.node k (getLeading::ps.map coe)}
   | some _, some _ := pure {cfg with localTrailingTermParsers :=
     cfg.localTrailingTermParsers.insert firstTk $ Parser.Combinators.node k (getLeading::ps.map coe)},
   pure cfg

/-- Recreate `ElaboratorState.parserCfg` from the Elaborator State and the initial config,
    effectively treating it as a cache. -/
def updateParserConfig : ElaboratorM Unit :=
do st ← get,
   sc ← currentScope,
   cfg ← read,
   let ccfg := cfg.initialParserCfg.toCommandParserConfig,
   ccfg ← st.reservedNotations.mfoldl (λ ccfg rnota,
     match CommandParserConfig.registerNotationTokens rnota.spec ccfg with
     | Except.ok ccfg := pure ccfg
     | Except.error e := error (review reserveNotation rnota) e) ccfg,
   ccfg ← (st.notations ++ sc.notations).mfoldl (λ ccfg nota,
     match CommandParserConfig.registerNotationTokens nota.nota.spec ccfg >>=
               CommandParserConfig.registerNotationParser nota.kind nota.nota with
     | Except.ok ccfg := pure ccfg
     | Except.error e := error (review «notation» nota.nota) e) ccfg,
   set {st with parserCfg := {cfg.initialParserCfg with toCommandParserConfig := ccfg}}

def postprocessNotationSpec (spec : NotationSpec.View) : NotationSpec.View :=
-- default leading tokens to `max`
-- NOTE: should happen after copying precedences from reserved notation
match spec with
| {prefixArg := none, rules := r@{symbol := notationSymbol.View.quoted sym@{prec := none, ..}, ..}::rs} :=
  {spec with rules := {r with symbol := notationSymbol.View.quoted {sym with prec := some
    {Term := precedenceTerm.View.lit $ precedenceLit.View.num $ number.View.ofNat maxPrec}
  }}::rs}
| _ := spec

def reserveNotation.elaborate : Elaborator :=
λ stx, do
  let v := view reserveNotation stx,
  let v := {v with spec := postprocessNotationSpec v.spec},
  -- TODO: sanity checks?
  modify $ λ st, {st with reservedNotations := v::st.reservedNotations},
  updateParserConfig

def matchPrecedence : Option precedence.View → Option precedence.View → Bool
| none      (some rp) := true
| (some sp) (some rp) := sp.Term.toNat = rp.Term.toNat
| _         _         := false

/-- Check if a notation is compatible with a reserved notation, and if so, copy missing
    precedences in the notation from the reserved notation. -/
def matchSpec (spec reserved : NotationSpec.View) : Option NotationSpec.View :=
do guard $ spec.prefixArg.isSome = reserved.prefixArg.isSome,
   rules ← (spec.rules.zip reserved.rules).mmap $ λ ⟨sr, rr⟩, do {
     notationSymbol.View.quoted sq@{symbol := some sa, ..} ← pure sr.symbol
       | failure,
     notationSymbol.View.quoted rq@{symbol := some ra, ..} ← pure rr.symbol
       | failure,
     guard $ sa.val.trim = ra.val.trim,
     guard $ matchPrecedence sq.prec rq.prec,
     st ← match sr.transition, rr.transition with
     | some (transition.View.binder sb), some (transition.View.binder rb) :=
       guard (matchPrecedence sb.prec rb.prec) *> pure rr.transition
     | some (transition.View.binders sb), some (transition.View.binders rb) :=
       guard (matchPrecedence sb.prec rb.prec) *> pure rr.transition
     | some (transition.View.Arg sarg), some (transition.View.Arg rarg) := do
       sact ← match action.View.kind <$> sarg.action, action.View.kind <$> rarg.action with
       | some (actionKind.View.prec sp), some (actionKind.View.prec rp) :=
         guard (sp.toNat = rp.toNat) *> pure sarg.action
       | none,                            some (actionKind.View.prec rp) :=
         pure rarg.action
       | _, _ := failure,
       pure $ some $ transition.View.Arg {sarg with action := sact}
     | none,    none    := pure none
     | _,       _       := failure,
     pure $ {rule.View .
       symbol := notationSymbol.View.quoted rq,
       transition := st}
   },
   pure $ {spec with rules := rules}

def notation.elaborateAux : notation.View → ElaboratorM notation.View :=
λ nota, do
  st ← get,
  -- check reserved notations
  matched ← pure $ st.reservedNotations.filterMap $
    λ rnota, matchSpec nota.spec rnota.spec,
  nota ← match matched with
  | [matched] := pure {nota with spec := matched}
  | []        := pure nota
  | _         := error (review «notation» nota) "invalid notation, matches multiple reserved notations",
  -- TODO: sanity checks
  pure {nota with spec := postprocessNotationSpec nota.spec}

-- TODO(Sebastian): better kind names, Module prefix?
def mkNotationKind : ElaboratorM SyntaxNodeKind :=
do st ← get,
   set {st with notationCounter := st.notationCounter + 1},
   pure {name := (`_notation).mkNumeral st.notationCounter}

/-- Register a notation in the Expander. Unlike with notation parsers, there is no harm in
    keeping local notation macros registered after closing a section. -/
def registerNotationMacro (nota : notation.View) : ElaboratorM NotationMacro :=
do k ← mkNotationKind,
   let m : NotationMacro := ⟨k, nota⟩,
   let transf := mkNotationTransformer m,
   modify $ λ st, {st with expanderCfg := {st.expanderCfg with transformers := st.expanderCfg.transformers.insert k.name transf}},
   pure m

def notation.elaborate : Elaborator :=
λ stx, do
  let nota := view «notation» stx,
  -- HACK: ignore List Literal notation using :fold
  let usesFold := nota.spec.rules.any $ λ r, match r.transition with
    | some (transition.View.Arg {action := some {kind := actionKind.View.fold _, ..}, ..}) := true
    | _ := false,
  if usesFold then do {
    cfg ← read,
    modify $ λ st, {st with messages := st.messages.add {filename := cfg.filename, pos := ⟨1,0⟩,
      severity := MessageSeverity.warning, text := "ignoring notation using 'fold' action"}}
  } else do {
    nota ← notation.elaborateAux nota,
    m ← registerNotationMacro nota,
    match nota.local with
      | some _ := modifyCurrentScope $ λ sc, {sc with notations := m::sc.notations}
      | none   := modify $ λ st, {st with notations := m::st.notations},
    updateParserConfig
  }

def universe.elaborate : Elaborator :=
λ stx, do
  let univ := view «universe» stx,
  let id := mangleIdent univ.id,
  sc ← currentScope,
  match sc.univs.find id with
  | none   := modifyCurrentScope $ λ sc, {sc with univs := sc.univs.insert id (Level.Param id)}
  | some _ := error stx $ "a universe named '" ++ toString id ++ "' has already been declared in this Scope"

def attribute.elaborate : Elaborator :=
λ stx, do
  let attr := view «attribute» stx,
  let mdata := MData.empty.setName `command `attribute,
  let mdata := mdata.setBool `local $ attr.local.isSome,
  attrs ← attrsToPexpr attr.attrs,
  ids ← attr.ids.mmap (λ id, match id.preresolved with
    | []  := error (Syntax.ident id) $ "unknown identifier '" ++ toString id.val ++ "'"
    | [c] := pure $ Expr.const c []
    | _   := error (Syntax.ident id) "invalid 'attribute' command, identifier is ambiguous"),
  let ids := Expr.mkCapp `_ ids,
  oldElabCommand stx $ Expr.mdata mdata $ Expr.app attrs ids

def check.elaborate : Elaborator :=
λ stx, do
  let v := view check stx,
  let mdata := MData.empty.setName `command `#check,
  e ← toPexpr v.Term,
  oldElabCommand stx $ Expr.mdata mdata e

def open.elaborate : Elaborator :=
λ stx, do
  let v := view «open» stx,
  -- TODO: do eager sanity checks (namespace does not exist, etc.)
  modifyCurrentScope $ λ sc, {sc with openDecls := sc.openDecls ++ v.spec}

def export.elaborate : Elaborator :=
λ stx, do
  let v := view «export» stx,
  ns ← getNamespace,
  -- TODO: do eager sanity checks (namespace does not exist, etc.)
  modify $ λ st, {st with exportDecls := st.exportDecls ++ v.spec.map (λ spec, ⟨ns, spec⟩)}

def initQuot.elaborate : Elaborator :=
λ stx, oldElabCommand stx $ Expr.mdata (MData.empty.setName `command `initQuot) dummy

def setOption.elaborate : Elaborator :=
λ stx, do
  let v := view «setOption» stx,
  let opt := v.opt.val,
  sc ← currentScope,
  let opts := sc.Options,
  -- TODO(Sebastian): check registered Options
  let opts := match v.val with
  | optionValue.View.Bool b := opts.setBool opt (match b with boolOptionValue.View.True _ := true | _ := false)
  | optionValue.View.String lit := match lit.value with
    | some s := opts.setString opt s
    | none   := opts  -- Parser already failed
  | optionValue.View.num lit := opts.setNat opt lit.toNat,
  modifyCurrentScope $ λ sc, {sc with Options := opts}

/-- List of commands: recursively elaborate each command. -/
def noKind.elaborate : Elaborator := λ stx, do
  some n ← pure stx.asNode
    | error stx "noKind.elaborate: unreachable",
  n.args.mfor command.elaborate

def end.elaborate : Elaborator :=
λ cmd, do
  let v := view «end» cmd,
  st ← get,
  -- NOTE: bottom-most (Module) Scope cannot be closed
  sc::sc'::scps ← pure st.scopes
    | error cmd "invalid 'end', there is no open Scope to end",
  let endName := mangleIdent $ v.Name.getOrElse Name.anonymous,
  when (endName ≠ sc.header) $
    error cmd $ "invalid end of " ++ sc.cmd ++ ", expected Name '" ++
      toString sc.header ++ "'",
  set {st with scopes := sc'::scps},
  -- local notations may have vanished
  updateParserConfig

def section.elaborate : Elaborator :=
λ cmd, do
  let sec := view «section» cmd,
  let header := mangleIdent $ sec.Name.getOrElse Name.anonymous,
  sc ← currentScope,
  modify $ λ st, {st with scopes := {sc with cmd := "section", header := header}::st.scopes}

def namespace.elaborate : Elaborator :=
λ cmd, do
  let v := view «namespace» cmd,
  let header := mangleIdent v.Name,
  sc ← currentScope,
  ns ← getNamespace,
  let sc' := {sc with cmd := "namespace", header := header, nsStack := (ns ++ header)::sc.nsStack},
  modify $ λ st, {st with scopes := sc'::st.scopes}

def eoi.elaborate : Elaborator :=
λ cmd, do
  st ← get,
  when (st.scopes.length > 1) $
    error cmd "invalid end of input, expected 'end'"

-- TODO(Sebastian): replace with attribute
def elaborators : RBMap Name Elaborator Name.quickLt := RBMap.fromList [
  (Module.header.name, Module.header.elaborate),
  (notation.name, notation.elaborate),
  (reserveNotation.name, reserveNotation.elaborate),
  (universe.name, universe.elaborate),
  (noKind.name, noKind.elaborate),
  (end.name, end.elaborate),
  (section.name, section.elaborate),
  (namespace.name, namespace.elaborate),
  (variables.name, variables.elaborate),
  (include.name, include.elaborate),
  --(omit.name, omit.elaborate),
  (declaration.name, declaration.elaborate),
  (attribute.name, attribute.elaborate),
  (open.name, open.elaborate),
  (export.name, export.elaborate),
  (check.name, check.elaborate),
  (initQuot.name, initQuot.elaborate),
  (setOption.name, setOption.elaborate),
  (Module.eoi.name, eoi.elaborate)
] _

-- TODO: optimize
def isOpenNamespace (sc : Scope) : Name → Bool
| Name.anonymous := true
| ns :=
  -- check surrounding namespaces
  ns ∈ sc.nsStack ∨
  -- check opened namespaces
  sc.openDecls.any (λ od, od.id.val = ns) ∨
  -- TODO: check active exports
  false

-- TODO: `hiding`, `as`, `renaming`
def matchOpenSpec (n : Name) (spec : openSpec.View) : Option Name :=
let matchesOnly := match spec.only with
| none := true
| some only := n = only.id.val ∨ only.ids.any (λ id, n = id.val) in
if matchesOnly then some (spec.id.val ++ n) else none

def resolveContext : Name → ElaboratorM (List Name)
| n := do
  st ← get,
  sc ← currentScope, pure $

  -- TODO(Sebastian): check the interaction betwen preresolution and section variables
  match sc.vars.find n with
  | some (_, v) := [v.uniqName]
  | _ :=

  -- global resolution

  -- check surrounding namespaces first
  -- TODO: check for `protected`
  match sc.nsStack.filter (λ ns, st.env.contains (ns ++ n)) with
  | ns::_ := [ns ++ n] -- prefer innermost namespace
  | _ :=

  -- check environment directly
  (let unrooted := n.replacePrefix `_root_ Name.anonymous in
   match st.env.contains unrooted with
   | true := [unrooted]
   | _ := [])
  ++
  -- check opened namespaces
  (let ns' := sc.openDecls.filterMap (matchOpenSpec n) in
   ns'.filter (λ n', st.env.contains n'))
  ++
  -- check active exports
  -- TODO: optimize
  -- TODO: Lean 3 activates an export in `foo` even on `open foo (specificThing)`, but does that make sense?
  (let eds' := st.exportDecls.filter (λ ed, isOpenNamespace sc ed.inNs) in
   let ns' := eds'.filterMap (λ ed, matchOpenSpec n ed.spec) in
   ns'.filter (λ n', st.env.contains n'))

  -- TODO: projection notation

partial def preresolve : Syntax → ElaboratorM Syntax
| (Syntax.ident id) := do
  let n := mangleIdent id,
  ns ← resolveContext n,
  pure $ Syntax.ident {id with preresolved := ns ++ id.preresolved}
| (Syntax.rawNode n) := do
  args ← n.args.mmap preresolve,
  pure $ Syntax.rawNode {n with args := args}
| stx := pure stx

def mkState (cfg : ElaboratorConfig) (env : Environment) (opts : Options) : ElaboratorState := {
  parserCfg := cfg.initialParserCfg,
  expanderCfg := {transformers := Expander.builtinTransformers, ..cfg},
  env := env,
  ngen := ⟨`_ngen.fixme, 0⟩,
  scopes := [{cmd := "MODULE", header := `MODULE, Options := opts}]}

def processCommand (cfg : ElaboratorConfig) (st : ElaboratorState) (cmd : Syntax) : ElaboratorState :=
let st := {st with messages := MessageLog.empty} in
let r := @ExceptT.run _ Id _ $ flip StateT.run st $ flip ReaderT.run cfg $ RecT.run
  (command.elaborate cmd)
  (λ _, error cmd "Elaborator.run: recursion depth exceeded")
  (λ cmd, do
    some n ← pure cmd.asNode |
      error cmd $ "not a command: " ++ toString cmd,
    some elab ← pure $ elaborators.find n.kind.name |
      error cmd $ "unknown command: " ++ toString n.kind.name,
    cmd' ← preresolve cmd,
    elab cmd') in
match r with
| Except.ok ((), st) := st
| Except.error e     := {st with messages := st.messages.add e}

end Elaborator
end Lean


/-
Copyright (c) 2021 Wojciech Nawrocki. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Wojciech Nawrocki, Marc Huisinga
-/
import Lean.DeclarationRange

import Lean.Data.Json
import Lean.Data.Lsp
import Lean.Elab.Command

import Lean.Server.FileSource
import Lean.Server.FileWorker.Utils

import Lean.Server.Rpc.Basic

namespace Lean.Server

structure RequestError where
  code    : JsonRpc.ErrorCode
  message : String
  deriving Inhabited

namespace RequestError
open JsonRpc

def fileChanged : RequestError :=
  { code := ErrorCode.contentModified
    message := "File changed." }

def methodNotFound (method : String) : RequestError :=
  { code := ErrorCode.methodNotFound
    message := s!"No request handler found for '{method}'" }

def invalidParams (message : String) : RequestError :=
  {code := ErrorCode.invalidParams, message}

def internalError (message : String) : RequestError :=
  { code := ErrorCode.internalError, message }

def ofException (e : Lean.Exception) : IO RequestError :=
  return internalError (← e.toMessageData.toString)

def ofIoError (e : IO.Error) : RequestError :=
  internalError (toString e)

def toLspResponseError (id : RequestID) (e : RequestError) : ResponseError Unit :=
  { id := id
    code := e.code
    message := e.message }

end RequestError

def parseRequestParams (paramType : Type) [FromJson paramType] (params : Json)
    : Except RequestError paramType :=
  fromJson? params |>.mapError fun inner =>
    { code := JsonRpc.ErrorCode.parseError
      message := s!"Cannot parse request params: {params.compress}\n{inner}" }

structure RequestContext where
  rpcSessions   : RBMap UInt64 (IO.Ref FileWorker.RpcSession) compare
  srcSearchPath : SearchPath
  doc           : FileWorker.EditableDocument
  hLog          : IO.FS.Stream
  hOut          : IO.FS.Stream
  initParams    : Lsp.InitializeParams

abbrev RequestTask α := Task (Except RequestError α)
abbrev RequestT m := ReaderT RequestContext <| ExceptT RequestError m
/-- Workers execute request handlers in this monad. -/
abbrev RequestM := ReaderT RequestContext <| EIO RequestError

abbrev RequestTask.pure (a : α) : RequestTask α := .pure (.ok a)

instance : MonadLift IO RequestM where
  monadLift x := do
    match ←  x.toBaseIO with
    | .error e => throw <| RequestError.ofIoError e
    | .ok v => return v

instance : MonadLift (EIO Exception) RequestM where
  monadLift x := do
    match ←  x.toBaseIO with
    | .error e => throw <| ← RequestError.ofException e
    | .ok v => return v

namespace RequestM
open FileWorker
open Snapshots

def readDoc [Monad m] [MonadReaderOf RequestContext m] : m EditableDocument := do
  let rc ← readThe RequestContext
  return rc.doc

def asTask (t : RequestM α) : RequestM (RequestTask α) := do
  let rc ← readThe RequestContext
  let t ← EIO.asTask <| t.run rc
  return t.map liftExcept

def mapTask (t : Task α) (f : α → RequestM β) : RequestM (RequestTask β) := do
  let rc ← readThe RequestContext
  let t ← EIO.mapTask (f · rc) t
  return t.map liftExcept

def bindTask (t : Task α) (f : α → RequestM (RequestTask β)) : RequestM (RequestTask β) := do
  let rc ← readThe RequestContext
  EIO.bindTask t (f · rc)

def waitFindSnapAux (notFoundX abortedX : RequestM α) (x : Snapshot → RequestM α)
    : Except ElabTaskError (Option Snapshot) → RequestM α
  /- The elaboration task that we're waiting for may be aborted if the file contents change.
  In that case, we reply with the `fileChanged` error by default. Thanks to this, the server doesn't
  get bogged down in requests for an old state of the document. -/
  | Except.error FileWorker.ElabTaskError.aborted => abortedX
  | Except.error (FileWorker.ElabTaskError.ioError e) =>
    throw (RequestError.ofIoError e)
  | Except.ok none => notFoundX
  | Except.ok (some snap) => x snap

/-- Create a task which waits for the first snapshot matching `p`, handles various errors,
and if a matching snapshot was found executes `x` with it. If not found, the task executes
`notFoundX`. -/
def withWaitFindSnap (doc : EditableDocument) (p : Snapshot → Bool)
    (notFoundX : RequestM β)
    (x : Snapshot → RequestM β)
    (abortedX : RequestM β := throwThe RequestError .fileChanged)
    : RequestM (RequestTask β) := do
  let findTask := doc.cmdSnaps.waitFind? p
  mapTask findTask <| waitFindSnapAux notFoundX abortedX x

/-- See `withWaitFindSnap`. -/
def bindWaitFindSnap (doc : EditableDocument) (p : Snapshot → Bool)
    (notFoundX : RequestM (RequestTask β))
    (x : Snapshot → RequestM (RequestTask β))
    (abortedX : RequestM (RequestTask β) := throwThe RequestError .fileChanged)
    : RequestM (RequestTask β) := do
  let findTask := doc.cmdSnaps.waitFind? p
  bindTask findTask <| waitFindSnapAux notFoundX abortedX x

/-- Create a task which waits for the snapshot containing `lspPos` and executes `f` with it.
If no such snapshot exists, the request fails with an error. -/
def withWaitFindSnapAtPos
    (lspPos : Lsp.Position)
    (f : Snapshots.Snapshot → RequestM α)
    : RequestM (RequestTask α) := do
  let doc ← readDoc
  let pos := doc.meta.text.lspPosToUtf8Pos lspPos
  withWaitFindSnap doc (fun s => s.endPos >= pos)
    (notFoundX := throw ⟨.invalidParams, s!"no snapshot found at {lspPos}"⟩)
    (x := f)

open Elab.Command in
def runCommandElabM (snap : Snapshot) (c : RequestT CommandElabM α) : RequestM α := do
  let rc ← readThe RequestContext
  match ← snap.runCommandElabM rc.doc.meta (c.run rc) with
  | .ok v => return v
  | .error e => throw e

def runCoreM (snap : Snapshot) (c : RequestT CoreM α) : RequestM α := do
  let rc ← readThe RequestContext
  match ← snap.runCoreM rc.doc.meta (c.run rc) with
  | .ok v => return v
  | .error e => throw e

open Elab.Term in
def runTermElabM (snap : Snapshot) (c : RequestT TermElabM α) : RequestM α := do
  let rc ← readThe RequestContext
  match ← snap.runTermElabM rc.doc.meta (c.run rc) with
  | .ok v => return v
  | .error e => throw e

end RequestM

/-! # The global request handlers table

We maintain a global map of LSP request handlers. This allows user code such as plugins
to register its own handlers, for example to support ITP functionality such as goal state
visualization.

For details of how to register one, see `registerLspRequestHandler`. -/
section HandlerTable
open Lsp

structure RequestHandler where
  fileSource : Json → Except RequestError Lsp.DocumentUri
  handle : Json → RequestM (RequestTask Json)

builtin_initialize requestHandlers : IO.Ref (PersistentHashMap String RequestHandler) ←
  IO.mkRef {}

/-- NB: This method may only be called in `initialize` blocks (user or builtin).

A registration consists of:
- a type of JSON-parsable request data `paramType`
- a `FileSource` instance for it so the system knows where to route requests
- a type of JSON-serializable response data `respType`
- an actual `handler` which runs in the `RequestM` monad and is expected
  to produce an asynchronous `RequestTask` which does any waiting/computation

A handler task may be cancelled at any time, so it should check the cancellation token when possible
to handle this cooperatively. Any exceptions thrown in a request handler will be reported to the client
as LSP error responses. -/
def registerLspRequestHandler (method : String)
    paramType [FromJson paramType] [FileSource paramType]
    respType [ToJson respType]
    (handler : paramType → RequestM (RequestTask respType)) : IO Unit := do
  if !(← Lean.initializing) then
    throw <| IO.userError s!"Failed to register LSP request handler for '{method}': only possible during initialization"
  if (← requestHandlers.get).contains method then
    throw <| IO.userError s!"Failed to register LSP request handler for '{method}': already registered"
  let fileSource := fun j =>
    parseRequestParams paramType j |>.map Lsp.fileSource
  let handle := fun j => do
    let params ← liftExcept <| parseRequestParams paramType j
    let t ← handler params
    pure <| t.map <| Except.map ToJson.toJson

  requestHandlers.modify fun rhs => rhs.insert method { fileSource, handle }

def lookupLspRequestHandler (method : String) : IO (Option RequestHandler) :=
  return (← requestHandlers.get).find? method

/-- NB: This method may only be called in `initialize` blocks (user or builtin).

Register another handler to invoke after the last one registered for a method.
At least one handler for the method must have already been registered to perform
chaining.

For more details on the registration of a handler, see `registerLspRequestHandler`. -/
def chainLspRequestHandler (method : String)
    paramType [FromJson paramType]
    respType [FromJson respType] [ToJson respType]
    (handler : paramType → RequestTask respType → RequestM (RequestTask respType)) : IO Unit := do
  if !(← Lean.initializing) then
    throw <| IO.userError s!"Failed to chain LSP request handler for '{method}': only possible during initialization"
  if let some oldHandler ← lookupLspRequestHandler method then
    let handle := fun j => do
      let t ← oldHandler.handle j
      let t := t.map fun x => x.bind fun j => FromJson.fromJson? j |>.mapError fun e =>
        .internalError s!"Failed to parse original LSP response for `{method}` when chaining: {e}"
      let params ← liftExcept <| parseRequestParams paramType j
      let t ← handler params t
      pure <| t.map <| Except.map ToJson.toJson

    requestHandlers.modify fun rhs => rhs.insert method {oldHandler with handle}
  else
    throw <| IO.userError s!"Failed to chain LSP request handler for '{method}': no initial handler registered"

def routeLspRequest (method : String) (params : Json) : IO (Except RequestError DocumentUri) := do
  match (← lookupLspRequestHandler method) with
  | none => return Except.error <| RequestError.methodNotFound method
  | some rh => return rh.fileSource params

def handleLspRequest (method : String) (params : Json) : RequestM (RequestTask Json) := do
  match (← lookupLspRequestHandler method) with
  | none =>
    throw <| .internalError
      s!"request '{method}' routed through watchdog but unknown in worker; are both using the same plugins?"
  | some rh => rh.handle params

end HandlerTable
end Lean.Server


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

/-!
The Exception monad transformer using CPS style.
-/

def ExceptCpsT (ε : Type u) (m : Type u → Type v) (α : Type u) := (β : Type u) → (α → m β) → (ε → m β) → m β

namespace ExceptCpsT

@[always_inline, inline]
def run {ε α : Type u} [Monad m] (x : ExceptCpsT ε m α) : m (Except ε α) :=
  x _ (fun a => pure (Except.ok a)) (fun e => pure (Except.error e))

@[always_inline, inline]
def runK {ε α : Type u} (x : ExceptCpsT ε m α) (s : ε) (ok : α → m β) (error : ε → m β) : m β :=
  x _ ok error

@[always_inline, inline]
def runCatch [Monad m] (x : ExceptCpsT α m α) : m α :=
  x α pure pure

@[always_inline]
instance : Monad (ExceptCpsT ε m) where
  map f x  := fun _ k₁ k₂ => x _ (fun a => k₁ (f a)) k₂
  pure a   := fun _ k _ => k a
  bind x f := fun _ k₁ k₂ => x _ (fun a => f a _ k₁ k₂) k₂

instance : LawfulMonad (ExceptCpsT σ m) := by
  refine' { .. } <;> intros <;> rfl

instance : MonadExceptOf ε (ExceptCpsT ε m) where
  throw e  := fun _ _ k => k e
  tryCatch x handle := fun _ k₁ k₂ => x _ k₁ (fun e => handle e _ k₁ k₂)

@[always_inline, inline]
def lift [Monad m] (x : m α) : ExceptCpsT ε m α :=
  fun _ k _ => x >>= k

instance [Monad m] : MonadLift m (ExceptCpsT σ m) where
  monadLift := ExceptCpsT.lift

instance [Inhabited ε] : Inhabited (ExceptCpsT ε m α) where
  default := fun _ _ k₂ => k₂ default

@[simp] theorem run_pure [Monad m] : run (pure x : ExceptCpsT ε m α) = pure (Except.ok x) := rfl

@[simp] theorem run_lift {α ε : Type u} [Monad m] (x : m α) : run (ExceptCpsT.lift x : ExceptCpsT ε m α) = (x >>= fun a => pure (Except.ok a) : m (Except ε α)) := rfl

@[simp] theorem run_throw [Monad m] : run (throw e : ExceptCpsT ε m β) = pure (Except.error e) := rfl

@[simp] theorem run_bind_lift [Monad m] (x : m α) (f : α → ExceptCpsT ε m β) : run (ExceptCpsT.lift x >>= f : ExceptCpsT ε m β) = x >>= fun a => run (f a) := rfl

@[simp] theorem run_bind_throw [Monad m] (e : ε) (f : α → ExceptCpsT ε m β) : run (throw e >>= f : ExceptCpsT ε m β) = run (throw e) := rfl

@[simp] theorem runCatch_pure [Monad m] : runCatch (pure x : ExceptCpsT α m α) = pure x := rfl

@[simp] theorem runCatch_lift {α : Type u} [Monad m] [LawfulMonad m] (x : m α) : runCatch (ExceptCpsT.lift x : ExceptCpsT α m α) = x := by
  simp [runCatch, lift]

@[simp] theorem runCatch_throw [Monad m] : runCatch (throw a : ExceptCpsT α m α) = pure a := rfl

@[simp] theorem runCatch_bind_lift [Monad m] (x : m α) (f : α → ExceptCpsT β m β) : runCatch (ExceptCpsT.lift x >>= f : ExceptCpsT β m β) = x >>= fun a => runCatch (f a) := rfl

@[simp] theorem runCatch_bind_throw [Monad m] (e : β) (f : α → ExceptCpsT β m β) : runCatch (throw e >>= f : ExceptCpsT β m β) = pure e := rfl

end ExceptCpsT


import Std.Tactic.Lint

-- internal names should be ignored
theorem Foo.Foo._bar : True := trivial

#lint- only dupNamespace


/-
# Elaboration

The elaborator is the component in charge of turning the user facing
`Syntax` into something with which the rest of the compiler can work.
Most of the time, this means translating `Syntax` into `Expr`s but
there are also other use cases such as `#check` or `#eval`. Hence the
elaborator is quite a large piece of code, it lives
[here](https://github.com/leanprover/lean4/blob/master/src/Lean/Elab).

## Command elaboration
A command is the highest level of `Syntax`, a Lean file is made
up of a list of commands. The most commonly used commands are declarations,
for example:
- `def`
- `inductive`
- `structure`

but there are also other ones, most notably `#check`, `#eval` and friends.
All commands live in the `command` syntax category so in order to declare
custom commands, their syntax has to be registered in that category.

### Giving meaning to commands
The next step is giving some semantics to the syntax. With commands, this
is done by registering a so called command elaborator.

Command elaborators have type `CommandElab` which is an alias for:
`Syntax → CommandElabM Unit`. What they do, is take the `Syntax` that
represents whatever the user wants to call the command and produce some
sort of side effect on the `CommandElabM` monad, after all the return
value is always `Unit`. The `CommandElabM` monad has 4 main kinds of
side effects:
1. Logging messages to the user via the `Monad` extensions
   `MonadLog` and `AddMessageContext`, like `#check`. This is done via
   functions that can be found in `Lean.Elab.Log`, the most notable ones
   being: `logInfo`, `logWarning` and `logError`.
2. Interacting with the `Environment` via the `Monad` extension `MonadEnv`.
   This is the place where all of the relevant information for the compiler
   is stored, all known declarations, their types, doc-strings, values etc.
   The current environment can be obtained via `getEnv` and set via `setEnv`
   once it has been modified. Note that quite often wrappers around `setEnv`
   like `addDecl` are the correct way to add information to the `Environment`.
3. Performing `IO`, `CommandElabM` is capable of running any `IO` operation.
   For example reading from files and based on their contents perform
   declarations.
4. Throwing errors, since it can run any kind of `IO`, it is only natural
   that it can throw errors via `throwError`.

Furthermore there are a bunch of other `Monad` extensions that are supported
by `CommandElabM`:
- `MonadRef` and `MonadQuotation` for `Syntax` quotations like in macros
- `MonadOptions` to interact with the options framework
- `MonadTrace` for debug trace information
- TODO: There are a few others though I'm not sure whether they are relevant,
  see the instance in `Lean.Elab.Command`

### Command elaboration
Now that we understand the type of command elaborators let's take a brief
look at how the elaboration process actually works:
1. Check whether any macros can be applied to the current `Syntax`.
   If there is a macro that does apply and does not throw an error
   the resulting `Syntax` is recursively elaborated as a command again.
2. If no macro can be applied, we search for all `CommandElab`s that have been
   registered for the `SyntaxKind` of the `Syntax` we are elaborating,
   using the `command_elab` attribute.
3. All of these `CommandElab` are then tried in order until one of them does not throw an
   `unsupportedSyntaxException`, Lean's way of indicating that the elaborator
   "feels responsible"
   for this specific `Syntax` construct. Note that it can still throw a regular
   error to indicate to the user that something is wrong. If no responsible
   elaborator is found, then the command elaboration is aborted with an `unexpected syntax`
   error message.

As you can see the general idea behind the procedure is quite similar to ordinary macro expansion.

### Making our own
Now that we know both what a `CommandElab` is and how they are used, we can
start looking into writing our own. The steps for this, as we learned above, are:
1. Declaring the syntax
2. Declaring the elaborator
3. Registering the elaborator as responsible for the syntax via the `command_elab`
   attribute.

Let's see how this is done:
-/

import Lean

open Lean Elab Command Term Meta

syntax (name := mycommand1) "#mycommand1" : command -- declare the syntax

@[command_elab mycommand1]
def mycommand1Impl : CommandElab := fun stx => do -- declare and register the elaborator
  logInfo "Hello World"

#mycommand1 -- Hello World

/-!
You might think that this is a little boiler-platey and it turns out the Lean
devs did as well so they added a macro for this!
-/
elab "#mycommand2" : command =>
  logInfo "Hello World"

#mycommand2 -- Hello World

/-!
Note that, due to the fact that command elaboration supports multiple
registered elaborators for the same syntax, we can in fact overload
syntax, if we want to.
-/
@[command_elab mycommand1]
def myNewImpl : CommandElab := fun stx => do
  logInfo "new!"

#mycommand1 -- new!

/-!
Furthermore it is also possible to only overload parts of syntax by
throwing an `unsupportedSyntaxException` in the cases we want the default
handler to deal with it or just letting the `elab` command handle it.
-/

/-
In the following example, we are not extending the original `#check` syntax,
but adding a new `SyntaxKind` for this specific syntax construct.
However, from the point of view of the user, the effect is basically the same.
-/
elab "#check" "mycheck" : command => do
  logInfo "Got ya!"

/-
This is actually extending the original `#check`
-/
@[command_elab Lean.Parser.Command.check] def mySpecialCheck : CommandElab := fun stx => do
  if let some str := stx[1].isStrLit? then
    logInfo s!"Specially elaborated string literal!: {str} : String"
  else
    throwUnsupportedSyntax

#check mycheck -- Got ya!
#check "Hello" -- Specially elaborated string literal!: Hello : String
#check Nat.add -- Nat.add : Nat → Nat → Nat

/-!
### Mini project
As a final mini project for this section let's build a command elaborator
that is actually useful. It will take a command and use the same mechanisms
as `elabCommand` (the entry point for command elaboration) to tell us
which macros or elaborators are relevant to the command we gave it.

We will not go through the effort of actually reimplementing `elabCommand` though
-/
elab "#findCElab " c:command : command => do
  let macroRes ← liftMacroM <| expandMacroImpl? (←getEnv) c
  match macroRes with
  | some (name, _) => logInfo s!"Next step is a macro: {name.toString}"
  | none =>
    let kind := c.raw.getKind
    let elabs := commandElabAttribute.getEntries (←getEnv) kind
    match elabs with
    | [] => logInfo s!"There is no elaborators for your syntax, looks like its bad :("
    | _ => logInfo s!"Your syntax may be elaborated by: {elabs.map (fun el => el.declName.toString)}"

#findCElab def lala := 12 -- Your syntax may be elaborated by: [Lean.Elab.Command.elabDeclaration]
#findCElab abbrev lolo := 12 -- Your syntax may be elaborated by: [Lean.Elab.Command.elabDeclaration]
#findCElab #check foo -- even our own syntax!: Your syntax may be elaborated by: [mySpecialCheck, Lean.Elab.Command.elabCheck]
#findCElab open Hi -- Your syntax may be elaborated by: [Lean.Elab.Command.elabOpen]
#findCElab namespace Foo -- Your syntax may be elaborated by: [Lean.Elab.Command.elabNamespace]
#findCElab #findCElab open Bar -- even itself!: Your syntax may be elaborated by: [«_aux_lean_elaboration___elabRules_command#findCElab__1»]

/-!
TODO: Maybe we should also add a mini project that demonstrates a
non # style command aka a declaration, although nothing comes to mind right now.
TODO:  Define a `conjecture` declaration, similar to `lemma/theorem`, except that
it is automatically sorried.  The `sorry` could be a custom one, to reflect that
the "conjecture" might be expected to be true.
-/

/-!
## Term elaboration
A term is a `Syntax` object that represents some sort of `Expr`.
Term elaborators are the ones that do the work for most of the code we write.
Most notably they elaborate all the values of things like definitions,
types (since these are also just `Expr`) etc.

All terms live in the `term` syntax category (which we have seen in action
in the macro chapter already). So, in order to declare custom terms, their
syntax needs to be registered in that category.

### Giving meaning to terms
As with command elaboration, the next step is giving some semantics to the syntax.
With terms, this is done by registering a so called term elaborator.

Term elaborators have type `TermElab` which is an alias for:
`Syntax → Option Expr → TermElabM Expr`. This type is already
quite different from command elaboration:
- As with command elaboration the `Syntax` is whatever the user used
  to create this term
- The `Option Expr` is the expected type of the term, since this cannot
  always be known it is only an `Option` argument
- Unlike command elaboration, term elaboration is not only executed
  because of its side effects -- the `TermElabM Expr` return value does
  actually contain something of interest, namely, the `Expr` that represents
  the `Syntax` object.

`TermElabM` is basically an upgrade of `CommandElabM` in every regard:
it supports all the capabilities we mentioned above, plus two more.
The first one is quite simple: On top of running `IO` code it is also
capable of running `MetaM` code, so `Expr`s can be constructed nicely.
The second one is very specific to the term elaboration loop.

### Term elaboration
The basic idea of term elaboration is the same as command elaboration:
expand macros and recurse or run term elaborators that have been registered
for the `Syntax` via the `term_elab` attribute (they might in turn run term elaboration)
until we are done. There is, however, one special action that a term elaborator
can do during its execution.

A term elaborator may throw `Except.postpone`. This indicates that
the term elaborator requires more
information to continue its work. In order to represent this missing information,
Lean uses so called synthetic metavariables. As you know from before, metavariables
are holes in `Expr`s that are waiting to be filled in. Synthetic metavariables are
different in that they have special methods that are used to solve them,
registered in `SyntheticMVarKind`. Right now, there are four of these:
- `typeClass`, the metavariable should be solved with typeclass synthesis
- `coe`, the metavariable should be solved via coercion (a special case of typeclass)
- `tactic`, the metavariable is a tactic term that should be solved by running a tactic
- `postponed`, the ones that are created at `Except.postpone`

Once such a synthetic metavariable is created, the next higher level term elaborator will continue.
At some point, execution of postponed metavariables will be resumed by the term elaborator,
in hopes that it can now complete its execution. We can try to see this in
action with the following example:
-/
#check set_option trace.Elab.postpone true in List.foldr .add 0 [1,2,3] -- [Elab.postpone] .add : ?m.5695 → ?m.5696 → ?m.5696

/-!
What happened here is that the elaborator for function applications started
at `List.foldr` which is a generic function so it created metavariables
for the implicit type parameters. Then, it attempted to elaborate the first argument `.add`.

In case you don't know how `.name` works, the basic idea is that quite
often (like in this case) Lean should be able to infer the output type (in this case `Nat`)
of a function (in this case `Nat.add`).  In such cases, the `.name` feature will then simply
search for a function named `name` in the namespace `Nat`. This is especially
useful when you want to use constructors of a type without referring to its
namespace or opening it, but can also be used like above.

Now back to our example, while Lean does at this point already know that `.add`
needs to have type: `?m1 → ?m2 → ?m2` (where `?x` is notation for a metavariable)
the elaborator for `.add` does need to know the actual value of `?m2` so the
term elaborator postpones execution (by internally creating a synthetic metavariable
in place of `.add`), the elaboration of the other two arguments then yields the fact that
`?m2` has to be `Nat` so once the `.add` elaborator is continued it can work with
this information to complete elaboration.

We can also easily provoke cases where this does not work out. For example:
-/

#check set_option trace.Elab.postpone true in List.foldr .add
-- [Elab.postpone] .add : ?m.5808 → ?m.5809 → ?m.5809
-- invalid dotted identifier notation, expected type is not of the form (... → C ...) where C is a constant
  -- ?m.5808 → ?m.5809 → ?m.5809

/-!
In this case `.add` first postponed its execution, then got called again
but didn't have enough information to finish elaboration and thus failed.

### Making our own
Adding new term elaborators works basically the same way as adding new
command elaborators so we'll only take a very brief look:
-/

syntax (name := myterm1) "myterm 1" : term

def mytermValues := [1, 2]

@[term_elab myterm1]
def myTerm1Impl : TermElab := fun stx type? =>
  mkAppM ``List.get! #[.const ``mytermValues [], mkNatLit 0] -- `MetaM` code

#eval myterm 1 -- 1

-- Also works with `elab`
elab "myterm 2" : term => do
  mkAppM ``List.get! #[.const ``mytermValues [], mkNatLit 1] -- `MetaM` code

#eval myterm 2 -- 2

/-!
### Mini project
As a final mini project for this chapter we will recreate one of the most
commonly used Lean syntax sugars, the `⟨a,b,c⟩` notation as a short hand
for single constructor types:
-/

-- slightly different notation so no ambiguity happens
syntax (name := myanon) "⟨⟨" term,* "⟩⟩" : term

def getCtors (typ : Name) : MetaM (List Name) := do
  let env ← getEnv
  match env.find? typ with
  | some (ConstantInfo.inductInfo val) =>
    pure val.ctors
  | _ => pure []

@[term_elab myanon]
def myanonImpl : TermElab := fun stx typ? => do
  -- Attempt to postpone execution if the type is not known or is a metavariable.
  -- Metavariables are used by things like the function elaborator to fill
  -- out the values of implicit parameters when they haven't gained enough
  -- information to figure them out yet.
  -- Term elaborators can only postpone execution once, so the elaborator
  -- doesn't end up in an infinite loop. Hence, we only try to postpone it,
  -- otherwise we may cause an error.
  tryPostponeIfNoneOrMVar typ?
  -- If we haven't found the type after postponing just error
  let some typ := typ? | throwError "expected type must be known"
  if typ.isMVar then
    throwError "expected type must be known"
  let Expr.const base .. := typ.getAppFn | throwError s!"type is not of the expected form: {typ}"
  let [ctor] ← getCtors base | throwError "type doesn't have exactly one constructor"
  let args := TSyntaxArray.mk stx[1].getSepArgs
  let stx ← `($(mkIdent ctor) $args*) -- syntax quotations
  elabTerm stx typ -- call term elaboration recursively

#check (⟨⟨1, sorry⟩⟩ : Fin 12) -- { val := 1, isLt := (_ : 1 < 12) } : Fin 12
#check ⟨⟨1, sorry⟩⟩ -- expected type must be known
#check (⟨⟨0⟩⟩ : Nat) -- type doesn't have exactly one constructor
#check (⟨⟨⟩⟩ : Nat → Nat) -- type is not of the expected form: Nat -> Nat

/-!
As a final note, we can shorten the postponing act by using an additional
syntax sugar of the `elab` syntax instead:
-/

-- This `t` syntax will effectively perform the first two lines of `myanonImpl`
elab "⟨⟨" args:term,* "⟩⟩" : term <= t => do
  sorry

/-!

## Exercises

1. Consider the following code. Rewrite `syntax` + `@[term_elab hi]... : TermElab` combination using just `elab`.

```
syntax (name := hi) term " ♥ " " ♥ "? " ♥ "? : term

@[term_elab hi]
def heartElab : TermElab := fun stx tp =>
  match stx with
    | `($l:term ♥) => do
      let nExpr ← elabTermEnsuringType l (mkConst `Nat)
      return Expr.app (Expr.app (Expr.const `Nat.add []) nExpr) (mkNatLit 1)
    | `($l:term ♥♥) => do
      let nExpr ← elabTermEnsuringType l (mkConst `Nat)
      return Expr.app (Expr.app (Expr.const `Nat.add []) nExpr) (mkNatLit 2)
    | `($l:term ♥♥♥) => do
      let nExpr ← elabTermEnsuringType l (mkConst `Nat)
      return Expr.app (Expr.app (Expr.const `Nat.add []) nExpr) (mkNatLit 3)
    | _ =>
      throwUnsupportedSyntax
```

2. Here is some syntax taken from a real mathlib command `alias`.

```
syntax (name := our_alias) (docComment)? "our_alias " ident " ← " ident* : command
```

We want `alias hi ← hello yes` to print out the identifiers after `←` - that is, "hello" and "yes".

Please add these semantics:

**a)** using `syntax` + `@[command_elab alias] def elabOurAlias : CommandElab`.
**b)** using `syntax` + `elab_rules`.
**c)** using `elab`.

3. Here is some syntax taken from a real mathlib tactic `nth_rewrite`.

```
open Parser.Tactic
syntax (name := nthRewriteSeq) "nth_rewrite " (config)? num rwRuleSeq (ppSpace location)? : tactic
```

We want `nth_rewrite 5 [←add_zero a] at h` to print out `"rewrite location!"` if the user provided location, and `"rewrite target!"` if the user didn't provide location.

Please add these semantics:

**a)** using `syntax` + `@[tactic nthRewrite] def elabNthRewrite : Lean.Elab.Tactic.Tactic`.
**b)** using `syntax` + `elab_rules`.
**c)** using `elab`.

-/


inductive Foo where
  | foo
example : Foo :=
  let c := Foo.foo
  c
--^ textDocument/typeDefinition