/- A transliteration of llvm-pretty https://github.com/elliottt/llvm-pretty/blob/master/src/Text/LLVM/AST.hs -/
-- import data.bitvec
import Std.Data.RBMap
import Init.Data.String
import Init.Data.Int

open Std (RBMap)

namespace LLVM

-- FIXME
-- def float : Type 0 := sorry
-- def double : Type 0 := sorry

def Strmap (a:Type) := RBMap String a Ord.compare
def Strmap.empty {a:Type} : Strmap a := Std.RBMap.empty

-- Identifiers -----------------------------------------------------------------

inductive Ident
| named (nm:String)
| anon (idx:Nat)

namespace Ident

def asString : Ident → String
| named nm => "%" ++ nm
| anon i   => "%" ++ (Nat.toDigits 10 i).asString

protected
def lt : Ident → Ident → Prop
| named x, named y => x < y
| named _, anon _  => True
| anon x,  anon y  => x < y
| anon _,  named _ => False

instance : LT Ident := ⟨Ident.lt⟩

instance decideEq : ∀(x y:Ident), Decidable (x = y)
| named a, named b =>
  match decEq a b with
  | Decidable.isTrue p  => Decidable.isTrue (congrArg _ p)
  | Decidable.isFalse p => Decidable.isFalse (fun H => Ident.noConfusion H p)
| anon a,  anon b =>
  match decEq a b with
  | Decidable.isTrue p  => Decidable.isTrue (congrArg _ p)
  | Decidable.isFalse p => Decidable.isFalse (fun H => Ident.noConfusion H p)
| anon _,  named _ => Decidable.isFalse (fun H => Ident.noConfusion H)
| named _, anon _  => Decidable.isFalse (fun H => Ident.noConfusion H)

instance decideLt : ∀(x y:Ident), Decidable (x < y)
| named x, named y =>
  match String.decLt x y with
  | Decidable.isTrue  p => Decidable.isTrue p
  | Decidable.isFalse p => Decidable.isFalse p
| anon x, anon y =>
  match Nat.decLt x y with
  | Decidable.isTrue  p => Decidable.isTrue p
  | Decidable.isFalse p => Decidable.isFalse p
| named _, anon _  => Decidable.isTrue True.intro
| anon _,  named _ => Decidable.isFalse False.elim

instance : Ord Ident where
  compare x y :=
    match x, y with
    | named x, named y => Ord.compare x y
    | anon x, anon y => Ord.compare x y
    | named _, anon _  => Ordering.lt
    | anon _,  named _ => Ordering.gt

end Ident

-- Data Layout -----------------------------------------------------------------

inductive AlignType
| integer
| vector
| float

inductive Mangling
| elf
| mips
| mach_o
| windows_coff
| windows_coff_x86

inductive Endian
| big
| little

-- The labels are mainly for documentation, taken from parseSpecifier
inductive LayoutSpec
| endianness (e:Endian)
| pointerSize (address_space : Nat)
               (size : Nat)
               (abi_align : Nat)
               (pref_align : Nat)
               (index_size : Option Nat)
| alignSize (type : AlignType) (size : Nat) (abi_align : Nat) (pref_align : Option Nat)
| nativeIntSize (legal_widths : List Nat)
| stackAlign    (a:Nat)
| aggregateAlign (abi_align : Nat) (pref_align:Nat)
| functionAddressSpace (x:Nat)
| stackAlloca  (sz:Nat)
| mangling (m:Mangling)

-- Types -----------------------------------------------------------------------

inductive FloatType
| half
| float
| double
| fp128
| x86FP80
| ppcFP128

inductive PrimType
| label
| token
| void
| integer (w:Nat)
| floatType (tp:FloatType)
| x86mmx
| metadata

namespace PrimType
instance : Coe FloatType PrimType := ⟨PrimType.floatType⟩
end PrimType

inductive LLVMType
| prim (tp:PrimType)
| alias (nm:String)
| array (n:Nat) (elt:LLVMType)
| funType (ret:LLVMType) (args:Array LLVMType) (varargs:Bool)
| ptr (tp:LLVMType)
| struct (packed:Bool) (fields:Array LLVMType)
| vector (n:Nat) (elt:LLVMType)

namespace LLVMType
instance : Coe PrimType LLVMType := ⟨LLVMType.prim⟩
instance : Inhabited LLVMType := ⟨LLVMType.prim PrimType.void⟩
end LLVMType

-- Top-level Type Aliases ------------------------------------------------------

inductive TypeDeclBody
| opaque
| defn (tp:LLVMType)

structure TypeDecl :=
(name : String)
(decl : TypeDeclBody)

-- Symbols ---------------------------------------------------------------------

structure Symbol := (symbol : String)

@[reducible]
instance symbolHasLess : LT Symbol := ⟨ λ(x y:Symbol) => x.symbol < y.symbol ⟩

@[reducible]
instance symbolLtDec (x y:Symbol) : Decidable (x < y) := String.decLt x.symbol y.symbol

instance : Ord Symbol where
  compare x y := Ord.compare x.symbol y.symbol

structure BlockLabel := (label : Ident)

namespace BlockLabel

instance decideEq : ∀(x y : BlockLabel), Decidable (x = y)
| ⟨a⟩, ⟨b⟩ =>
  match Ident.decideEq a b with
  | Decidable.isTrue p  => Decidable.isTrue (congrArg _ p)
  | Decidable.isFalse p => Decidable.isFalse (λH => BlockLabel.noConfusion H p)

instance : Ord BlockLabel where
  compare x y := Ord.compare x.label y.label

end BlockLabel

structure Typed (a : Type) :=
  (type  : LLVMType)
  (value : a)

/-
namespace llvm.typed
lemma sizeof_spec' (a:Type) [has_sizeof a] (x:typed a) :
  typed.sizeof a x = 1 + sizeof (x.type) + sizeof (x.value) :=
begin
  cases x, unfold typed.sizeof
end
end llvm.typed
-/

-- Instructions ----------------------------------------------------------------

inductive ArithOp
| add (uoverflow : Bool) (soverflow : Bool)
| fadd
| sub (uoverflow : Bool) (soverflow : Bool)
| fsub
| mul (uoverflow : Bool) (soverflow : Bool)
| fmul
| udiv (exact : Bool)
| sdiv (exact : Bool)
| fdiv
| urem
| srem
| frem

-- | binary bitwise operators.
inductive BitOp
| shl (uoverflow : Bool) (soverflow : Bool)
| lshr (exact : Bool)
| ashr (exact : Bool)
| and
| or
| xor

-- | Conversions from one type to another.
inductive ConvOp
| trunc
| zext
| sext
| fp_trunc
| fp_ext
| fp_to_ui
| fp_to_si
| ui_to_fp
| si_to_fp
| ptr_to_int
| int_to_ptr
| bit_cast

inductive AtomicRWOp
| xchg
| add
| sub
| and
| nand
| or
| xor
| max
| min
| u_max
| u_min

/-- Ordering constraint (https://llvm.org/docs/LangRef.html#ordering) -/
inductive AtomicOrdering
| unordered
| monotonic
| acquire
| release
| acqRel
| seqCst

-- | Integer comparison operators.
inductive ICmpOp
| ieq | ine | iugt | iuge | iult | iule | isgt | isge | islt | isle

-- | Floating-point comparison operators.
inductive FCmpOp
| ffalse| foeq | fogt | foge | folt | fole | fone
| ford  | fueq | fugt | fuge | fult | fule | fune
| funo  | ftrue

-- Values ----------------------------------------------------------------------

inductive Clause : Type
| catchExc
| filterExc

def Float := UInt32

def Double := UInt64

mutual -- Value ConstExpr, ValMD, and DebugLoc are mutually dependent

inductive Value : Type
     | integer : Int -> Value
     | bool : Bool -> Value
--     | float : Float -> Value
--     | double : Double -> Value
     | ident : Ident -> Value
     | constExpr : ConstExpr -> Value
     | symbol : Symbol -> Value
     | null  : Value
     | array : LLVMType -> Array Value -> Value
     | vector : LLVMType -> Array Value -> Value
     | struct : Array (Typed Value) -> Value
     | packedStruct : Array (Typed Value) -> Value
     | string : String -> Value -- FIXME, should probably actually be list of word8
     | undef : Value
     | label : BlockLabel -> Value
     | zeroInit : Value
     | md : ValMD -> Value
     | asm : Bool -> Bool -> String -> String -> Value -- hasSideEffects isAlignStack asmString constraintString

inductive ConstExpr : Type
     | select : Typed Value -> Typed Value -> Typed Value -> ConstExpr
     | gep : Bool -> Option Nat -> LLVMType -> Array (Typed Value) -> ConstExpr
     | conv : ConvOp -> Typed Value -> LLVMType -> ConstExpr
     | arith : ArithOp -> Typed Value -> Value -> ConstExpr
     | fcmp : FCmpOp -> Typed Value -> Typed Value -> ConstExpr
     | icmp : ICmpOp -> Typed Value -> Typed Value -> ConstExpr
     | bit : BitOp -> Typed Value -> Value -> ConstExpr
     | blockAddr : Symbol -> BlockLabel -> ConstExpr

inductive ValMD : Type
     | string (s:String) : ValMD
     | value (val:Typed Value) : ValMD
     | ref (r:Nat) : ValMD
     | node (l:List (Option ValMD)) : ValMD
     | loc (l:DebugLoc) : ValMD
     | debugInfo  : ValMD -- FIXME , just a placeholder for now

inductive DebugLoc : Type
     | debugLoc (line : Nat) (col : Nat) (scope : ValMD) (IA : Option ValMD) : DebugLoc

end

namespace Value

instance : Inhabited Value := ⟨Value.integer 0⟩

end Value

instance symbolIsValue    : Coe Symbol Value :=
  ⟨Value.symbol⟩
instance constExprIsValue : Coe ConstExpr Value :=
  ⟨Value.constExpr⟩

inductive Instruction : Type
| ret (val:Typed Value)
| retVoid
| arith (op:ArithOp) (x:Typed Value) (y:Value)
| bit   (op:BitOp) (x:Typed Value) (y:Value)
| conv  (op:ConvOp) (x:Typed Value) (res:LLVMType)
| call (tailcall : Bool) (rtp:Option LLVMType) (fn:Value) (args:Array (Typed Value))
| alloca (tp:LLVMType) (cnt:Option (Typed Value)) (align:Option Nat)
| load (addr:Typed Value) (ord:Option AtomicOrdering) (align:Option Nat)
| store (val:Typed Value) (addr:Typed Value) (align:Option Nat)
/-
| fence : option string -> atomic_ordering -> instruction
| cmp_xchg (weak : bool) (volatile : bool) : Typed Value -> Typed Value -> Typed Value
            -> option string -> atomic_ordering -> atomic_ordering -> instruction
| atomic_rw (volatile : bool) : AtomicRWOp -> Typed Value -> Typed Value
            -> option string -> atomic_ordering -> instruction
-/
| icmp (op:ICmpOp) (x:Typed Value) (y:Value)
| fcmp (op:FCmpOp) (x:Typed Value) (y:Value)
| phi (tp:LLVMType) (vals:Array (Value × BlockLabel))
| gep (bounds : Bool) (val:Typed Value) (idx:Array (Typed Value))
| select (c:Typed Value) (t:Typed Value) (f:Value)
| extractvalue (ag:Typed Value) (idxl:Array Nat)
| insertvalue (ag:Typed Value) (elt:Typed Value) (idxl:Array Nat)
| extractelement (vec:Typed Value) (idx:Value)
| insertelement (vec:Typed Value) (elt:Typed Value) (idx:Value)
| shufflevector (x:Typed Value) (y:Value) (mask:Typed Value)
| jump (label:BlockLabel)
| br (cond:Typed Value) (iftrue iffalse:BlockLabel)
| invoke (rtype:LLVMType) (fn:Value) (args:List (Typed Value)) (normal unwind:BlockLabel)
| comment (msg:String)
| unreachable
| unwind
| va_arg (argl:Typed Value) (tp:LLVMType)
| indirectbr (addr:Typed Value) (allowed:List BlockLabel)
| switch (idx:Typed Value) (default:BlockLabel) (cases:List (Nat × BlockLabel))
| landingpad (res:LLVMType) (y:Option (Typed Value)) (x:Bool) (clauses:List (Clause × Typed Value))
| resume (exn:Typed Value)

-- Named Metadata --------------------------------------------------------------

structure NamedMD :=
(name   : String)
(values : List Nat)

-- Unnamed Metadata ------------------------------------------------------------

structure UnnamedMD :=
(index  : Nat)
(values : ValMD)
(distinct : Bool)

-- Comdat ----------------------------------------------------------------------

inductive SelectionKind
| any
| exact_match
| largest
| no_duplicates
| same_size

inductive Linkage
| private_linkage
| linker_private
| linker_private_weak
| linker_private_weak_def_auto
| internal
| available_externally
| linkonce
| weak
| common
| appending
| extern_weak
| linkonce_odr
| weak_odr
| external
| dll_import
| dll_export

inductive Visibility
| default
| hidden
| protected_visibility

structure GlobalAttrs :=
(linkage    : Option Linkage)
(visibility : Option Visibility)
(const      : Bool)

structure Global :=
(sym   : Symbol)
(attrs : GlobalAttrs)
(type  : LLVMType)
(value : Option Value)
(align : Option Nat)
(metadata : Strmap ValMD)

inductive FunAttr
 | align_stack (a:Nat)
 | alwaysinline
 | builtin
 | cold
 | inlinehint
 | jumptable
 | minsize
 | naked
 | nobuiltin
 | noduplicate
 | noimplicitfloat
 | noinline
 | nonlazybind
 | noredzone
 | noreturn
 | nounwind
 | optnone
 | optsize
 | readnone
 | readonly
 | returns_twice
 | sanitize_address
 | sanitize_memory
 | sanitize_thread
 | ssp
 | ssp_req
 | ssp_strong
 | uwtable

structure Declare :=
(retType : LLVMType)
(name    : Symbol)
(args    : Array LLVMType)
(varArgs : Bool)
(attrs   : Array FunAttr)
(comdat  : Option String)

structure GC := (gc : String)

structure Stmt :=
(assign : Option Ident)
(instr : Instruction)
(metadata : (Array (String × ValMD)))

structure BasicBlock :=
(label : BlockLabel)
(stmts : Array Stmt)

structure Define :=
(linkage  : Option Linkage)
(retType  : LLVMType)
(name     : Symbol)
(args     : Array (Typed Ident))
(varArgs  : Bool)
(attrs    : Array FunAttr)
(sec      : Option String)
(gc       : Option GC)
(body     : Array BasicBlock)
(metadata : Strmap ValMD)
(comdat   : Option String)

structure GlobalAlias :=
(name   : Symbol)
(type   : LLVMType)
(target : Value)

-- Modules ---------------------------------------------------------------------
structure Module :=
(sourceName : Option String)
(dataLayout : List LayoutSpec) -- ^ type size and alignment information
(types      : Array TypeDecl) -- ^ top-level type aliases
(namedMD    : Array NamedMD)
(unnamedMD  : Array UnnamedMD)
(comdat     : Strmap SelectionKind)
(globals    : Array Global) -- ^ global value declarations
(declares   : Array Declare) -- ^ external function declarations (without definitions)
(defines    : Array Define) -- ^ internal function declarations (with definitions)
(inlineAsm  : Array String)
(aliases    : Array GlobalAlias)

-- DWARF Debug Info ------------------------------------------------------------
/-
data DebugInfo' lab
  = DebugInfoBasicType DIBasicType
| DebugInfoCompileUnit (DICompileUnit' lab)
| DebugInfoCompositeType (DICompositeType' lab)
| DebugInfoDerivedType (DIDerivedType' lab)
| DebugInfoEnumerator String !Int64
| DebugInfoExpression DIExpression
| DebugInfoFile DIFile
| DebugInfoGlobalVariable (DIGlobalVariable' lab)
| DebugInfoGlobalVariableExpression (DIGlobalVariableExpression' lab)
| DebugInfoLexicalBlock (DILexicalBlock' lab)
| DebugInfoLexicalBlockFile (DILexicalBlockFile' lab)
| DebugInfoLocalVariable (DILocalVariable' lab)
| DebugInfoSubprogram (DISubprogram' lab)
| DebugInfoSubrange DISubrange
| DebugInfoSubroutineType (DISubroutineType' lab)
| DebugInfoNameSpace (DINameSpace' lab)
| DebugInfoTemplateTypeParameter (DITemplateTypeParameter' lab)
| DebugInfoTemplateValueParameter (DITemplateValueParameter' lab)
| DebugInfoImportedEntity (DIImportedEntity' lab)
  deriving (Show,Functor,Generic,Generic1)

type DebugInfo = DebugInfo' BlockLabel

type DIImportedEntity = DIImportedEntity' BlockLabel
data DIImportedEntity' lab = DIImportedEntity
    { diieTag      :: DwarfTag
    , diieName     :: String
    , diieScope    :: Maybe (ValMd' lab)
    , diieEntity   :: Maybe (ValMd' lab)
    , diieLine     :: Word32
    } deriving (Show,Functor,Generic,Generic1)

type DITemplateTypeParameter = DITemplateTypeParameter' BlockLabel
data DITemplateTypeParameter' lab = DITemplateTypeParameter
    { dittpName :: String
    , dittpType :: ValMd' lab
    } deriving (Show,Functor,Generic,Generic1)

type DITemplateValueParameter = DITemplateValueParameter' BlockLabel
data DITemplateValueParameter' lab = DITemplateValueParameter
    { ditvpName  :: String
    , ditvpType  :: ValMd' lab
    , ditvpValue :: ValMd' lab
    } deriving (Show,Functor,Generic,Generic1)

type DINameSpace = DINameSpace' BlockLabel
data DINameSpace' lab = DINameSpace
    { dinsName  :: String
    , dinsScope :: ValMd' lab
    , dinsFile  :: ValMd' lab
    , dinsLine  :: Word32
    } deriving (Show,Functor,Generic,Generic1)

-- TODO: Turn these into sum types
-- See https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/Support/Dwarf.def
type DwarfAttrEncoding = Word8
type DwarfLang = Word16
type DwarfTag = Word16
type DwarfVirtuality = Word8
-- See https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/IR/DebugInfoMetadata.h#L175
type DIFlags = Word32
-- This seems to be defined internally as a small enum, and defined
-- differently across versions. Maybe turn this into a sum type once
-- it stabilizes.
type DIEmissionKind = Word8

data DIBasicType = DIBasicType
  { dibtTag :: DwarfTag
  , dibtName :: String
  , dibtSize :: Word64
  , dibtAlign :: Word64
  , dibtEncoding :: DwarfAttrEncoding
  } deriving (Show,Generic)

data DICompileUnit' lab = DICompileUnit
  { dicuLanguage           :: DwarfLang
  , dicuFile               :: Maybe (ValMd' lab)
  , dicuProducer           :: Maybe String
  , dicuIsOptimized        :: Bool
  , dicuFlags              :: Maybe String
  , dicuRuntimeVersion     :: Word16
  , dicuSplitDebugFilename :: Maybe FilePath
  , dicuEmissionKind       :: DIEmissionKind
  , dicuEnums              :: Maybe (ValMd' lab)
  , dicuRetainedTypes      :: Maybe (ValMd' lab)
  , dicuSubprograms        :: Maybe (ValMd' lab)
  , dicuGlobals            :: Maybe (ValMd' lab)
  , dicuImports            :: Maybe (ValMd' lab)
  , dicuMacros             :: Maybe (ValMd' lab)
  , dicuDWOId              :: Word64
  , dicuSplitDebugInlining :: Bool
  }
  deriving (Show,Functor,Generic,Generic1)

type DICompileUnit = DICompileUnit' BlockLabel

data DICompositeType' lab = DICompositeType
  { dictTag            :: DwarfTag
  , dictName           :: Maybe String
  , dictFile           :: Maybe (ValMd' lab)
  , dictLine           :: Word32
  , dictScope          :: Maybe (ValMd' lab)
  , dictBaseType       :: Maybe (ValMd' lab)
  , dictSize           :: Word64
  , dictAlign          :: Word64
  , dictOffset         :: Word64
  , dictFlags          :: DIFlags
  , dictElements       :: Maybe (ValMd' lab)
  , dictRuntimeLang    :: DwarfLang
  , dictVTableHolder   :: Maybe (ValMd' lab)
  , dictTemplateParams :: Maybe (ValMd' lab)
  , dictIdentifier     :: Maybe String
  }
  deriving (Show,Functor,Generic,Generic1)

type DICompositeType = DICompositeType' BlockLabel

data DIDerivedType' lab = DIDerivedType
  { didtTag :: DwarfTag
  , didtName :: Maybe String
  , didtFile :: Maybe (ValMd' lab)
  , didtLine :: Word32
  , didtScope :: Maybe (ValMd' lab)
  , didtBaseType :: Maybe (ValMd' lab)
  , didtSize :: Word64
  , didtAlign :: Word64
  , didtOffset :: Word64
  , didtFlags :: DIFlags
  , didtExtraData :: Maybe (ValMd' lab)
  }
  deriving (Show,Functor,Generic,Generic1)

type DIDerivedType = DIDerivedType' BlockLabel

data DIExpression = DIExpression
  { dieElements :: [Word64]
  }
  deriving (Show,Generic)

data DIFile = DIFile
  { difFilename  :: FilePath
  , difDirectory :: FilePath
  } deriving (Show,Generic)

data DIGlobalVariable' lab = DIGlobalVariable
  { digvScope                :: Maybe (ValMd' lab)
  , digvName                 :: Maybe String
  , digvLinkageName          :: Maybe String
  , digvFile                 :: Maybe (ValMd' lab)
  , digvLine                 :: Word32
  , digvType                 :: Maybe (ValMd' lab)
  , digvIsLocal              :: Bool
  , digvIsDefinition         :: Bool
  , digvVariable             :: Maybe (ValMd' lab)
  , digvDeclaration          :: Maybe (ValMd' lab)
  , digvAlignment            :: Maybe Word32
  }
  deriving (Show,Functor,Generic,Generic1)

type DIGlobalVariable = DIGlobalVariable' BlockLabel

data DIGlobalVariableExpression' lab = DIGlobalVariableExpression
  { digveVariable   :: Maybe (ValMd' lab)
  , digveExpression :: Maybe (ValMd' lab)
  }
  deriving (Show,Functor,Generic,Generic1)

type DIGlobalVariableExpression = DIGlobalVariableExpression' BlockLabel

data DILexicalBlock' lab = DILexicalBlock
  { dilbScope  :: Maybe (ValMd' lab)
  , dilbFile   :: Maybe (ValMd' lab)
  , dilbLine   :: Word32
  , dilbColumn :: Word16
  }
  deriving (Show,Functor,Generic,Generic1)

type DILexicalBlock = DILexicalBlock' BlockLabel

data DILexicalBlockFile' lab = DILexicalBlockFile
  { dilbfScope         :: ValMd' lab
  , dilbfFile          :: Maybe (ValMd' lab)
  , dilbfDiscriminator :: Word32
  }
  deriving (Show,Functor,Generic,Generic1)

type DILexicalBlockFile = DILexicalBlockFile' BlockLabel

data DILocalVariable' lab = DILocalVariable
  { dilvScope :: Maybe (ValMd' lab)
  , dilvName :: Maybe String
  , dilvFile :: Maybe (ValMd' lab)
  , dilvLine :: Word32
  , dilvType :: Maybe (ValMd' lab)
  , dilvArg :: Word16
  , dilvFlags :: DIFlags
  }
  deriving (Show,Functor,Generic,Generic1)

type DILocalVariable = DILocalVariable' BlockLabel

data DISubprogram' lab = DISubprogram
  { dispScope          :: Maybe (ValMd' lab)
  , dispName           :: Maybe String
  , dispLinkageName    :: Maybe String
  , dispFile           :: Maybe (ValMd' lab)
  , dispLine           :: Word32
  , dispType           :: Maybe (ValMd' lab)
  , dispIsLocal        :: Bool
  , dispIsDefinition   :: Bool
  , dispScopeLine      :: Word32
  , dispContainingType :: Maybe (ValMd' lab)
  , dispVirtuality     :: DwarfVirtuality
  , dispVirtualIndex   :: Word32
  , dispThisAdjustment :: Int64
  , dispThrownTypes    :: Maybe (ValMd' lab)
  , dispFlags          :: DIFlags
  , dispIsOptimized    :: Bool
  , dispTemplateParams :: Maybe (ValMd' lab)
  , dispDeclaration    :: Maybe (ValMd' lab)
  , dispVariables      :: Maybe (ValMd' lab)
  }
  deriving (Show,Functor,Generic,Generic1)

type DISubprogram = DISubprogram' BlockLabel

data DISubrange = DISubrange
  { disrCount :: Int64
  , disrLowerBound :: Int64
  }
  deriving (Show,Generic)

data DISubroutineType' lab = DISubroutineType
  { distFlags :: DIFlags
  , distTypeArray :: Maybe (ValMd' lab)
  }
  deriving (Show,Functor,Generic,Generic1)

type DISubroutineType = DISubroutineType' BlockLabel

-- Aggregate Utilities ---------------------------------------------------------

data IndexResult
  = Invalid                             -- ^ An invalid use of GEP
| HasType Type                        -- ^ A resolved type
| Resolve Ident (Type -> IndexResult) -- ^ Continue, after resolving an alias

isInvalid :: IndexResult -> Bool
isInvalid ir = case ir of
  Invalid -> True
  _       -> False

-- | Resolves the type of a GEP instruction. Type aliases are resolved
-- using the given function. An invalid use of GEP or one relying
-- on unknown type aliases will return 'Nothing'
resolveGepFull ::
(Ident -> Maybe Type) {- ^ Type alias resolution -} ->
  Type                  {- ^ Pointer type          -} ->
  [Typed Value]  {- ^ Path                  -} ->
  Maybe Type            {- ^ Type of result        -}
resolveGepFull env t ixs = go (resolveGep t ixs)
  where
  go Invalid                = Nothing
  go (HasType result)       = Just result
  go (Resolve ident resume) = go . resume =<< env ident

-- | Resolve the type of a GEP instruction.  Note that the type produced is the
-- type of the result, not necessarily a pointer.
resolveGep :: Type -> [Typed Value] -> IndexResult
resolveGep (PtrTo ty0) (v:ixs0)
| isGepIndex v =
    resolveGepBody ty0 ixs0
resolveGep ty0@PtrTo{} (v:ixs0)
| Just i <- elimAlias (typedType v) =
    Resolve i (\ty' -> resolveGep ty0 (Typed ty' (typedValue v):ixs0))
resolveGep (Alias i) ixs =
    Resolve i (\ty' -> resolveGep ty' ixs)
resolveGep _ _ = Invalid

-- | Resolve the type of a GEP instruction.  This assumes that the input has
-- already been processed as a pointer.
resolveGepBody :: Type -> [Typed Value] -> IndexResult
resolveGepBody (Struct fs) (v:ixs)
| Just i <- isGepStructIndex v, genericLength fs > i =
    resolveGepBody (genericIndex fs i) ixs
resolveGepBody (PackedStruct fs) (v:ixs)
| Just i <- isGepStructIndex v, genericLength fs > i =
    resolveGepBody (genericIndex fs i) ixs
resolveGepBody (Alias name) is
| not (null is) =
    Resolve name (\ty' -> resolveGepBody ty' is)
resolveGepBody (Array _ ty') (v:ixs)
| isGepIndex v =
    resolveGepBody ty' ixs
resolveGepBody (Vector _ tp) [val]
| isGepIndex val =
    HasType tp
resolveGepBody ty (v:ixs)
| Just i <- elimAlias (typedType v) =
    Resolve i (\ty' -> resolveGepBody ty (Typed ty' (typedValue v):ixs))
resolveGepBody ty [] =
    HasType ty
resolveGepBody _ _ =
    Invalid

isGepIndex :: Typed Value -> Bool
isGepIndex tv =
  isPrimTypeOf isInteger (typedType tv) ||
  isVectorOf (isPrimTypeOf isInteger) (typedType tv)

isGepStructIndex :: Typed Value -> Maybe Integer
isGepStructIndex tv = do
  guard (isGepIndex tv)
  elimValInteger (typedValue tv)

resolveValueIndex :: Type -> [Int32] -> IndexResult
resolveValueIndex ty is@(ix:ixs) = case ty of
  Struct fs | genericLength fs > ix
    -> resolveValueIndex (genericIndex fs ix) ixs

  PackedStruct fs | genericLength fs > ix
    -> resolveValueIndex (genericIndex fs ix) ixs

  Array n ty' | fromIntegral ix < n
    -> resolveValueIndex ty' ixs

  Alias name
    -> Resolve name (\ty' -> resolveValueIndex ty' is)

  _ -> Invalid
resolveValueIndex ty [] = HasType ty
-/

end LLVM


import category_theory.limits.shapes.binary_products
import category_theory.limits.preserves.shapes.binary_products
import category_theory.adjunction
import category_theory.monad.adjunction
import category_theory.adjunction.fully_faithful
import category_theory.closed.cartesian
import category.adjunction

universes v₁ v₂ u₁ u₂

namespace category_theory

open limits category

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₁} D] (i : D ⥤ C)

def coyoneda.ext {X Y : C} (p : Π {Z : C}, (X ⟶ Z) ≃ (Y ⟶ Z))
  (n : Π {Z Z' : C} (f : Z ⟶ Z') (g : X ⟶ Z), p (g ≫ f) = p g ≫ f) : X ≅ Y :=
{ hom := p.symm (𝟙 Y),
  inv := p (𝟙 X),
  hom_inv_id' := by rw [← p.injective.eq_iff, n, p.apply_symm_apply, id_comp],
  inv_hom_id' := by rw [← n, id_comp, equiv.apply_symm_apply] }

class in_subcategory (A : C) :=
(witness : D)
(iso : i.obj witness ≅ A)

def witness_in (A : C) [in_subcategory i A] : D := in_subcategory.witness.{v₁} i A
def witness_iso (A : C) [in_subcategory i A] : i.obj (witness_in i A) ≅ A := in_subcategory.iso.

class in_subcategory' [ir : is_right_adjoint i] (A : C) :=
( returning : is_iso (ir.adj.unit.app A) )

def containment_iso (A : C) [ir : is_right_adjoint i] [h : in_subcategory' i A] : A ≅ i.obj ((left_adjoint i).obj A) :=
begin
  haveI := h.returning,
  exact as_iso (ir.adj.unit.app A),
end
variable {i}

instance inclusion_is_in (B : D) : in_subcategory i (i.obj B) :=
{ witness := B,
  iso := iso.refl _ }

noncomputable
instance inclusion_is_in' (B : D) [ir : reflective i] : in_subcategory' i (i.obj B) :=
{ returning :=
  begin
    haveI := nat_iso.is_iso_app_of_is_iso ir.adj.counit B,
    have : ir.adj.unit.app (i.obj B) ≫ i.map (ir.adj.counit.app B) = 𝟙 (i.obj B) := ir.adj.right_triangle_components,
    refine ⟨i.map (ir.adj.counit.app B), ir.adj.right_triangle_components, _⟩,
    dsimp,
    rw [← cancel_mono (i.map (is_right_adjoint.adj.counit.app B)), assoc, this, comp_id, id_comp],
    apply is_iso.mono_of_iso,
  end }

def unit_iso_of_split_mono [ir : reflective i] (A : C) [split_mono (ir.adj.unit.app A)] : is_iso (ir.adj.unit.app A) :=
begin
  let h : i.obj (ir.left.obj A) ⟶ A := retraction (ir.adj.unit.app A),
  haveI : is_iso (ir.adj.unit.app (i.obj (ir.left.obj A))) := in_subcategory'.returning,
  haveI : split_epi h := ⟨ir.adj.unit.app A, split_mono.id (ir.adj.unit.app A)⟩,
  suffices : epi (ir.adj.unit.app A),
    refine ⟨h, split_mono.id (ir.adj.unit.app A), _⟩,
    resetI,
    dsimp,
    erw [← cancel_epi (ir.adj.unit.app A), split_mono.id_assoc (ir.adj.unit.app A), comp_id],
  suffices : epi (ir.adj.unit.app _ ≫ i.map (ir.left.map h)),
    erw [← ir.adj.unit.naturality h, functor.id_map] at this,
    resetI,
    apply epi_of_epi h,
  apply epi_comp,
end

-- Some of the stuff here doesn't need reflectiveness, need to untangle what assumptions are actually used
noncomputable
def in_subcategory_of_has_iso [ir : reflective i] (A : C) (B : D) (h : i.obj B ≅ A) : in_subcategory' i A :=
{ returning :=
  begin
    apply unit_iso_of_split_mono _,
    refine ⟨i.map ((ir.adj.hom_equiv _ _).symm h.inv) ≫ h.hom, _⟩,
    simp,
  end }

@[reducible]
def equiv_homset_left_of_iso
  {X X' : C} (Y : C) (i : X ≅ X') :
  (X ⟶ Y) ≃ (X' ⟶ Y) :=
{ to_fun := λ f, i.inv ≫ f,
  inv_fun := λ f, i.hom ≫ f,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }.

@[reducible]
def equiv_homset_right_of_iso
  (X : C) {Y Y' : C} (i : Y ≅ Y') :
  (X ⟶ Y) ≃ (X ⟶ Y') :=
{ to_fun := λ f, f ≫ i.hom,
  inv_fun := λ f, f ≫ i.inv,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }.

variable (i)
noncomputable
def biject_inclusion [ir : reflective i] {A B : C} [in_subcategory' i B] : (A ⟶ B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) :=
calc (A ⟶ B) ≃ (A ⟶ i.obj ((left_adjoint i).obj B)) : equiv_homset_right_of_iso _ (containment_iso _ _)
    ... ≃ ((left_adjoint i).obj A ⟶ (left_adjoint i).obj B) : (ir.adj.hom_equiv _ _).symm
    ... ≃ (i.obj ((left_adjoint i).obj A) ⟶ i.obj ((left_adjoint i).obj B)) : equiv_of_fully_faithful i
    ... ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) : equiv_homset_right_of_iso _ (containment_iso _ _).symm
variable {i}

lemma biject_inclusion_natural [ir : reflective i] {A B B' : C} [h : in_subcategory' i B] [h' : in_subcategory' i B'] (f : A ⟶ B) (g : B ⟶ B') :
  biject_inclusion i (f ≫ g) = biject_inclusion i f ≫ g :=
begin
  dsimp [biject_inclusion, containment_iso],
  haveI := h'.returning,
  haveI := h.returning,
  have : i.map
        (((is_right_adjoint.adj.hom_equiv A ((left_adjoint i).obj B')).symm)
           ((f ≫ g) ≫ is_right_adjoint.adj.unit.app B')) ≫
      inv (is_right_adjoint.adj.unit.app B') = (i.map
           (((is_right_adjoint.adj.hom_equiv A ((left_adjoint i).obj B)).symm)
              (f ≫ is_right_adjoint.adj.unit.app B)) ≫
         inv (is_right_adjoint.adj.unit.app B)) ≫
      g ↔ _ = _ := (as_iso (ir.adj.unit.app B')).comp_inv_eq,
  convert this.2 _, -- this should not be necessary
  clear this,
  dsimp [as_iso_hom],
  erw [assoc, assoc, ir.adj.unit.naturality, assoc, (as_iso _).inv_hom_id_assoc, functor.comp_map, ← functor.map_comp],
  rw [← ir.adj.hom_equiv_naturality_right_symm, assoc], refl,
end .

lemma biject_inclusion_natural_left [ir : reflective i] {A A' B : C} [h : in_subcategory' i B] (f : A ⟶ A') (g : A' ⟶ B) :
  biject_inclusion i (f ≫ g) = i.map ((left_adjoint i).map f) ≫ biject_inclusion i g :=
begin
  dsimp [biject_inclusion],
  erw [← i.map_comp_assoc, ← ir.adj.hom_equiv_naturality_left_symm, assoc],
end

lemma biject_inclusion_symm_id_eq [ir : reflective i] (A : C) :
  (biject_inclusion i).symm (𝟙 (i.obj ((left_adjoint i).obj A))) = ir.adj.unit.app A :=
begin
  rw equiv.symm_apply_eq,
  dsimp [biject_inclusion, containment_iso],
  rw [ir.adj.hom_equiv_counit],
  let η := ir.adj.unit,
  let ε := ir.adj.counit,
  let L := left_adjoint i,
  have : 𝟙 (i.obj ((left_adjoint i).obj A)) = _ ≫ inv (is_right_adjoint.adj.unit.app (i.obj ((left_adjoint i).obj A))) ↔ _ = _ := (as_iso (is_right_adjoint.adj.unit.app (i.obj ((left_adjoint i).obj A)))).eq_comp_inv,
  rw this, clear this,
  rw [id_comp, as_iso_hom],
  change η.app (i.obj (L.obj A)) = i.map (L.map (η.app A ≫ η.app (i.obj (L.obj A))) ≫ ε.app (L.obj (i.obj (L.obj A)))),
  rw [L.map_comp, assoc],
  haveI := nat_iso.is_iso_app_of_is_iso ε (L.obj A),
  erw [ir.adj.left_triangle_components, comp_id, ← cancel_mono (i.map (ε.app (L.obj A))), ir.adj.right_triangle_components,
       ← i.map_comp, ir.adj.left_triangle_components, i.map_id],
end

lemma biject_inclusion_is_comp_unit [ir : reflective i] {A B : C} [h : in_subcategory' i B] (f : i.obj ((left_adjoint i).obj A) ⟶ B) :
  (biject_inclusion i).symm f = ir.adj.unit.app _ ≫ f :=
by rw [← biject_inclusion_symm_id_eq A, (biject_inclusion i).symm_apply_eq,
       biject_inclusion_natural _ _, equiv.apply_symm_apply, id_comp]

variables [has_finite_products.{v₁} C] [has_finite_products.{v₁} D] [cartesian_closed C] (i)

class exponential_ideal extends reflective i :=
[ strength (A) {B} [in_subcategory' i B] : in_subcategory' i (A ⟹ B) ]

noncomputable def exponential_ideal_of [z : reflective i]
  (h : ∀ (A : C) (B : D), in_subcategory' i (A ⟹ i.obj B)) : exponential_ideal i :=
{ strength := λ A B inst,
  begin
    resetI,
    let ir : is_right_adjoint i := by apply_instance,
    let L := ir.left,
    let η := ir.adj.unit,
    haveI := h A (L.obj B),
    let i₁ : B ≅ i.obj (L.obj B) := containment_iso i B,
    let i₂ : A ⟹ i.obj (L.obj B) ≅ i.obj (L.obj (A ⟹ (i.obj (L.obj B)))) := containment_iso i (A ⟹ i.obj (L.obj B)),
    let : A ⟹ B ≅ i.obj (L.obj (A ⟹ B)),
      apply (exp A).map_iso i₁ ≪≫ i₂ ≪≫ (exp A ⋙ L ⋙ i).map_iso i₁.symm,
    refine ⟨_⟩,
    convert is_iso.of_iso this,
    change η.app (A ⟹ B) =
      (exp _).map (containment_iso _ _).hom ≫ η.app _ ≫ i.map (L.map ((exp _).map (containment_iso _ _).inv)),
    erw η.naturality_assoc,
    change η.app (A ⟹ B) = η.app (A ⟹ B) ≫ (exp A ⋙ L ⋙ _).map _ ≫ (exp A ⋙ L ⋙ _).map _,
    rw [← (exp A ⋙ L ⋙ _).map_comp, iso.hom_inv_id, functor.map_id],
    erw comp_id,
  end,
  ..z }

variables [exponential_ideal i]

noncomputable
def bijection (A B : C) (C' : D) : ((left_adjoint i).obj (A ⨯ B) ⟶ C') ≃ ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B ⟶ C') :=
calc _ ≃ (A ⨯ B ⟶ i.obj C') : _inst_6.to_reflective.adj.hom_equiv _ _
... ≃ (B ⨯ A ⟶ i.obj C') : equiv_homset_left_of_iso _ (limits.prod.braiding _ _)
... ≃ (A ⟶ B ⟹ i.obj C') : (exp.adjunction _).hom_equiv _ _
... ≃ (i.obj ((left_adjoint i).obj A) ⟶ B ⟹ i.obj C') :
  begin
    apply biject_inclusion i,
    apply exponential_ideal.strength,
  end
... ≃ (B ⨯ i.obj ((left_adjoint i).obj A) ⟶ i.obj C') : ((exp.adjunction _).hom_equiv _ _).symm
... ≃ (i.obj ((left_adjoint i).obj A) ⨯ B ⟶ i.obj C') : equiv_homset_left_of_iso _ (limits.prod.braiding _ _)
... ≃ (B ⟶ i.obj ((left_adjoint i).obj A) ⟹ i.obj C') : (exp.adjunction _).hom_equiv _ _
... ≃ (i.obj ((left_adjoint i).obj B) ⟶ i.obj ((left_adjoint i).obj A) ⟹ i.obj C') :
  begin
    apply biject_inclusion _,
    apply exponential_ideal.strength,
  end
... ≃ (i.obj ((left_adjoint i).obj A) ⨯ i.obj ((left_adjoint i).obj B) ⟶ i.obj C') : ((exp.adjunction _).hom_equiv _ _).symm
... ≃ (i.obj ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B) ⟶ i.obj C') : equiv_homset_left_of_iso _
  begin
    apply (as_iso (prod_comparison _ _ _)).symm,
    haveI : preserves_limits i := _inst_6.to_reflective.adj.right_adjoint_preserves_limits,
    apply_instance,
  end
... ≃ ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B ⟶ C') : (equiv_of_fully_faithful _).symm

variables {i}

lemma comp_inv_eq {X Y Z : C} (f : X ⟶ Y) (g : Z ⟶ Y) (h : Z ⟶ X) [is_iso f] :
  g ≫ inv f = h ↔ g = h ≫ f :=
(as_iso f).comp_inv_eq.

-- @[reassoc] lemma prod_comparison_natural (F : C ⥤ D) {A A' B B' : C} (f : A ⟶ A') (g : B ⟶ B') :
--   F.map (prod.map f g) ≫ prod_comparison F A' B' = prod_comparison F A B ≫ prod.map (F.map f) (F.map g) :=

lemma bijection_id (A B : C) : (bijection i A B _).symm (𝟙 _) = prod_comparison _ _ _ :=
begin
  dsimp [bijection],
  -- rw [equiv.symm_symm, equiv.symm_symm, equiv.symm_symm],
  -- dsimp [equiv_of_fully_faithful],
  rw [i.map_id, comp_id, biject_inclusion_is_comp_unit, biject_inclusion_is_comp_unit],
  let ir : is_right_adjoint i := by apply_instance,
  let L := ir.left,
  let adj : L ⊣ i := ir.adj,
  let η : _ ⟶ L ⋙ i := adj.unit,
  let ε : i ⋙ L ⟶ _ := adj.counit,
  change ((adj.hom_equiv (A ⨯ B) (L.obj A ⨯ L.obj B)).symm)
      (prod.lift limits.prod.snd limits.prod.fst ≫
         cartesian_closed.uncurry (η.app A ≫
              cartesian_closed.curry (prod.lift limits.prod.snd limits.prod.fst ≫
                   cartesian_closed.uncurry (η.app B ≫ cartesian_closed.curry _)))) =
    prod_comparison L A B,
  rw [uncurry_natural_left, uncurry_curry, uncurry_natural_left, uncurry_curry,
      ← adjunction.eq_hom_equiv_apply, prod.lift_map_assoc, prod.lift_map_assoc,
      comp_id, comp_id, ← assoc, comp_inv_eq, adjunction.hom_equiv_unit, assoc],
  apply prod.hom_ext,
  rw [assoc, prod.lift_fst, prod.lift_snd, assoc, assoc, prod_comparison, prod_comparison,
      prod.lift_fst, ← i.map_comp, prod.lift_fst],
  apply η.naturality,
  rw [assoc, prod.lift_snd, prod.lift_fst_assoc, assoc, assoc, prod_comparison,
      prod_comparison, prod.lift_snd, ← i.map_comp, prod.lift_snd],
  apply η.naturality,
end .

lemma bijection_natural (A B : C) (C' C'' : D) (f : ((left_adjoint i).obj (A ⨯ B) ⟶ C')) (g : C' ⟶ C'') : bijection i _ _ _ (f ≫ g) = bijection i _ _ _ f ≫ g :=
begin
  have : i.preimage (i.map g) = g := preimage_map g,
  conv_rhs {congr, skip, rw ← this},
  dsimp [bijection],
  rw [← preimage_comp, assoc, ← adjunction.hom_equiv_naturality_right_symm,
      is_right_adjoint.adj.hom_equiv_naturality_right, ← assoc,
      (exp.adjunction B).hom_equiv_naturality_right, ← biject_inclusion_natural _ _,
      ← (exp.adjunction (i.obj _)).hom_equiv_naturality_right, assoc,
      ← (exp.adjunction B).hom_equiv_naturality_right_symm, ← biject_inclusion_natural _ _],
end

open limits.prod

noncomputable
def preserves_pair_of_exponential_ideal (A B : C) : preserves_limit (pair.{v₁} A B) (is_right_adjoint.left i) :=
begin
  let ir : is_right_adjoint i := by apply_instance,
  let L := ir.left,
  let : L.obj (A ⨯ B) ≅ L.obj A ⨯ L.obj B := coyoneda.ext (λ Z, bijection i A B _) (λ _ _ _ _, bijection_natural _ _ _ _ _ _),
  have equate : prod_comparison L A B = this.hom := (bijection_id A B).symm,
  have : is_iso (prod_comparison L A B),
    rw equate, apply_instance,
  exactI preserves_pair.of_iso_comparison _ _ _,
end

variable (i)
noncomputable
def preserves_binary_products_of_exponential_ideal : preserves_limits_of_shape (discrete walking_pair) (is_right_adjoint.left i) :=
{ preserves_limit := λ K,
  begin
    apply preserves_limit_of_iso_diagram _ (diagram_iso_pair K).symm,
    apply preserves_pair_of_exponential_ideal,
  end }
end category_theory


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.adjunction.fully_faithful
import category_theory.sites.plus
import category_theory.limits.concrete_category
import category_theory.concrete_category.elementwise

/-!

# Sheafification

We construct the sheafification of a presheaf over a site `C` with values in `D` whenever
`D` is a concrete category for which the forgetful functor preserves the appropriate (co)limits
and reflects isomorphisms.

We generally follow the approach of https://stacks.math.columbia.edu/tag/00W1

-/

namespace category_theory

open category_theory.limits opposite

universes w v u
variables {C : Type u} [category.{v} C] {J : grothendieck_topology C}
variables {D : Type w} [category.{max v u} D]

section
variables [concrete_category.{max v u} D]

local attribute [instance]
  concrete_category.has_coe_to_sort
  concrete_category.has_coe_to_fun

/-- A concrete version of the multiequalizer, to be used below. -/
@[nolint has_nonempty_instance]
def meq {X : C} (P : Cᵒᵖ ⥤ D) (S : J.cover X) :=
{ x : Π (I : S.arrow), P.obj (op I.Y) //
  ∀ (I : S.relation), P.map I.g₁.op (x I.fst) = P.map I.g₂.op (x I.snd) }
end

namespace meq

variables [concrete_category.{max v u} D]

local attribute [instance]
  concrete_category.has_coe_to_sort
  concrete_category.has_coe_to_fun

instance {X} (P : Cᵒᵖ ⥤ D) (S : J.cover X) : has_coe_to_fun (meq P S)
  (λ x, Π (I : S.arrow), P.obj (op I.Y)) := ⟨λ x, x.1⟩

@[ext]
lemma ext {X} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x y : meq P S)
  (h : ∀ I : S.arrow, x I = y I) : x = y := subtype.ext $ funext $ h

lemma condition {X} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (I : S.relation) :
  P.map I.g₁.op (x ((S.index P).fst_to I)) = P.map I.g₂.op (x ((S.index P).snd_to I)) := x.2 _

/-- Refine a term of `meq P T` with respect to a refinement `S ⟶ T` of covers. -/
def refine {X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X} (x : meq P T) (e : S ⟶ T) :
  meq P S :=
⟨λ I, x ⟨I.Y, I.f, (le_of_hom e) _ I.hf⟩,
  λ I, x.condition ⟨I.Y₁, I.Y₂, I.Z, I.g₁, I.g₂, I.f₁, I.f₂,
    (le_of_hom e) _ I.h₁, (le_of_hom e) _ I.h₂, I.w⟩⟩

@[simp]
lemma refine_apply {X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X} (x : meq P T) (e : S ⟶ T)
  (I : S.arrow) : x.refine e I = x ⟨I.Y, I.f, (le_of_hom e) _ I.hf⟩ := rfl

/-- Pull back a term of `meq P S` with respect to a morphism `f : Y ⟶ X` in `C`. -/
def pullback {Y X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (f : Y ⟶ X) :
  meq P ((J.pullback f).obj S) :=
⟨λ I, x ⟨_,I.f ≫ f, I.hf⟩, λ I, x.condition
  ⟨I.Y₁, I.Y₂, I.Z, I.g₁, I.g₂, I.f₁ ≫ f, I.f₂ ≫ f, I.h₁, I.h₂, by simp [reassoc_of I.w]⟩ ⟩

@[simp]
lemma pullback_apply {Y X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (f : Y ⟶ X)
  (I : ((J.pullback f).obj S).arrow) : x.pullback f I = x ⟨_, I.f ≫ f, I.hf⟩ := rfl

@[simp]
lemma pullback_refine {Y X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X} (h : S ⟶ T)
  (f : Y ⟶ X) (x : meq P T) : (x.pullback f).refine
  ((J.pullback f).map h) = (refine x h).pullback _ := rfl

/-- Make a term of `meq P S`. -/
def mk {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : P.obj (op X)) : meq P S :=
⟨λ I, P.map I.f.op x, λ I, by { dsimp, simp only [← comp_apply, ← P.map_comp, ← op_comp, I.w] }⟩

lemma mk_apply {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : P.obj (op X)) (I : S.arrow) :
  mk S x I = P.map I.f.op x := rfl

variable [preserves_limits (forget D)]

/-- The equivalence between the type associated to `multiequalizer (S.index P)` and `meq P S`. -/
noncomputable
def equiv {X : C} (P : Cᵒᵖ ⥤ D) (S : J.cover X) [has_multiequalizer (S.index P)] :
  (multiequalizer (S.index P) : D) ≃ meq P S :=
limits.concrete.multiequalizer_equiv _

@[simp]
lemma equiv_apply {X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} [has_multiequalizer (S.index P)]
  (x : multiequalizer (S.index P)) (I : S.arrow) :
equiv P S x I = multiequalizer.ι (S.index P) I x := rfl

@[simp]
lemma equiv_symm_eq_apply {X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} [has_multiequalizer (S.index P)]
  (x : meq P S) (I : S.arrow) : multiequalizer.ι (S.index P) I ((meq.equiv P S).symm x) = x I :=
begin
  let z := (meq.equiv P S).symm x,
  rw ← equiv_apply,
  simp,
end

end meq

namespace grothendieck_topology

namespace plus

variables [concrete_category.{max v u} D]

local attribute [instance]
  concrete_category.has_coe_to_sort
  concrete_category.has_coe_to_fun

variable [preserves_limits (forget D)]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]

noncomputable theory

/-- Make a term of `(J.plus_obj P).obj (op X)` from `x : meq P S`. -/
def mk {X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) : (J.plus_obj P).obj (op X) :=
colimit.ι (J.diagram P X) (op S) ((meq.equiv P S).symm x)

lemma res_mk_eq_mk_pullback {Y X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (f : Y ⟶ X) :
  (J.plus_obj P).map f.op (mk x) = mk (x.pullback f) :=
begin
  dsimp [mk, plus_obj],
  simp only [← comp_apply, colimit.ι_pre, ι_colim_map_assoc],
  simp_rw [comp_apply],
  congr' 1,
  apply_fun meq.equiv P _,
  erw equiv.apply_symm_apply,
  ext i,
  simp only [diagram_pullback_app,
    meq.pullback_apply, meq.equiv_apply, ← comp_apply],
  erw [multiequalizer.lift_ι, meq.equiv_symm_eq_apply],
  cases i, refl,
end

lemma to_plus_mk {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : P.obj (op X)) :
  (J.to_plus P).app _ x = mk (meq.mk S x) :=
begin
  dsimp [mk, to_plus],
  let e : S ⟶ ⊤ := hom_of_le (order_top.le_top _),
  rw ← colimit.w _ e.op,
  delta cover.to_multiequalizer,
  simp only [comp_apply],
  congr' 1,
  dsimp [diagram],
  apply concrete.multiequalizer_ext,
  intros i,
  simpa only [← comp_apply, category.assoc, multiequalizer.lift_ι,
    category.comp_id, meq.equiv_symm_eq_apply],
end

lemma to_plus_apply {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : meq P S) (I : S.arrow) :
  (J.to_plus P).app _ (x I) = (J.plus_obj P).map I.f.op (mk x) :=
begin
  dsimp only [to_plus, plus_obj],
  delta cover.to_multiequalizer,
  dsimp [mk],
  simp only [← comp_apply, colimit.ι_pre, ι_colim_map_assoc],
  simp only [comp_apply],
  dsimp only [functor.op],
  let e : (J.pullback I.f).obj (unop (op S)) ⟶ ⊤ := hom_of_le (order_top.le_top _),
  rw ← colimit.w _ e.op,
  simp only [comp_apply],
  congr' 1,
  apply concrete.multiequalizer_ext,
  intros i,
  dsimp [diagram],
  simp only [← comp_apply, category.assoc, multiequalizer.lift_ι,
    category.comp_id, meq.equiv_symm_eq_apply],
  let RR : S.relation :=
    ⟨_, _, _, i.f, 𝟙 _, I.f, i.f ≫ I.f, I.hf, sieve.downward_closed _ I.hf _, by simp⟩,
  cases I,
  erw x.condition RR,
  simpa [RR],
end

lemma to_plus_eq_mk {X : C} {P : Cᵒᵖ ⥤ D} (x : P.obj (op X)) :
  (J.to_plus P).app _ x = mk (meq.mk ⊤ x) :=
begin
  dsimp [mk, to_plus],
  delta cover.to_multiequalizer,
  simp only [comp_apply],
  congr' 1,
  apply_fun (meq.equiv P ⊤),
  ext i,
  simpa,
end

variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]

lemma exists_rep {X : C} {P : Cᵒᵖ ⥤ D} (x : (J.plus_obj P).obj (op X)) :
  ∃ (S : J.cover X) (y : meq P S), x = mk y :=
begin
  obtain ⟨S,y,h⟩ := concrete.colimit_exists_rep (J.diagram P X) x,
  use [S.unop, meq.equiv _ _ y],
  rw ← h,
  dsimp [mk],
  simp,
end

lemma eq_mk_iff_exists {X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X}
  (x : meq P S) (y : meq P T) : mk x = mk y ↔ (∃ (W : J.cover X) (h1 : W ⟶ S) (h2 : W ⟶ T),
    x.refine h1 = y.refine h2) :=
begin
  split,
  { intros h,
    obtain ⟨W, h1, h2, hh⟩ := concrete.colimit_exists_of_rep_eq _ _ _ h,
    use [W.unop, h1.unop, h2.unop],
    ext I,
    apply_fun (multiequalizer.ι (W.unop.index P) I) at hh,
    convert hh,
    all_goals
    { dsimp [diagram],
      simp only [← comp_apply, multiequalizer.lift_ι, category.comp_id, meq.equiv_symm_eq_apply],
      cases I, refl } },
  { rintros ⟨S,h1,h2,e⟩,
    apply concrete.colimit_rep_eq_of_exists,
    use [(op S), h1.op, h2.op],
    apply concrete.multiequalizer_ext,
    intros i,
    apply_fun (λ ee, ee i) at e,
    convert e,
    all_goals
    { dsimp [diagram],
      simp only [← comp_apply, multiequalizer.lift_ι, meq.equiv_symm_eq_apply],
      cases i, refl } },
end

/-- `P⁺` is always separated. -/
theorem sep {X : C} (P : Cᵒᵖ ⥤ D) (S : J.cover X) (x y : (J.plus_obj P).obj (op X))
  (h : ∀ (I : S.arrow), (J.plus_obj P).map I.f.op x = (J.plus_obj P).map I.f.op y) :
  x = y :=
begin
  -- First, we choose representatives for x and y.
  obtain ⟨Sx,x,rfl⟩ := exists_rep x,
  obtain ⟨Sy,y,rfl⟩ := exists_rep y,
  simp only [res_mk_eq_mk_pullback] at h,

  -- Next, using our assumption,
  -- choose covers over which the pullbacks of these representatives become equal.
  choose W h1 h2 hh using λ (I : S.arrow), (eq_mk_iff_exists _ _).mp (h I),

  -- To prove equality, it suffices to prove that there exists a cover over which
  -- the representatives become equal.
  rw eq_mk_iff_exists,

  -- Construct the cover over which the representatives become equal by combining the various
  -- covers chosen above.
  let B : J.cover X := S.bind W,
  use B,

  -- Prove that this cover refines the two covers over which our representatives are defined
  -- and use these proofs.
  let ex : B ⟶ Sx := hom_of_le begin
    rintros Y f ⟨Z,e1,e2,he2,he1,hee⟩,
    rw ← hee,
    apply le_of_hom (h1 ⟨_, _, he2⟩),
    exact he1,
  end,
  let ey : B ⟶ Sy := hom_of_le begin
    rintros Y f ⟨Z,e1,e2,he2,he1,hee⟩,
    rw ← hee,
    apply le_of_hom (h2 ⟨_, _, he2⟩),
    exact he1,
  end,
  use [ex, ey],

  -- Now prove that indeed the representatives become equal over `B`.
  -- This will follow by using the fact that our representatives become
  -- equal over the chosen covers.
  ext1 I,
  let IS : S.arrow := I.from_middle,
  specialize hh IS,
  let IW : (W IS).arrow := I.to_middle,
  apply_fun (λ e, e IW) at hh,
  convert hh,
  { let Rx : Sx.relation := ⟨I.Y, I.Y, I.Y, 𝟙 _, 𝟙 _, I.f,
      I.to_middle_hom ≫ I.from_middle_hom, _, _, by simp [I.middle_spec]⟩,
    have := x.condition Rx,
    simpa using this },
  { let Ry : Sy.relation := ⟨I.Y, I.Y, I.Y, 𝟙 _, 𝟙 _, I.f,
      I.to_middle_hom ≫ I.from_middle_hom, _, _, by simp [I.middle_spec]⟩,
    have := y.condition Ry,
    simpa using this },
end

lemma inj_of_sep (P : Cᵒᵖ ⥤ D) (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
  (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y) (X : C) :
  function.injective ((J.to_plus P).app (op X)) :=
begin
  intros x y h,
  simp only [to_plus_eq_mk] at h,
  rw eq_mk_iff_exists at h,
  obtain ⟨W, h1, h2, hh⟩ := h,
  apply hsep X W,
  intros I,
  apply_fun (λ e, e I) at hh,
  exact hh
end

/-- An auxiliary definition to be used in the proof of `exists_of_sep` below.
  Given a compatible family of local sections for `P⁺`, and representatives of said sections,
  construct a compatible family of local sections of `P` over the combination of the covers
  associated to the representatives.
  The separatedness condition is used to prove compatibility among these local sections of `P`. -/
def meq_of_sep (P : Cᵒᵖ ⥤ D)
  (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
    (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y)
  (X : C) (S : J.cover X)
  (s : meq (J.plus_obj P) S)
  (T : Π (I : S.arrow), J.cover I.Y)
  (t : Π (I : S.arrow), meq P (T I))
  (ht : ∀ (I : S.arrow), s I = mk (t I)) : meq P (S.bind T) :=
{ val := λ I, t I.from_middle I.to_middle,
  property := begin
    intros II,
    apply inj_of_sep P hsep,
    rw [← comp_apply, ← comp_apply, (J.to_plus P).naturality, (J.to_plus P).naturality,
      comp_apply, comp_apply],
    erw [to_plus_apply (T II.fst.from_middle) (t II.fst.from_middle) II.fst.to_middle,
         to_plus_apply (T II.snd.from_middle) (t II.snd.from_middle) II.snd.to_middle,
         ← ht, ← ht, ← comp_apply, ← comp_apply, ← (J.plus_obj P).map_comp,
         ← (J.plus_obj P).map_comp],
    rw [← op_comp, ← op_comp],
    let IR : S.relation :=
      ⟨_, _, _, II.g₁ ≫ II.fst.to_middle_hom, II.g₂ ≫ II.snd.to_middle_hom,
        II.fst.from_middle_hom, II.snd.from_middle_hom, II.fst.from_middle_condition,
        II.snd.from_middle_condition, _⟩,
    swap, { simp only [category.assoc, II.fst.middle_spec, II.snd.middle_spec], apply II.w },
    exact s.condition IR,
  end }

theorem exists_of_sep (P : Cᵒᵖ ⥤ D)
  (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
    (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y)
  (X : C) (S : J.cover X)
  (s : meq (J.plus_obj P) S) :
  ∃ t : (J.plus_obj P).obj (op X), meq.mk S t = s :=
begin
  have inj : ∀ (X : C), function.injective ((J.to_plus P).app (op X)) := inj_of_sep _ hsep,

  -- Choose representatives for the given local sections.
  choose T t ht using λ I, exists_rep (s I),

  -- Construct a large cover over which we will define a representative that will
  -- provide the gluing of the given local sections.
  let B : J.cover X := S.bind T,
  choose Z e1 e2 he2 he1 hee using λ I : B.arrow, I.hf,

  -- Construct a compatible system of local sections over this large cover, using the chosen
  -- representatives of our local sections.
  -- The compatilibity here follows from the separatedness assumption.
  let w : meq P B := meq_of_sep P hsep X S s T t ht,

  -- The associated gluing will be the candidate section.
  use mk w,
  ext I,
  erw [ht, res_mk_eq_mk_pullback],

  -- Use the separatedness of `P⁺` to prove that this is indeed a gluing of our
  -- original local sections.
  apply sep P (T I),
  intros II,
  simp only [res_mk_eq_mk_pullback, eq_mk_iff_exists],

  -- It suffices to prove equality for representatives over a
  -- convenient sufficiently large cover...
  use (J.pullback II.f).obj (T I),
  let e0 : (J.pullback II.f).obj (T I) ⟶ (J.pullback II.f).obj ((J.pullback I.f).obj B) :=
    hom_of_le begin
      intros Y f hf,
      apply sieve.le_pullback_bind _ _ _ I.hf,
      { cases I,
        exact hf },
    end,
  use [e0, 𝟙 _],
  ext IV,
  dsimp only [meq.refine_apply, meq.pullback_apply, w],
  let IA : B.arrow := ⟨_, (IV.f ≫ II.f) ≫ I.f, _⟩,
  swap,
  { refine ⟨I.Y, _, _, I.hf, _, rfl⟩,
    apply sieve.downward_closed,
    convert II.hf,
    cases I, refl },
  let IB : S.arrow := IA.from_middle,
  let IC : (T IB).arrow := IA.to_middle,
  let ID : (T I).arrow := ⟨IV.Y, IV.f ≫ II.f, sieve.downward_closed (T I) II.hf IV.f⟩,
  change t IB IC = t I ID,
  apply inj IV.Y,
  erw [to_plus_apply (T I) (t I) ID, to_plus_apply (T IB) (t IB) IC, ← ht, ← ht],

  -- Conclude by constructing the relation showing equality...
  let IR : S.relation := ⟨_, _, IV.Y, IC.f, ID.f, IB.f, I.f, _, I.hf, IA.middle_spec⟩,
  convert s.condition IR,
  cases I, refl,
end

variable [reflects_isomorphisms (forget D)]

/-- If `P` is separated, then `P⁺` is a sheaf. -/
theorem is_sheaf_of_sep (P : Cᵒᵖ ⥤ D)
  (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
    (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y) :
  presheaf.is_sheaf J (J.plus_obj P) :=
begin
  rw presheaf.is_sheaf_iff_multiequalizer,
  intros X S,
  apply is_iso_of_reflects_iso _ (forget D),
  rw is_iso_iff_bijective,
  split,
  { intros x y h,
    apply sep P S _ _,
    intros I,
    apply_fun (meq.equiv _ _) at h,
    apply_fun (λ e, e I) at h,
    convert h,
    { erw [meq.equiv_apply, ← comp_apply, multiequalizer.lift_ι] },
    { erw [meq.equiv_apply, ← comp_apply, multiequalizer.lift_ι] } },
  { rintros (x : (multiequalizer (S.index _) : D)),
    obtain ⟨t,ht⟩ := exists_of_sep P hsep X S (meq.equiv _ _ x),
    use t,
    apply_fun meq.equiv _ _,
    swap, { apply_instance },
    rw ← ht,
    ext i,
    dsimp,
    rw [← comp_apply, multiequalizer.lift_ι],
    refl }
end

variable (J)

/-- `P⁺⁺` is always a sheaf. -/
theorem is_sheaf_plus_plus (P : Cᵒᵖ ⥤ D) :
  presheaf.is_sheaf J (J.plus_obj (J.plus_obj P)) :=
begin
  apply is_sheaf_of_sep,
  intros X S x y,
  apply sep,
end

end plus

variables (J)
variables
  [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
  [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]

/-- The sheafification of a presheaf `P`.
*NOTE:* Additional hypotheses are needed to obtain a proof that this is a sheaf! -/
def sheafify (P : Cᵒᵖ ⥤ D) : Cᵒᵖ ⥤ D := J.plus_obj (J.plus_obj P)

/-- The canonical map from `P` to its sheafification. -/
def to_sheafify (P : Cᵒᵖ ⥤ D) : P ⟶ J.sheafify P :=
J.to_plus P ≫ J.plus_map (J.to_plus P)

/-- The canonical map on sheafifications induced by a morphism. -/
def sheafify_map {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) : J.sheafify P ⟶ J.sheafify Q :=
J.plus_map $ J.plus_map η

@[simp]
lemma sheafify_map_id (P : Cᵒᵖ ⥤ D) : J.sheafify_map (𝟙 P) = 𝟙 (J.sheafify P) :=
by { dsimp [sheafify_map, sheafify], simp }

@[simp]
lemma sheafify_map_comp {P Q R : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (γ : Q ⟶ R) :
  J.sheafify_map (η ≫ γ) = J.sheafify_map η ≫ J.sheafify_map γ :=
by { dsimp [sheafify_map, sheafify], simp }

@[simp, reassoc]
lemma to_sheafify_naturality {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) :
  η ≫ J.to_sheafify _ = J.to_sheafify _ ≫ J.sheafify_map η :=
by { dsimp [sheafify_map, sheafify, to_sheafify], simp }

variable (D)

/-- The sheafification of a presheaf `P`, as a functor.
*NOTE:* Additional hypotheses are needed to obtain a proof that this is a sheaf! -/
def sheafification : (Cᵒᵖ ⥤ D) ⥤ Cᵒᵖ ⥤ D := (J.plus_functor D ⋙ J.plus_functor D)

@[simp]
lemma sheafification_obj (P : Cᵒᵖ ⥤ D) : (J.sheafification D).obj P = J.sheafify P := rfl

@[simp]
lemma sheafification_map {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) : (J.sheafification D).map η =
  J.sheafify_map η := rfl

/-- The canonical map from `P` to its sheafification, as a natural transformation.
*Note:* We only show this is a sheaf under additional hypotheses on `D`. -/
def to_sheafification : 𝟭 _ ⟶ sheafification J D :=
J.to_plus_nat_trans D ≫ whisker_right (J.to_plus_nat_trans D) (J.plus_functor D)

@[simp]
lemma to_sheafification_app (P : Cᵒᵖ ⥤ D) : (J.to_sheafification D).app P = J.to_sheafify P := rfl

variable {D}

lemma is_iso_to_sheafify {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  is_iso (J.to_sheafify P) :=
begin
  dsimp [to_sheafify],
  haveI : is_iso (J.to_plus P) := by { apply is_iso_to_plus_of_is_sheaf J P hP },
  haveI : is_iso ((J.plus_functor D).map (J.to_plus P)) := by { apply functor.map_is_iso },
  exact @is_iso.comp_is_iso _ _ _ _ _ (J.to_plus P)
    ((J.plus_functor D).map (J.to_plus P)) _ _,
end

/-- If `P` is a sheaf, then `P` is isomorphic to `J.sheafify P`. -/
def iso_sheafify {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  P ≅ J.sheafify P :=
by letI := is_iso_to_sheafify J hP; exactI as_iso (J.to_sheafify P)

@[simp]
lemma iso_sheafify_hom {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  (J.iso_sheafify hP).hom = J.to_sheafify P := rfl

/-- Given a sheaf `Q` and a morphism `P ⟶ Q`, construct a morphism from
`J.sheafifcation P` to `Q`. -/
def sheafify_lift {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q) :
  J.sheafify P ⟶ Q := J.plus_lift (J.plus_lift η hQ) hQ

@[simp, reassoc]
lemma to_sheafify_sheafify_lift {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q) :
  J.to_sheafify P ≫ sheafify_lift J η hQ = η :=
by { dsimp only [sheafify_lift, to_sheafify], simp }

lemma sheafify_lift_unique {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q)
  (γ : J.sheafify P ⟶ Q) :
  J.to_sheafify P ≫ γ = η → γ = sheafify_lift J η hQ :=
begin
  intros h,
  apply plus_lift_unique,
  apply plus_lift_unique,
  rw [← category.assoc, ← plus_map_to_plus],
  exact h,
end

@[simp]
lemma iso_sheafify_inv {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  (J.iso_sheafify hP).inv = J.sheafify_lift (𝟙 _) hP :=
begin
  apply J.sheafify_lift_unique,
  simp [iso.comp_inv_eq],
end

lemma sheafify_hom_ext {P Q : Cᵒᵖ ⥤ D} (η γ : J.sheafify P ⟶ Q) (hQ : presheaf.is_sheaf J Q)
  (h : J.to_sheafify P ≫ η = J.to_sheafify P ≫ γ) : η = γ :=
begin
  apply J.plus_hom_ext _ _ hQ,
  apply J.plus_hom_ext _ _ hQ,
  rw [← category.assoc, ← category.assoc, ← plus_map_to_plus],
  exact h,
end

@[simp, reassoc]
lemma sheafify_map_sheafify_lift {P Q R : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (γ : Q ⟶ R)
  (hR : presheaf.is_sheaf J R) :
  J.sheafify_map η ≫ J.sheafify_lift γ hR = J.sheafify_lift (η ≫ γ) hR :=
begin
  apply J.sheafify_lift_unique,
  rw [← category.assoc, ← J.to_sheafify_naturality,
    category.assoc, to_sheafify_sheafify_lift],
end

end grothendieck_topology

variables (J)
variables
  [concrete_category.{max v u} D]
  [preserves_limits (forget D)]
  [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
  [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
  [reflects_isomorphisms (forget D)]

lemma grothendieck_topology.sheafify_is_sheaf (P : Cᵒᵖ ⥤ D) :
  presheaf.is_sheaf J (J.sheafify P) :=
grothendieck_topology.plus.is_sheaf_plus_plus _ _

variables (D)

/-- The sheafification functor, as a functor taking values in `Sheaf`. -/
@[simps]
def presheaf_to_Sheaf : (Cᵒᵖ ⥤ D) ⥤ Sheaf J D :=
{ obj := λ P, ⟨J.sheafify P, J.sheafify_is_sheaf P⟩,
  map := λ P Q η, ⟨J.sheafify_map η⟩,
  map_id' := λ P, Sheaf.hom.ext _ _ $ J.sheafify_map_id _,
  map_comp' := λ P Q R f g, Sheaf.hom.ext _ _ $ J.sheafify_map_comp _ _ }

instance presheaf_to_Sheaf_preserves_zero_morphisms [preadditive D] :
  (presheaf_to_Sheaf J D).preserves_zero_morphisms  :=
{ map_zero' := λ F G, by { ext, erw [colimit.ι_map, comp_zero, J.plus_map_zero,
    J.diagram_nat_trans_zero, zero_comp] } }

/-- The sheafification functor is left adjoint to the forgetful functor. -/
@[simps unit_app counit_app_val]
def sheafification_adjunction : presheaf_to_Sheaf J D ⊣ Sheaf_to_presheaf J D :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ P Q,
  { to_fun := λ e, J.to_sheafify P ≫ e.val,
    inv_fun := λ e, ⟨J.sheafify_lift e Q.2⟩,
    left_inv := λ e, Sheaf.hom.ext _ _ $ (J.sheafify_lift_unique _ _ _ rfl).symm,
    right_inv := λ e, J.to_sheafify_sheafify_lift _ _ },
  hom_equiv_naturality_left_symm' := begin
    intros P Q R η γ, ext1, dsimp, symmetry,
    apply J.sheafify_map_sheafify_lift,
  end,
  hom_equiv_naturality_right' := λ P Q R η γ, by { dsimp, rw category.assoc } }

instance Sheaf_to_presheaf_is_right_adjoint : is_right_adjoint (Sheaf_to_presheaf J D) :=
⟨_, sheafification_adjunction J D⟩

instance presheaf_mono_of_mono {F G : Sheaf J D} (f : F ⟶ G) [mono f] : mono f.1 :=
(Sheaf_to_presheaf J D).map_mono _

lemma Sheaf.hom.mono_iff_presheaf_mono {F G : Sheaf J D} (f : F ⟶ G) : mono f ↔ mono f.1 :=
⟨λ m, by { resetI, apply_instance },
 λ m, by { resetI, exact Sheaf.hom.mono_of_presheaf_mono J D f }⟩

variables {J D}
/-- A sheaf `P` is isomorphic to its own sheafification. -/
@[simps]
def sheafification_iso (P : Sheaf J D) :
  P ≅ (presheaf_to_Sheaf J D).obj P.val :=
{ hom := ⟨(J.iso_sheafify P.2).hom⟩,
  inv := ⟨(J.iso_sheafify P.2).inv⟩,
  hom_inv_id' := by { ext1, apply (J.iso_sheafify P.2).hom_inv_id },
  inv_hom_id' := by { ext1, apply (J.iso_sheafify P.2).inv_hom_id } }

instance is_iso_sheafification_adjunction_counit (P : Sheaf J D) :
  is_iso ((sheafification_adjunction J D).counit.app P) :=
is_iso_of_fully_faithful (Sheaf_to_presheaf J D) _

instance sheafification_reflective : is_iso (sheafification_adjunction J D).counit :=
nat_iso.is_iso_of_is_iso_app _

end category_theory


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

! This file was ported from Lean 3 source module tactic.doc_commands
! leanprover-community/mathlib commit bc40b44c260045cc3e7ea7e29a9080cd8e92bd57
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/

/-!
# Documentation commands

We generate html documentation from mathlib. It is convenient to collect lists of tactics, commands,
notes, etc. To facilitate this, we declare these documentation entries in the library
using special commands.

* `library_note` adds a note describing a certain feature or design decision. These can be
  referenced in doc strings with the text `note [name of note]`.
* `add_tactic_doc` adds an entry documenting an interactive tactic, command, hole command, or
  attribute.

Since these commands are used in files imported by `tactic.core`, this file has no imports.

## Implementation details

`library_note note_id note_msg` creates a declaration `` `library_note.i `` for some `i`.
This declaration is a pair of strings `note_id` and `note_msg`, and it gets tagged with the
`library_note` attribute.

Similarly, `add_tactic_doc` creates a declaration `` `tactic_doc.i `` that stores the provided
information.
-/

/- warning: string.hash -> String.hash is a dubious translation:
lean 3 declaration is
  String -> Nat
but is expected to have type
  ([mdata borrowed:1 String]) -> UInt64
Case conversion may be inaccurate. Consider using '#align string.hash String.hashₓ'. -/
/-- A rudimentary hash function on strings. -/
def String.hash (s : String) : ℕ :=
  s.fold 1 fun h c => (33 * h + c.val) % unsignedSz
#align string.hash String.hash

/-- Get the last component of a name, and convert it to a string. -/
unsafe def name.last : Name → String
  | Name.mk_string s _ => s
  | Name.mk_numeral n _ => repr n
  | anonymous => "[anonymous]"
#align name.last name.last

open Tactic

/-- `copy_doc_string fr to` copies the docstring from the declaration named `fr`
to each declaration named in the list `to`. -/
unsafe def tactic.copy_doc_string (fr : Name) (to : List Name) : tactic Unit := do
  let fr_ds ← doc_string fr
  to fun tgt => add_doc_string tgt fr_ds
#align tactic.copy_doc_string tactic.copy_doc_string

open Lean Lean.Parser Interactive

/-- `copy_doc_string source → target_1 target_2 ... target_n` copies the doc string of the
declaration named `source` to each of `target_1`, `target_2`, ..., `target_n`.
 -/
@[user_command]
unsafe def copy_doc_string_cmd (_ : parse (tk "copy_doc_string")) : parser Unit := do
  let fr ← parser.ident
  tk "->"
  let to ← parser.many parser.ident
  let expr.const fr _ ← resolve_name fr
  let to ← parser.of_tactic (to.mapM fun n => expr.const_name <$> resolve_name n)
  tactic.copy_doc_string fr to
#align copy_doc_string_cmd copy_doc_string_cmd

/-! ### The `library_note` command -/

/-- A user attribute `library_note` for tagging decls of type `string × string` for use in note
output. -/
@[user_attribute]
unsafe def library_note_attr : user_attribute
    where
  Name := `library_note
  descr := "Notes about library features to be included in documentation"
  parser := failed
#align library_note_attr library_note_attr

/-- `mk_reflected_definition name val` constructs a definition declaration by reflection.

Example: ``mk_reflected_definition `foo 17`` constructs the definition
declaration corresponding to `def foo : ℕ := 17`
-/
unsafe def mk_reflected_definition (decl_name : Name) {type} [reflected _ type] (body : type)
    [reflected _ body] : declaration :=
  mk_definition decl_name (reflect type).collect_univ_params (reflect type) (reflect body)
#align mk_reflected_definition mk_reflected_definition

/--
If `note_name` and `note` are strings, `add_library_note note_name note` adds a declaration named
`library_note.<note_name>` with `note` as the docstring and tags it with the `library_note`
attribute.
-/
unsafe def tactic.add_library_note (note_name note : String) : tactic Unit := do
  let decl_name := .str `library_note note_name
  add_decl <| mk_reflected_definition decl_name ()
  add_doc_string decl_name note
  library_note_attr decl_name () tt none
#align tactic.add_library_note tactic.add_library_note

open Tactic

/-- A command to add library notes. Syntax:
```
/--
note message
-/
library_note "note id"
```
-/
@[user_command]
unsafe def library_note (mi : interactive.decl_meta_info) (_ : parse (tk "library_note")) :
    parser Unit := do
  let note_name ← parser.pexpr
  let note_name ← eval_pexpr String note_name
  let some doc_string ← pure mi.doc_string |
    fail "library_note requires a doc string"
  add_library_note note_name doc_string
#align library_note library_note

/-- Collects all notes in the current environment.
Returns a list of pairs `(note_id, note_content)` -/
unsafe def tactic.get_library_notes : tactic (List (String × String)) :=
  attribute.get_instances `library_note >>=
    List.mapM fun dcl => Prod.mk dcl.getLast <$> doc_string dcl
#align tactic.get_library_notes tactic.get_library_notes

/-! ### The `add_tactic_doc_entry` command -/

/-- The categories of tactic doc entry. -/
inductive DocCategory
  | tactic
  | cmd
  | hole_cmd
  | attr
  deriving DecidableEq, has_reflect
#align doc_category DocCategory

/-- Format a `doc_category` -/
unsafe def doc_category.to_string : DocCategory → String
  | DocCategory.tactic => "tactic"
  | DocCategory.cmd => "command"
  | DocCategory.hole_cmd => "hole_command"
  | DocCategory.attr => "attribute"
#align doc_category.to_string doc_category.to_string

unsafe instance : has_to_format DocCategory :=
  ⟨↑doc_category.to_string⟩

/-- The information used to generate a tactic doc entry -/
structure TacticDocEntry where
  Name : String
  category : DocCategory
  declNames : List Name
  tags : List String := []
  inheritDescriptionFrom : Option Name := none
  deriving has_reflect
#align tactic_doc_entry TacticDocEntry

/-- Turns a `tactic_doc_entry` into a JSON representation. -/
unsafe def tactic_doc_entry.to_json (d : TacticDocEntry) (desc : String) : json :=
  json.object
    [("name", d.Name), ("category", d.category.toString),
      ("decl_names", d.declNames.map (json.of_string ∘ toString)),
      ("tags", d.tags.map json.of_string), ("description", desc)]
#align tactic_doc_entry.to_json tactic_doc_entry.to_json

unsafe instance tactic_doc_entry.has_to_string : ToString (TacticDocEntry × String) :=
  ⟨fun ⟨doc, desc⟩ => json.unparse (doc.to_json desc)⟩
#align tactic_doc_entry.has_to_string tactic_doc_entry.has_to_string

/-- A user attribute `tactic_doc` for tagging decls of type `tactic_doc_entry`
for use in doc output -/
@[user_attribute]
unsafe def tactic_doc_entry_attr : user_attribute
    where
  Name := `tactic_doc
  descr := "Information about a tactic to be included in documentation"
  parser := failed
#align tactic_doc_entry_attr tactic_doc_entry_attr

/-- Collects everything in the environment tagged with the attribute `tactic_doc`. -/
unsafe def tactic.get_tactic_doc_entries : tactic (List (TacticDocEntry × String)) :=
  attribute.get_instances `tactic_doc >>=
    List.mapM fun dcl => Prod.mk <$> (mk_const dcl >>= eval_expr TacticDocEntry) <*> doc_string dcl
#align tactic.get_tactic_doc_entries tactic.get_tactic_doc_entries

/-- `add_tactic_doc tde` adds a declaration to the environment
with `tde` as its body and tags it with the `tactic_doc`
attribute. If `tde.decl_names` has exactly one entry `` `decl`` and
if `tde.description` is the empty string, `add_tactic_doc` uses the doc
string of `decl` as the description. -/
unsafe def tactic.add_tactic_doc (tde : TacticDocEntry) (doc : Option String) : tactic Unit := do
  let desc ←
    doc <|> do
        let inh_id ←
          match tde.inheritDescriptionFrom, tde.declNames with
            | some inh_id, _ => pure inh_id
            | none, [inh_id] => pure inh_id
            | none, _ =>
              fail
                "A tactic doc entry must either:\n 1. have a description written as a doc-string for the `add_tactic_doc` invocation, or\n 2. have a single declaration in the `decl_names` field, to inherit a description from, or\n 3. explicitly indicate the declaration to inherit the description from using\n    `inherit_description_from`."
        doc_string inh_id <|> fail (toString inh_id ++ " has no doc string")
  let decl_name := .str (.str `tactic_doc tde.category.toString) tde.Name
  add_decl <| mk_definition decl_name [] q(TacticDocEntry) (reflect tde)
  add_doc_string decl_name desc
  tactic_doc_entry_attr decl_name () tt none
#align tactic.add_tactic_doc tactic.add_tactic_doc

/-- A command used to add documentation for a tactic, command, hole command, or attribute.

Usage: after defining an interactive tactic, command, or attribute,
add its documentation as follows.
```lean
/--
describe what the command does here
-/
add_tactic_doc
{ name := "display name of the tactic",
  category := cat,
  decl_names := [`dcl_1, `dcl_2],
  tags := ["tag_1", "tag_2"] }
```

The argument to `add_tactic_doc` is a structure of type `tactic_doc_entry`.
* `name` refers to the display name of the tactic; it is used as the header of the doc entry.
* `cat` refers to the category of doc entry.
  Options: `doc_category.tactic`, `doc_category.cmd`, `doc_category.hole_cmd`, `doc_category.attr`
* `decl_names` is a list of the declarations associated with this doc. For instance,
  the entry for `linarith` would set ``decl_names := [`tactic.interactive.linarith]``.
  Some entries may cover multiple declarations.
  It is only necessary to list the interactive versions of tactics.
* `tags` is an optional list of strings used to categorize entries.
* The doc string is the body of the entry. It can be formatted with markdown.
  What you are reading now is the description of `add_tactic_doc`.

If only one related declaration is listed in `decl_names` and if this
invocation of `add_tactic_doc` does not have a doc string, the doc string of
that declaration will become the body of the tactic doc entry. If there are
multiple declarations, you can select the one to be used by passing a name to
the `inherit_description_from` field.

If you prefer a tactic to have a doc string that is different then the doc entry,
you should write the doc entry as a doc string for the `add_tactic_doc` invocation.

Note that providing a badly formed `tactic_doc_entry` to the command can result in strange error
messages.

-/
@[user_command]
unsafe def add_tactic_doc_command (mi : interactive.decl_meta_info)
    (_ : parse <| tk "add_tactic_doc") : parser Unit := do
  let pe ← parser.pexpr
  let e ← eval_pexpr TacticDocEntry pe
  tactic.add_tactic_doc e mi
#align add_tactic_doc_command add_tactic_doc_command

/-- At various places in mathlib, we leave implementation notes that are referenced from many other
files. To keep track of these notes, we use the command `library_note`. This makes it easy to
retrieve a list of all notes, e.g. for documentation output.

These notes can be referenced in mathlib with the syntax `Note [note id]`.
Often, these references will be made in code comments (`--`) that won't be displayed in docs.
If such a reference is made in a doc string or module doc, it will be linked to the corresponding
note in the doc display.

Syntax:
```
/--
note message
-/
library_note "note id"
```

An example from `meta.expr`:

```
/--
Some declarations work with open expressions, i.e. an expr that has free variables.
Terms will free variables are not well-typed, and one should not use them in tactics like
`infer_type` or `unify`. You can still do syntactic analysis/manipulation on them.
The reason for working with open types is for performance: instantiating variables requires
iterating through the expression. In one performance test `pi_binders` was more than 6x
quicker than `mk_local_pis` (when applied to the type of all imported declarations 100x).
-/
library_note "open expressions"
```

This note can be referenced near a usage of `pi_binders`:

```
-- See Note [open expressions]
/-- behavior of f -/
def f := pi_binders ...
```
-/
add_tactic_doc
  { Name := "library_note"
    category := DocCategory.cmd
    declNames := [`library_note, `tactic.add_library_note]
    tags := ["documentation"]
    inheritDescriptionFrom := `library_note }

add_tactic_doc
  { Name := "add_tactic_doc"
    category := DocCategory.cmd
    declNames := [`add_tactic_doc_command, `tactic.add_tactic_doc]
    tags := ["documentation"]
    inheritDescriptionFrom := `add_tactic_doc_command }

add_tactic_doc
  { Name := "copy_doc_string"
    category := DocCategory.cmd
    declNames := [`copy_doc_string_cmd, `tactic.copy_doc_string]
    tags := ["documentation"]
    inheritDescriptionFrom := `copy_doc_string_cmd }

-- add docs to core tactics
/-- The congruence closure tactic `cc` tries to solve the goal by chaining
equalities from context and applying congruence (i.e. if `a = b`, then `f a = f b`).
It is a finishing tactic, i.e. it is meant to close
the current goal, not to make some inconclusive progress.
A mostly trivial example would be:

```lean
example (a b c : ℕ) (f : ℕ → ℕ) (h: a = b) (h' : b = c) : f a = f c := by cc
```

As an example requiring some thinking to do by hand, consider:

```lean
example (f : ℕ → ℕ) (x : ℕ)
  (H1 : f (f (f x)) = x) (H2 : f (f (f (f (f x)))) = x) :
  f x = x :=
by cc
```

The tactic works by building an equality matching graph. It's a graph where
the vertices are terms and they are linked by edges if they are known to
be equal. Once you've added all the equalities in your context, you take
the transitive closure of the graph and, for each connected component
(i.e. equivalence class) you can elect a term that will represent the
whole class and store proofs that the other elements are equal to it.
You then take the transitive closure of these equalities under the
congruence lemmas.

The `cc` implementation in Lean does a few more tricks: for example it
derives `a=b` from `nat.succ a = nat.succ b`, and `nat.succ a !=
nat.zero` for any `a`.

* The starting reference point is Nelson, Oppen, [Fast decision procedures based on congruence
closure](http://www.cs.colorado.edu/~bec/courses/csci5535-s09/reading/nelson-oppen-congruence.pdf),
Journal of the ACM (1980)

* The congruence lemmas for dependent type theory as used in Lean are described in
[Congruence closure in intensional type theory](https://leanprover.github.io/papers/congr.pdf)
(de Moura, Selsam IJCAR 2016).
-/
add_tactic_doc
  { Name := "cc (congruence closure)"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.cc]
    tags := ["core", "finishing"] }

/-- `conv {...}` allows the user to perform targeted rewriting on a goal or hypothesis,
by focusing on particular subexpressions.

See <https://leanprover-community.github.io/extras/conv.html> for more details.

Inside `conv` blocks, mathlib currently additionally provides
* `erw`,
* `ring`, `ring2` and `ring_exp`,
* `norm_num`,
* `norm_cast`,
* `apply_congr`, and
* `conv` (within another `conv`).

`apply_congr` applies congruence lemmas to step further inside expressions,
and sometimes gives better results than the automatically generated
congruence lemmas used by `congr`.

Using `conv` inside a `conv` block allows the user to return to the previous
state of the outer `conv` block after it is finished. Thus you can continue
editing an expression without having to start a new `conv` block and re-scoping
everything. For example:
```lean
example (a b c d : ℕ) (h₁ : b = c) (h₂ : a + c = a + d) : a + b = a + d :=
by conv
{ to_lhs,
  conv
  { congr, skip,
    rw h₁ },
  rw h₂, }
```
Without `conv`, the above example would need to be proved using two successive
`conv` blocks, each beginning with `to_lhs`.

Also, as a shorthand, `conv_lhs` and `conv_rhs` are provided, so that
```lean
example : 0 + 0 = 0 :=
begin
  conv_lhs { simp }
end
```
just means
```lean
example : 0 + 0 = 0 :=
begin
  conv { to_lhs, simp }
end
```
and likewise for `to_rhs`.
-/
add_tactic_doc
  { Name := "conv"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.conv]
    tags := ["core"] }

add_tactic_doc
  { Name := "simp"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.simp]
    tags := ["core", "simplification"] }

/-- Accepts terms with the type `component tactic_state string` or `html empty` and
renders them interactively.
Requires a compatible version of the vscode extension to view the resulting widget.

### Example:

```lean
/-- A simple counter that can be incremented or decremented with some buttons. -/
meta def counter_widget {π α : Type} : component π α :=
component.ignore_props $ component.mk_simple int int 0 (λ _ x y, (x + y, none)) (λ _ s,
  h "div" [] [
    button "+" (1 : int),
    html.of_string $ to_string $ s,
    button "-" (-1)
  ]
)

#html counter_widget
```
-/
add_tactic_doc
  { Name := "#html"
    category := DocCategory.cmd
    declNames := [`show_widget_cmd]
    tags := ["core", "widgets"] }

/-- The `add_decl_doc` command is used to add a doc string to an existing declaration.

```lean
def foo := 5

/--
Doc string for foo.
-/
add_decl_doc foo
```
-/
@[user_command]
unsafe def add_decl_doc_command (mi : interactive.decl_meta_info) (_ : parse <| tk "add_decl_doc") :
    parser Unit := do
  let n ← parser.ident
  let n ← resolve_constant n
  let some doc ← pure mi.doc_string |
    fail "add_decl_doc requires a doc string"
  add_doc_string n doc
#align add_decl_doc_command add_decl_doc_command

add_tactic_doc
  { Name := "add_decl_doc"
    category := DocCategory.cmd
    declNames := [`` add_decl_doc_command]
    tags := ["documentation"] }


import system.io
import tactic.where
import tactic.tcache

open tactic

theorem lol : 1 + 1 = 2 := begin
  simp
end

theorem lol' (x : ℕ) : 1 = 1 := rfl

run_cmd (do
  let n := `lol',
  e ← get_env,
  d ← e.get n,
  let s := expr.deserialise d.type.serialise,
  let t := expr.deserialise d.value.serialise,
  -- tactic.trace d.value.serialise,
  -- tactic.trace $ d.type.to_raw_fmt ++ "\n",
  -- tactic.trace $ s.to_raw_fmt ++ "\n",
  -- tactic.trace $ d.value.to_raw_fmt ++ "\n",
  -- tactic.trace t.to_raw_fmt,
  e ← e.add $ declaration.thm (n ++ "v2") [] s (task.pure t),
  set_env e
)

run_cmd (do
  e ← get_env,
  d ← e.get `lol,
  match d with
  | declaration.thm n l t v := tactic.trace v.get.to_raw_fmt
  | _ := skip
  end
)


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

Converter monad for building simplifiers.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.meta.tactic
import Mathlib.Lean3Lib.init.meta.simp_tactic
import Mathlib.Lean3Lib.init.meta.interactive
import Mathlib.Lean3Lib.init.meta.congr_lemma
import Mathlib.Lean3Lib.init.meta.match_tactic

namespace Mathlib

/-- `conv α` is a tactic for discharging goals of the form `lhs ~ rhs` for some relation `~` (usually equality) and fixed lhs, rhs.
Known in the literature as a __conversion__ tactic.
So for example, if one had the lemma `p : x = y`, then the conversion for `p` would be one that solves `p`.
-/


/-
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

namespace Mathlib.Prelude.Rename

open Lean
open System (FilePath)
open Lean (HashMap)

/-- This structure keeps track of alignments from lean 3 names to lean 4 names and vice versa. -/
structure RenameMap where
  /-- This maps `n3 ↦ (dubious, n4)` where `n3` is the lean 3 name and `n4` is the corresponding
  lean 4 name. `dubious` is either empty, or a warning message to be displayed when `n3` is
  translated, which indicates that the translation from `n3` to `n4` is approximate and may cause
  downstream errors. -/
  toLean4 : NameMap (String × Name) := {}
  /-- This maps `n4 ↦ (n3, clashes)` where `n4` is the lean 4 name and `n3::clashes` is the list of
  all (non-`synthetic`) declarations that map to `n4`. (That is, we do not assume the mapping
  from lean 3 to lean 4 name is injective.) -/
  toLean3 : NameMap (Name × List Name) := {}
  deriving Inhabited

/-- An `olean` entry for the rename extension. -/
structure NameEntry where
  /-- The lean 3 name. -/
  n3 : Name
  /-- The lean 4 name, or `.anonymous` for a `#noalign`. -/
  n4 : Name
  /-- If true, this lean 3 -> lean 4 mapping will not be entered into the converse map.
  This is used for "internal" definitions that should never be referred to in the source syntax. -/
  synthetic := false
  /-- A dubious translation is one where there is a type mismatch
  from the translated lean 3 definition to a pre-existing lean 4 definition.
  Type errors are likely in downstream theorems.
  The string stored here is printed in the event that `n3` is encountered by synport. -/
  dubious := ""

/-- Insert a name entry into the `RenameMap`. -/
def RenameMap.insert (m : RenameMap) (e : NameEntry) : RenameMap :=
  let ⟨to4, to3⟩ := m
  let to4 := to4.insert e.n3 (e.dubious, e.n4)
  let to3 := if e.synthetic || e.n4.isAnonymous then to3 else
    match to3.find? e.n4 with
    | none => to3.insert e.n4 (e.n3, [])
    | some (a, l) => if (a::l).contains e.n3 then to3 else to3.insert e.n4 (a, e.n3 :: l)
  ⟨to4, to3⟩

/-- Look up a lean 4 name from the lean 3 name. Also return the `dubious` error message. -/
def RenameMap.find? (m : RenameMap) : Name → Option (String × Name) := m.toLean4.find?

initialize renameExtension : SimplePersistentEnvExtension NameEntry RenameMap ←
  registerSimplePersistentEnvExtension {
    addEntryFn := (·.insert)
    addImportedFn := mkStateFromImportedEntries (·.insert) {}
  }

def getRenameMap (env : Environment) : RenameMap :=
  renameExtension.getState env

def addNameAlignment (n3 : Name) (n4 : Name) (synthetic := false) (dubious := "") : CoreM Unit := do
  modifyEnv fun env ↦ renameExtension.addEntry env { n3, n4, synthetic, dubious }

/-- The `@[binport]` attribute should not be added manually, it is added automatically by mathport
to definitions that it created based on a lean 3 definition (as opposed to pre-existing
definitions). -/
initialize binportTag : TagAttribute ←
  registerTagAttribute `binport "this definition was autogenerated by mathport"

/--
Removes all occurrences of `ₓ` from the name.
This is the same processing used by mathport to generate name references,
and declarations with `ₓ` are used to align declarations that do not defeq match the originals.
-/
def removeX : Name → Name
  | .anonymous => .anonymous
  | .str p s =>
    let s := if s.contains 'ₓ' then
      s.foldl (fun acc c => if c = 'ₓ' then acc else acc.push c) ""
    else s
    .str (removeX p) s
  | .num p n => .num (removeX p) n

open Lean.Elab Lean.Elab.Command

/-- Because lean 3 uses a lowercase snake case convention, it is expected that all lean 3
declaration names should use lowercase, with a few rare exceptions for categories and the set union
operator. This linter warns if you use uppercase in the lean 3 part of an `#align` statement,
because this is most likely a typo. But if the declaration actually uses capitals it is not unusual
to disable this lint locally or at file scope. -/
register_option linter.uppercaseLean3 : Bool := {
  defValue := true
  descr := "enable the lean 3 casing lint"
}

/-- Check that the referenced lean 4 definition exists in an `#align` directive. -/
register_option align.precheck : Bool := {
  defValue := true
  descr := "Check that the referenced lean 4 definition exists in an `#align` directive."
}

/--
`#align lean_3.def_name Lean4.defName` will record an "alignment" from the lean 3 name
to the corresponding lean 4 name. This information is used by the
[mathport](https://github.com/leanprover-community/mathport) utility to translate later uses of
the definition.

If there is no alignment for a given definition, mathport will attempt to convert
from the lean 3 `snake_case` style to `UpperCamelCase` for namespaces and types and
`lowerCamelCase` for definitions, and `snake_case` for theorems. But for various reasons,
it may fail either to determine whether it is a type, definition, or theorem, or to determine
that a specific definition is in fact being called. Or a specific definition may need a different
name altogether because the existing name is already taken in lean 4 for something else. For
these reasons, you should use `#align` on any theorem that needs to be renamed from the default.
-/
syntax (name := align) "#align " ident ident : command

/-- Checks that `id` has not already been `#align`ed or `#noalign`ed. -/
def ensureUnused [Monad m] [MonadEnv m] [MonadError m] (id : Name) : m Unit := do
  if let some (_, n) := (getRenameMap (← getEnv)).toLean4.find? id then
    if n.isAnonymous then
      throwError "{id} has already been no-aligned"
    else
      throwError "{id} has already been aligned (to {n})"

/--
Purported Lean 3 names containing capital letters are suspicious.
However, we disregard capital letters occurring in a few common names.
-/
def suspiciousLean3Name (s : String) : Bool := Id.run do
  let allowed : List String :=
    ["Prop", "Type", "Pi", "Exists", "End",
     "Inf", "Sup", "Union", "Inter",
     "Ioo", "Ico", "Iio", "Icc", "Iic", "Ioc", "Ici", "Ioi", "Ixx"]
  let mut s := s
  for a in allowed do
    s := s.replace a ""
  return s.any (·.isUpper)

/-- Elaborate an `#align` command. -/
@[command_elab align] def elabAlign : CommandElab
  | `(#align $id3:ident $id4:ident) => do
    if (← getInfoState).enabled then
      addCompletionInfo <| CompletionInfo.id id4 id4.getId (danglingDot := false) {} none
      let c := removeX id4.getId
      if (← getEnv).contains c then
        addConstInfo id4 c none
      else if align.precheck.get (← getOptions) then
        let note := "(add `set_option align.precheck false` to suppress this message)"
        let inner := match ← try some <$> resolveGlobalConstWithInfos id4 catch _ => pure none with
        | none => m!""
        | some cs => m!" Did you mean:\n\n{
            ("\n":MessageData).joinSep (cs.map fun c' => m!"  #align {id3} {c'}")
          }\n\n#align inputs have to be fully qualified.{""
          } (Double check the lean 3 name too, we can't check that!)"
        throwErrorAt id4 "Declaration {c} not found.{inner}\n{note}"
      if Linter.getLinterValue linter.uppercaseLean3 (← getOptions) then
        if id3.getId.anyS suspiciousLean3Name then
          Linter.logLint linter.uppercaseLean3 id3 $
            "Lean 3 names are usually lowercase. This might be a typo.\n" ++
            "If the Lean 3 name is correct, then above this line, add:\n" ++
            "set_option linter.uppercaseLean3 false in\n"
    withRef id3 <| ensureUnused id3.getId
    liftCoreM <| addNameAlignment id3.getId id4.getId
  | _ => throwUnsupportedSyntax

/--
`#noalign lean_3.def_name` will record that `lean_3.def_name` has been marked for non-porting.
This information is used by the [mathport](https://github.com/leanprover-community/mathport)
utility, which will remove the declaration from the corresponding mathport file, and later
uses of the definition will be replaced by `sorry`.
-/
syntax (name := noalign) "#noalign " ident : command

/-- Elaborate a `#noalign` command. -/
@[command_elab noalign] def elabNoAlign : CommandElab
  | `(#noalign $id3:ident) => do
    withRef id3 <| ensureUnused id3.getId
    liftCoreM $ addNameAlignment id3.getId .anonymous
  | _ => throwUnsupportedSyntax

/-- Show information about the alignment status of a lean 3 definition. -/
syntax (name := lookup3) "#lookup3 " ident : command

/-- Elaborate a `#lookup3` command. -/
@[command_elab lookup3] def elabLookup3 : CommandElab
  | `(#lookup3%$tk $id3:ident) => do
    let n3 := id3.getId
    let m := getRenameMap (← getEnv)
    match m.find? n3 with
    | none    => logInfoAt tk s!"name `{n3} not found"
    | some (dubious, n4) => do
      if n4.isAnonymous then
        logInfoAt tk m!"{n3} has been no-aligned"
      else
        let mut msg := m!"{n4}"
        if !dubious.isEmpty then
          msg := msg ++ s!" (dubious: {dubious})"
        logInfoAt tk <|
          match m.toLean3.find? n4 with
          | none | some (_, []) => msg
          | some (n, l) => m!"{msg} (aliases {n :: l})"
  | _ => throwUnsupportedSyntax


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

Instances of `traversable` for types from the core library
-/

import category.traversable.basic category.basic category.functor category.applicative
import data.list.basic data.set.lattice

universes u v

open function

instance : traversable id := ⟨λ _ _ _ _, id⟩
instance : is_lawful_traversable id := by refine {..}; intros; refl

section option

open function functor

section inst

variables {F : Type u → Type v} [applicative F]

instance : traversable option := ⟨@option.traverse⟩

end inst

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]

lemma option.id_traverse {α} (x : option α) : option.traverse id.mk x = x :=
by cases x; refl

lemma option.comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : option α) :
  option.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (option.traverse f <$> option.traverse g x) :=
by cases x; simp! with functor_norm; refl

lemma option.traverse_eq_map_id {α β} (f : α → β) (x : option α) :
  traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by cases x; refl

variable (η : applicative_transformation F G)

lemma option.naturality {α β} (f : α → F β) (x : option α) :
  η (option.traverse f x) = option.traverse (@η _ ∘ f) x :=
by cases x with x; simp! [*] with functor_norm

end option

instance : is_lawful_traversable option :=
{ id_traverse := @option.id_traverse,
  comp_traverse := @option.comp_traverse,
  traverse_eq_map_id := @option.traverse_eq_map_id,
  naturality := @option.naturality }

namespace list

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]

open applicative functor
open list (cons)

protected lemma id_traverse {α} (xs : list α) :
  list.traverse id.mk xs = xs :=
by induction xs; simp! * with functor_norm; refl

protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : list α) :
  list.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (list.traverse f <$> list.traverse g x) :=
by induction x; simp! * with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : list α) :
  list.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : list α) :
  η (list.traverse f x) = list.traverse (@η _ ∘ f) x :=
by induction x; simp! * with functor_norm
open nat

instance : traversable list := ⟨@list.traverse⟩

instance : is_lawful_traversable list :=
{ id_traverse := @list.id_traverse,
  comp_traverse := @list.comp_traverse,
  traverse_eq_map_id := @list.traverse_eq_map_id,
  naturality := @list.naturality }

section traverse
variables {α' β' : Type u} (f : α' → F β')

@[simp] lemma traverse_nil : traverse f ([] : list α') = (pure [] : F (list β')) := rfl

@[simp] lemma traverse_cons (a : α') (l : list α') :
  traverse f (a :: l) = (::) <$> f a <*> traverse f l := rfl

variables [is_lawful_applicative F]

@[simp] lemma traverse_append :
  ∀ (as bs : list α'), traverse f (as ++ bs) = (++) <$> traverse f as <*> traverse f bs
| [] bs :=
  have has_append.append ([] : list β') = id, by funext; refl,
  by simp [this] with functor_norm
| (a :: as) bs := by simp [traverse_append as bs] with functor_norm; congr

lemma mem_traverse {f : α' → set β'} :
  ∀(l : list α') (n : list β'), n ∈ traverse f l ↔ forall₂ (λb a, b ∈ f a) n l
| []      []      := by simp
| (a::as) []      := by simp; exact assume h, match h with end
| []      (b::bs) := by simp
| (a::as) (b::bs) :=
  suffices (b :: bs : list β') ∈ traverse f (a :: as) ↔ b ∈ f a ∧ bs ∈ traverse f as,
    by simpa [mem_traverse as bs],
  iff.intro
    (assume ⟨_, ⟨b, hb, rfl⟩, _, hl, rfl⟩, ⟨hb, hl⟩)
    (assume ⟨hb, hl⟩, ⟨_, ⟨b, hb, rfl⟩, _, hl, rfl⟩)

end traverse

end list

namespace sum

section traverse
variables {σ : Type u}
variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

open applicative functor
open list (cons)

protected def traverse {α β} (f : α → F β) : σ ⊕ α → F (σ ⊕ β)
| (sum.inl x) := pure (sum.inl x)
| (sum.inr x) := sum.inr <$> f x

variables [is_lawful_applicative F] [is_lawful_applicative G]

protected lemma id_traverse {σ α} (x : σ ⊕ α) : sum.traverse id.mk x = x :=
by cases x; refl

protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) :
  sum.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (sum.traverse f <$> sum.traverse g x) :=
by cases x; simp! [sum.traverse,map_id] with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : σ ⊕ α) :
  sum.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

protected lemma map_traverse {α β γ} (g : α → G β) (f : β → γ) (x : σ ⊕ α) :
  (<$>) f <$> sum.traverse g x = sum.traverse ((<$>) f ∘ g) x :=
by cases x; simp [(<$>), sum.mapr, sum.traverse, id_map] with functor_norm; congr

protected lemma traverse_map {α β γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) :
  sum.traverse f (g <$> x) = sum.traverse (f ∘ g) x :=
by cases x; simp [(<$>), sum.mapr, sum.traverse, id_map] with functor_norm

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : σ ⊕ α) :
  η (sum.traverse f x) = sum.traverse (@η _ ∘ f) x :=
by cases x; simp! [sum.traverse] with functor_norm

end traverse

instance {σ : Type u} : traversable.{u} (sum σ) := ⟨@sum.traverse _⟩

instance {σ : Type u} : is_lawful_traversable.{u} (sum σ) :=
{ id_traverse := @sum.id_traverse σ,
  comp_traverse := @sum.comp_traverse σ,
  traverse_eq_map_id := @sum.traverse_eq_map_id σ,
  naturality := @sum.naturality σ }

end sum


import Mathlib.Tactic.Trace

example : True := by
  trace 2 + 2 + 3
  trivial

example : True := by
  trace "hello" ++ " world"
  trivial


/-
Here is an example where temporary metavariables from typeclass resolution
could spill into nested typeclass resolution, for which the outer TC succeeds
iff:

1. the inner TC is still called, even with the leaked tmp mvars
2. the inner TC is allowed to assign the leaked tmp mvars

This example will *NOT* work in Lean4.

Although it would be easy to allow inner TC to set the outer TC tmp mvars,
the issue is that the solution to the inner TC problem may not be unique,
and it would be extremely difficult to allow backtracking from the outer TC
through to the inner TC.

In Lean4, inner TC can be called with leaked temporary mvars from the outer TC,
but they are treated as opaque, just as regular mvars are treated in the outer TC.
So, this example will fail.
-/

class Foo  (α : Type) : Type := (x : Unit)
class Zoo  (α : Type) : Type := (x : Unit)
class Bar  (α : Type) : Type := (x : Unit)
class HasParam (α : Type) [Bar α] : Type := (x : Unit)

instance FooToBar (α : Type) [f : Foo α] : Bar α :=
match f.x with
| () => {x:=()}

instance ZooToBar (α : Type) [z : Zoo α] : Bar α :=
match z.x with
| () => {x:=()}

instance HasParamInst (α : Type) [h : Foo α] : HasParam α := {x:=()}

class Top : Type := (x : Unit)

instance FooInt : Foo Int := {x:=()}
instance AllZoo (α : Type) : Zoo α := {x:=()}

instance Bad (α : Type) [HasParam α] : Top := Top.mk ()

set_option pp.all true
set_option trace.class_instances true
set_option trace.type_context.complete_instance true

def foo [Top] : Unit := ()
#check @foo _

/-
[class_instances]  class-instance resolution trace
[class_instances] (0) ?x_0 : Top := @Bad ?x_1 ?x_2
[class_instances] (1) ?x_2 : @HasParam ?x_1 (@ZooToBar ?x_1 (AllZoo ?x_1)) := @HasParamInst ?x_3 ?x_4
[type_context.complete_instance] would have synthed: Foo ?x_3
[type_context.complete_instance] would have synthed: Foo ?x_3
failed is_def_eq
-/

def couldWork : Top :=
@Bad Int (@HasParamInst Int FooInt)

#print couldWork
/-
def couldWork : Top :=
@Bad Int (@HasParamInst Int FooInt)
-/


example (foo bar : Option Nat) : False := by
  have : do { let x ← bar; foo } = bar >>= fun x => foo := rfl
  admit
  done