module Data.TreeRep where

open import Prelude hiding (_>>=_) renaming (_>>=′_ to _>>=_)
open import Container.Traversable
open import Builtin.Reflection
open import Builtin.Float

data Leaf : Set where
  char   : Char → Leaf
  string : String → Leaf
  float  : Float → Leaf
  name   : Name → Leaf

data TreeRep : Set where
  leaf : Leaf → TreeRep
  node : Nat → List TreeRep → TreeRep

--- Eq instance ---

private
  leaf-char-inj : ∀ {x y} → Leaf.char x ≡ char y → x ≡ y
  leaf-char-inj refl = refl

  leaf-string-inj : ∀ {x y} → Leaf.string x ≡ string y → x ≡ y
  leaf-string-inj refl = refl

  leaf-float-inj : ∀ {x y} → Leaf.float x ≡ float y → x ≡ y
  leaf-float-inj refl = refl

  leaf-name-inj : ∀ {x y} → Leaf.name x ≡ name y → x ≡ y
  leaf-name-inj refl = refl

  leaf-inj : ∀ {x y} → leaf x ≡ leaf y → x ≡ y
  leaf-inj refl = refl

  node-inj₁ : ∀ {x y z w} → node x z ≡ node y w → x ≡ y
  node-inj₁ refl = refl

  node-inj₂ : ∀ {x y z w} → node x z ≡ node y w → z ≡ w
  node-inj₂ refl = refl

  eq-leaf : (x y : Leaf) → Dec (x ≡ y)
  eq-leaf (char x) (char x₁) = decEq₁ leaf-char-inj (x == x₁)
  eq-leaf (string x) (string x₁) = decEq₁ leaf-string-inj (x == x₁)
  eq-leaf (float x) (float x₁) = decEq₁ leaf-float-inj (x == x₁)
  eq-leaf (name x) (name x₁) = decEq₁ leaf-name-inj (x == x₁)
  eq-leaf (char x) (string x₁) = no λ()
  eq-leaf (char x) (float x₁) = no λ()
  eq-leaf (char x) (name x₁) = no λ()
  eq-leaf (string x) (char x₁) = no λ()
  eq-leaf (string x) (float x₁) = no λ()
  eq-leaf (string x) (name x₁) = no λ()
  eq-leaf (float x) (char x₁) = no λ()
  eq-leaf (float x) (string x₁) = no λ()
  eq-leaf (float x) (name x₁) = no λ()
  eq-leaf (name x) (char x₁) = no λ()
  eq-leaf (name x) (string x₁) = no λ()
  eq-leaf (name x) (float x₁) = no λ()

instance
  EqLeaf : Eq Leaf
  _==_ {{EqLeaf}} = eq-leaf

private
  eq-tree  : (x y : TreeRep) → Dec (x ≡ y)
  eq-trees : (xs ys : List TreeRep) → Dec (xs ≡ ys)

  eq-tree (leaf x) (leaf x₁) = decEq₁ leaf-inj (x == x₁)
  eq-tree (leaf x) (node x₁ x₂) = no λ()
  eq-tree (node x x₁) (leaf x₂) = no λ()
  eq-tree (node x xs) (node y ys) = decEq₂ node-inj₁ node-inj₂ (x == y) (eq-trees xs ys)

  eq-trees [] [] = yes refl
  eq-trees [] (x ∷ ys) = no λ()
  eq-trees (x ∷ xs) [] = no λ()
  eq-trees (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj-head cons-inj-tail (eq-tree x y) (eq-trees xs ys)

instance
  EqTree : Eq TreeRep
  _==_ {{EqTree}} = eq-tree

--- Ord instance ---

data LessLeaf : Leaf → Leaf → Set where
  char         : ∀ {x y} → x < y → LessLeaf (char x) (char y)
  string       : ∀ {x y} → x < y → LessLeaf (string x) (string y)
  float        : ∀ {x y} → x < y → LessLeaf (float x) (float y)
  name         : ∀ {x y} → x < y → LessLeaf (name x) (name y)
  char<string  : ∀ {x y} → LessLeaf (char x) (string y)
  char<float   : ∀ {x y} → LessLeaf (char x) (float y)
  char<name    : ∀ {x y} → LessLeaf (char x) (name y)
  string<float : ∀ {x y} → LessLeaf (string x) (float y)
  string<name  : ∀ {x y} → LessLeaf (string x) (name y)
  float<name   : ∀ {x y} → LessLeaf (float x) (name y)

private
  cmp-leaf : (a b : Leaf) → Comparison LessLeaf a b
  cmp-leaf (char x) (char x₁) = mapComparison char (compare x x₁)
  cmp-leaf (string x) (string x₁) = mapComparison string (compare x x₁)
  cmp-leaf (float x) (float x₁) = mapComparison float (compare x x₁)
  cmp-leaf (name x) (name x₁) = mapComparison name (compare x x₁)
  cmp-leaf (char x) (string x₁) = less char<string
  cmp-leaf (char x) (float x₁) = less char<float
  cmp-leaf (char x) (name x₁) = less char<name
  cmp-leaf (string x) (char x₁) = greater char<string
  cmp-leaf (string x) (float x₁) = less string<float
  cmp-leaf (string x) (name x₁) = less string<name
  cmp-leaf (float x) (char x₁) = greater char<float
  cmp-leaf (float x) (string x₁) = greater string<float
  cmp-leaf (float x) (name x₁) = less float<name
  cmp-leaf (name x) (char x₁) = greater char<name
  cmp-leaf (name x) (string x₁) = greater string<name
  cmp-leaf (name x) (float x₁) = greater float<name

instance
  OrdLeaf : Ord Leaf
  OrdLeaf = defaultOrd cmp-leaf

  OrdLawsLeaf : Ord/Laws Leaf
  Ord/Laws.super OrdLawsLeaf = it
  less-antirefl {{OrdLawsLeaf}} (char   lt) = less-antirefl {A = Nat      } lt
  less-antirefl {{OrdLawsLeaf}} (string lt) = less-antirefl {A = List Char} lt
  less-antirefl {{OrdLawsLeaf}} (float  lt) = less-antirefl {A = Float    } lt
  less-antirefl {{OrdLawsLeaf}} (name   lt) = less-antirefl {A = Name     } lt
  less-trans {{OrdLawsLeaf}} (char   lt) (char   lt₁) = char   (less-trans {A = Nat      } lt lt₁)
  less-trans {{OrdLawsLeaf}} (string lt) (string lt₁) = string (less-trans {A = List Char} lt lt₁)
  less-trans {{OrdLawsLeaf}} (float  lt) (float  lt₁) = float  (less-trans {A = Float    } lt lt₁)
  less-trans {{OrdLawsLeaf}} (name   lt) (name   lt₁) = name   (less-trans {A = Name     } lt lt₁)
  less-trans {{OrdLawsLeaf}} (char   lt) char<string  = char<string
  less-trans {{OrdLawsLeaf}} (char   lt) char<float   = char<float
  less-trans {{OrdLawsLeaf}} (char   lt) char<name    = char<name
  less-trans {{OrdLawsLeaf}} (string lt) string<float = string<float
  less-trans {{OrdLawsLeaf}} (string lt) string<name  = string<name
  less-trans {{OrdLawsLeaf}} (float  lt) float<name   = float<name
  less-trans {{OrdLawsLeaf}} char<string  (string lt) = char<string
  less-trans {{OrdLawsLeaf}} char<string string<float = char<float
  less-trans {{OrdLawsLeaf}} char<string  string<name = char<name
  less-trans {{OrdLawsLeaf}} char<float   (float lt)  = char<float
  less-trans {{OrdLawsLeaf}} char<float   float<name  = char<name
  less-trans {{OrdLawsLeaf}} char<name    (name lt)   = char<name
  less-trans {{OrdLawsLeaf}} string<float (float lt)  = string<float
  less-trans {{OrdLawsLeaf}} string<float float<name  = string<name
  less-trans {{OrdLawsLeaf}} string<name  (name lt)   = string<name
  less-trans {{OrdLawsLeaf}} float<name   (name lt)   = float<name

data LessTree : TreeRep → TreeRep → Set where
  leaf      : ∀ {x y} → x < y → LessTree (leaf x) (leaf y)
  leaf<node : ∀ {x y ys} → LessTree (leaf x) (node y ys)
  tag<      : ∀ {x y xs ys} → x < y → LessTree (node x xs) (node y ys)
  children< : ∀ {x xs ys} → LessList LessTree xs ys → LessTree (node x xs) (node x ys)

private
  cmp-tree  : ∀ x y → Comparison LessTree x y
  cmp-trees : ∀ xs ys → Comparison (LessList LessTree) xs ys

  cmp-tree (leaf x) (leaf y) = mapComparison leaf (compare x y)
  cmp-tree (leaf _) (node _ _) = less leaf<node
  cmp-tree (node _ _) (leaf _) = greater leaf<node
  cmp-tree (node x xs) (node  y ys)  with compare x y
  cmp-tree (node x xs) (node  y ys)  | less    x<y = less (tag< x<y)
  cmp-tree (node x xs) (node  y ys)  | greater x>y = greater (tag< x>y)
  cmp-tree (node x xs) (node .x ys)  | equal refl with cmp-trees xs ys
  cmp-tree (node x xs) (node .x ys)  | equal refl | less    lt = less (children< lt)
  cmp-tree (node x xs) (node .x .xs) | equal refl | equal refl = equal refl
  cmp-tree (node x xs) (node .x ys)  | equal refl | greater gt = greater (children< gt)

  cmp-trees [] [] = equal refl
  cmp-trees []       (x ∷ ys) = less nil<cons
  cmp-trees (x ∷ xs) []       = greater nil<cons
  cmp-trees (x ∷ xs) (y ∷ ys) = compareCons (cmp-tree x y) (cmp-trees xs ys)

instance
  OrdTree : Ord TreeRep
  OrdTree = defaultOrd cmp-tree

private
  antirefl  : {t : TreeRep} → t < t → ⊥
  antirefls : {ts : List TreeRep} → ts < ts → ⊥
  antirefl  (leaf lt)      = less-antirefl {A = Leaf} lt
  antirefl  (tag< lt)      = less-antirefl {A = Nat} lt
  antirefl  (children< lt) = antirefls lt
  antirefls (head< lt)     = antirefl lt
  antirefls (tail< lt)     = antirefls lt

  ltrans  : {s t u : TreeRep} → s < t → t < u → s < u
  ltranss : {ss ts us : List TreeRep} → ss < ts → ts < us → ss < us
  ltrans (leaf lt)      (leaf lt₁)      = leaf (less-trans {A = Leaf} lt lt₁)
  ltrans (leaf lt)      leaf<node       = leaf<node
  ltrans leaf<node      (tag< lt)       = leaf<node
  ltrans leaf<node      (children< lt)  = leaf<node
  ltrans (tag< lt)      (tag< lt₁)      = tag< (less-trans {A = Nat} lt lt₁)
  ltrans (tag< lt)      (children< lt₁) = tag< lt
  ltrans (children< lt) (tag< lt₁)      = tag< lt₁
  ltrans (children< lt) (children< lt₁) = children< (ltranss lt lt₁)
  ltranss nil<cons      (head< lt)      = nil<cons
  ltranss nil<cons      (tail< lt₁)     = nil<cons
  ltranss (head< lt)    (head< lt₁)     = head< (ltrans lt lt₁)
  ltranss (head< lt)    (tail< lt₁)     = head< lt
  ltranss (tail< lt)    (head< lt₁)     = head< lt₁
  ltranss (tail< lt)    (tail< lt₁)     = tail< (ltranss lt lt₁)

instance
  OrdLawsTree : Ord/Laws TreeRep
  Ord/Laws.super OrdLawsTree = it
  less-antirefl {{OrdLawsTree}} = antirefl
  less-trans    {{OrdLawsTree}} = ltrans

--- Encoding types as trees ---

record TreeEncoding {a} (A : Set a) : Set a where
  constructor treeEncoding
  field
    treeEncode : A → TreeRep
    treeDecode : TreeRep → Maybe A
    isTreeEmbedding : ∀ x → treeDecode (treeEncode x) ≡ just x

open TreeEncoding {{...}} public

module _ {a} {A : Set a} {{_ : TreeEncoding A}} where
  private
    encode-injective : (x y : A) → treeEncode x ≡ treeEncode y → x ≡ y
    encode-injective x y eq = eraseEquality $ just-inj $
      isTreeEmbedding x ʳ⟨≡⟩ cong treeDecode eq ⟨≡⟩ isTreeEmbedding y

    decTreeEq : (x y : A) → Dec (x ≡ y)
    decTreeEq x y with treeEncode x == treeEncode y
    decTreeEq x y | yes eq = yes (encode-injective x y eq)
    decTreeEq x y | no !eq = no λ x=y → !eq (cong treeEncode x=y)

  EqByTreeEncoding : Eq A
  _==_ {{EqByTreeEncoding}} = decTreeEq

  data LessEncoding (x y : A) : Set a where
    less-enc : treeEncode x < treeEncode y → LessEncoding x y

  OrdByTreeEncoding : Ord A
  OrdByTreeEncoding = defaultOrd λ x y → injectComparison (encode-injective _ _) less-enc $
                                          (compare on treeEncode) x y

  OrdLawsByTreeEncoding : Ord/Laws A
  Ord/Laws.super OrdLawsByTreeEncoding = OrdByTreeEncoding
  less-antirefl {{OrdLawsByTreeEncoding}} (less-enc lt) = less-antirefl {A = TreeRep} lt
  less-trans    {{OrdLawsByTreeEncoding}} (less-enc lt) (less-enc lt₁) = less-enc (less-trans {A = TreeRep} lt lt₁)

--- Encodings for standard types ---

instance
  EncodeNat : TreeEncoding Nat
  EncodeNat = treeEncoding enc dec (λ _ → refl)
    where
      enc : Nat → TreeRep
      enc n = node n []

      dec : TreeRep → Maybe Nat
      dec (node n _) = just n
      dec (leaf _) = nothing

  EncodeBool : TreeEncoding Bool
  EncodeBool = treeEncoding enc dec emb
    where
      enc : Bool → TreeRep
      enc false = node 0 []
      enc true = node 1 []

      dec : TreeRep → Maybe Bool
      dec (node 0 _) = just false
      dec _          = just true

      emb : ∀ b → dec (enc b) ≡ just b
      emb false = refl
      emb true  = refl

  EncodeMaybe : ∀ {a} {A : Set a} {{_ : TreeEncoding A}} → TreeEncoding (Maybe A)
  EncodeMaybe {A = A} = treeEncoding enc dec emb
    where
      enc : Maybe A → TreeRep
      enc nothing  = node 0 []
      enc (just x) = node 1 [ treeEncode x ]

      dec : TreeRep → Maybe (Maybe A)
      dec (node 0 _)       = just nothing
      dec (node _ (x ∷ _)) = just <$> treeDecode x
      dec _                = nothing

      emb : ∀ x → dec (enc x) ≡ just x
      emb nothing  = refl
      emb (just x) = just =$= isTreeEmbedding x

  EncodeSigma : ∀ {a b} {A : Set a} {B : A → Set b}
                  {{EncA : TreeEncoding A}} {{EncB : ∀ {x} → TreeEncoding (B x)}} →
                  TreeEncoding (Σ A B)
  EncodeSigma {A = A} {B = B} = treeEncoding enc dec emb
    where
      enc : Σ A B → TreeRep
      enc (x , y) = node 0 (treeEncode x ∷ treeEncode y ∷ [])

      dec : TreeRep → Maybe (Σ A B)
      dec (node _ (x ∷ y ∷ _)) = do
        x ← treeDecode x ofType Maybe A
        y ← treeDecode y
        just (x , y)
      dec _ = nothing

      emb : ∀ x → dec (enc x) ≡ just x
      emb (x , y) rewrite isTreeEmbedding x | isTreeEmbedding y = refl

  EncodeList : ∀ {a} {A : Set a} {{_ : TreeEncoding A}} → TreeEncoding (List A)
  treeEncode {{EncodeList}} xs          = node 0 (map treeEncode xs)
  treeDecode {{EncodeList}} (node _ xs) = traverse′ treeDecode xs
  treeDecode {{EncodeList}} _           = nothing
  isTreeEmbedding {{EncodeList}} []       = refl
  isTreeEmbedding {{EncodeList}} (x ∷ xs) = _∷_ =$= isTreeEmbedding x =*= isTreeEmbedding xs

--- Example ---

-- private
--   data TestData : Set where
--     cA : TestData → TestData
--     cB : TestData → TestData → TestData
--     cC : TestData
--     cD : TestData → TestData → TestData

--   private
--     encodeTest : TestData → TreeRep
--     encodeTest (cA x)   = node 0 (encodeTest x ∷ [])
--     encodeTest (cB x y) = node 1 (encodeTest x ∷ encodeTest y ∷ [])
--     encodeTest cC       = node 2 []
--     encodeTest (cD x y) = node 3 (encodeTest x ∷ encodeTest y ∷ [])

--     decodeTest : TreeRep → Maybe TestData
--     decodeTest (leaf _) = nothing
--     decodeTest (node 0 (x ∷ []))     = cA <$> decodeTest x
--     decodeTest (node 1 (x ∷ y ∷ [])) = cB <$> decodeTest x <*> decodeTest y
--     decodeTest (node 2 [])           = just cC
--     decodeTest (node 3 (x ∷ y ∷ [])) = cD <$> decodeTest x <*> decodeTest y
--     decodeTest _ = nothing

--     embeddingTest : ∀ x → decodeTest (encodeTest x) ≡ just x
--     embeddingTest (cA x)   = cA =$= embeddingTest x
--     embeddingTest (cB x y) = cB =$= embeddingTest x =*= embeddingTest y
--     embeddingTest cC       = refl
--     embeddingTest (cD x y) = cD =$= embeddingTest x =*= embeddingTest y

--   instance
--     EncodeTest : TreeEncoding TestData
--     EncodeTest = record { treeEncode      = encodeTest
--                         ; treeDecode      = decodeTest
--                         ; isTreeEmbedding = embeddingTest }

--     EqTest : Eq TestData
--     EqTest = EqByTreeEncoding

--     OrdTest : Ord TestData
--     OrdTest = OrdByTreeEncoding


------------------------------------------------------------------------
-- Laws related to _⊛_ and return
------------------------------------------------------------------------

module TotalParserCombinators.Laws.ApplicativeFunctor where

open import Algebra
open import Category.Monad
open import Codata.Musical.Notation
open import Data.List
import Data.List.Categorical
import Data.List.Relation.Binary.BagAndSetEquality as BSEq
open import Function
open import Level

open RawMonad {f = zero} Data.List.Categorical.monad
  using () renaming (_⊛_ to _⊛′_; _>>=_ to _>>=′_)
private
  module BagMonoid {k} {A : Set} =
    CommutativeMonoid (BSEq.commutativeMonoid k A)

open import TotalParserCombinators.Derivative
open import TotalParserCombinators.Congruence
  hiding (return; fail) renaming (_∣_ to _∣′_)
import TotalParserCombinators.Laws.AdditiveMonoid as AdditiveMonoid
open import TotalParserCombinators.Laws.Derivative as Derivative
import TotalParserCombinators.Laws.Monad as Monad
open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser

------------------------------------------------------------------------
-- _⊛_, return, _∣_ and fail form an applicative functor "with a zero
-- and a plus"

-- Together with the additive monoid laws we get something which
-- resembles an idempotent semiring (if we restrict ourselves to
-- language equivalence).

-- First note that _⊛_ can be defined using _>>=_.

private

  -- A variant of "flip map".

  pam : ∀ {Tok R₁ R₂ xs} →
        Parser Tok R₁ xs → (f : R₁ → R₂) →
        Parser Tok R₂ (xs >>=′ [_] ∘ f)
  pam p f = p >>= (return ∘ f)

  infixl 10 _⊛″_

  -- Note that this definition forces the argument parsers.

  _⊛″_ : ∀ {Tok R₁ R₂ fs xs} →
         ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs)               →
         ∞⟨ fs ⟩Parser Tok  R₁                     (flatten xs) →
                Parser Tok       R₂  (flatten fs ⊛′ flatten xs)
  p₁ ⊛″ p₂ = ♭? p₁ >>= pam (♭? p₂)

⊛-in-terms-of->>= :
  ∀ {Tok R₁ R₂ fs xs}
  (p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs)            )
  (p₂ : ∞⟨ fs ⟩Parser Tok  R₁                   (flatten xs)) →
  p₁ ⊛ p₂ ≅P p₁ ⊛″ p₂
⊛-in-terms-of->>= {R₁ = R₁} {R₂} {fs} {xs} p₁ p₂ =
  BagMonoid.reflexive (Claims.⊛flatten-⊛-flatten (flatten fs) xs) ∷ λ t → ♯ (
    D t (p₁ ⊛ p₂)                                         ≅⟨ D-⊛ p₁ p₂ ⟩

    D t (♭? p₁) ⊛ ♭? p₂ ∣
    return⋆ (flatten fs) ⊛ D t (♭? p₂)                    ≅⟨ ⊛-in-terms-of->>= (D t (♭? p₁)) (♭? p₂) ∣′
                                                             ⊛-in-terms-of->>= (return⋆ (flatten fs)) (D t (♭? p₂)) ⟩
    D t (♭? p₁) ⊛″ ♭? p₂ ∣
    return⋆ (flatten fs) ⊛″ D t (♭? p₂)                   ≅⟨ (D t (♭? p₁) ⊛″ ♭? p₂ ∎) ∣′
                                                             ([ ○ - ○ - ○ - ○ ] return⋆ (flatten fs) ∎ >>= λ f →
                                                                                sym $ lemma t f) ⟩
    D t (♭? p₁) >>= pam (♭? p₂) ∣
    return⋆ (flatten fs) >>= (λ f → D t (pam (♭? p₂) f))  ≅⟨ sym $ D->>= (♭? p₁) (pam (♭? p₂)) ⟩

    D t (♭? p₁ >>= pam (♭? p₂))                           ∎)
  where
  lemma : ∀ t (f : R₁ → R₂) →
          D t (♭? p₂ >>= λ x → return (f x)) ≅P
          D t (♭? p₂) >>= λ x → return (f x)
  lemma t f =
    D t (pam (♭? p₂) f)                    ≅⟨ D->>= (♭? p₂) (return ∘ f) ⟩

    pam (D t (♭? p₂)) f ∣
    (return⋆ (flatten xs) >>= λ _ → fail)  ≅⟨ (pam (D t (♭? p₂)) f ∎) ∣′
                                              Monad.right-zero (return⋆ (flatten xs)) ⟩
    pam (D t (♭? p₂)) f ∣ fail             ≅⟨ AdditiveMonoid.right-identity (pam (D t (♭? p₂)) f) ⟩
    pam (D t (♭? p₂)) f                    ∎

-- We can then reduce all the laws to corresponding laws for _>>=_.

-- The zero laws have already been proved.

open Derivative public
  using () renaming (left-zero-⊛  to left-zero;
                     right-zero-⊛ to right-zero)

-- _⊛_ distributes from the left over _∣_.

left-distributive : ∀ {Tok R₁ R₂ fs xs₁ xs₂}
                    (p₁ : Parser Tok (R₁ → R₂) fs)
                    (p₂ : Parser Tok R₁ xs₁)
                    (p₃ : Parser Tok R₁ xs₂) →
                    p₁ ⊛ (p₂ ∣ p₃) ≅P p₁ ⊛ p₂ ∣ p₁ ⊛ p₃
left-distributive p₁ p₂ p₃ =
  p₁ ⊛  (p₂ ∣ p₃)                     ≅⟨ ⊛-in-terms-of->>= p₁ (p₂ ∣ p₃) ⟩
  p₁ ⊛″ (p₂ ∣ p₃)                     ≅⟨ ([ ○ - ○ - ○ - ○ ] p₁ ∎ >>= λ f →
                                            Monad.right-distributive p₂ p₃ (return ∘ f)) ⟩
  (p₁ >>= λ f → pam p₂ f ∣ pam p₃ f)  ≅⟨ Monad.left-distributive p₁ (pam p₂) (pam p₃) ⟩
  p₁ ⊛″ p₂ ∣ p₁ ⊛″ p₃                 ≅⟨ sym $ ⊛-in-terms-of->>= p₁ p₂ ∣′
                                               ⊛-in-terms-of->>= p₁ p₃ ⟩
  p₁ ⊛  p₂ ∣ p₁ ⊛  p₃                 ∎

-- _⊛_ distributes from the right over _∣_.

right-distributive : ∀ {Tok R₁ R₂ fs₁ fs₂ xs}
                     (p₁ : Parser Tok (R₁ → R₂) fs₁)
                     (p₂ : Parser Tok (R₁ → R₂) fs₂)
                     (p₃ : Parser Tok R₁ xs) →
                     (p₁ ∣ p₂) ⊛ p₃ ≅P p₁ ⊛ p₃ ∣ p₂ ⊛ p₃
right-distributive p₁ p₂ p₃ =
  (p₁ ∣ p₂) ⊛  p₃      ≅⟨ ⊛-in-terms-of->>= (p₁ ∣ p₂) p₃ ⟩
  (p₁ ∣ p₂) ⊛″ p₃      ≅⟨ Monad.right-distributive p₁ p₂ (pam p₃) ⟩
  p₁ ⊛″ p₃ ∣ p₂ ⊛″ p₃  ≅⟨ sym $ ⊛-in-terms-of->>= p₁ p₃ ∣′
                                ⊛-in-terms-of->>= p₂ p₃ ⟩
  p₁ ⊛  p₃ ∣ p₂ ⊛  p₃  ∎

-- Applicative functor laws.

identity : ∀ {Tok R xs} (p : Parser Tok R xs) → return id ⊛ p ≅P p
identity p =
  return id ⊛  p  ≅⟨ ⊛-in-terms-of->>= (return id) p ⟩
  return id ⊛″ p  ≅⟨ Monad.left-identity id (pam p) ⟩
  p >>= return    ≅⟨ Monad.right-identity p ⟩
  p               ∎

homomorphism : ∀ {Tok R₁ R₂} (f : R₁ → R₂) (x : R₁) →
               return f ⊛ return x ≅P return {Tok = Tok} (f x)
homomorphism f x =
  return f ⊛  return x  ≅⟨ ⊛-in-terms-of->>= (return f) (return x) ⟩
  return f ⊛″ return x  ≅⟨ Monad.left-identity f (pam (return x)) ⟩
  pam (return x) f      ≅⟨ Monad.left-identity x (return ∘ f) ⟩
  return (f x)          ∎

private

  infixl 10 _⊛-cong_

  _⊛-cong_ :
    ∀ {k Tok R₁ R₂ xs₁ xs₂ fs₁ fs₂}
      {p₁ : Parser Tok (R₁ → R₂) fs₁} {p₂ : Parser Tok R₁ xs₁}
      {p₃ : Parser Tok (R₁ → R₂) fs₂} {p₄ : Parser Tok R₁ xs₂} →
    p₁ ∼[ k ]P p₃ → p₂ ∼[ k ]P p₄ → p₁ ⊛″ p₂ ∼[ k ]P p₃ ⊛″ p₄
  _⊛-cong_ {p₁ = p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄ =
    p₁ ⊛″ p₂  ≅⟨ sym $ ⊛-in-terms-of->>= p₁ p₂ ⟩
    p₁ ⊛  p₂  ∼⟨ [ ○ - ○ - ○ - ○ ] p₁≈p₃ ⊛ p₂≈p₄ ⟩
    p₃ ⊛  p₄  ≅⟨ ⊛-in-terms-of->>= p₃ p₄ ⟩
    p₃ ⊛″ p₄  ∎

  pam-lemma : ∀ {Tok R₁ R₂ R₃ xs} {g : R₂ → List R₃}
              (p₁ : Parser Tok R₁ xs) (f : R₁ → R₂)
              (p₂ : (x : R₂) → Parser Tok R₃ (g x)) →
              pam p₁ f >>= p₂ ≅P p₁ >>= λ x → p₂ (f x)
  pam-lemma p₁ f p₂ =
    pam p₁ f >>= p₂                     ≅⟨ sym $ Monad.associative p₁ (return ∘ f) p₂ ⟩
    (p₁ >>= λ x → return (f x) >>= p₂)  ≅⟨ ([ ○ - ○ - ○ - ○ ] p₁ ∎ >>= λ x →
                                              Monad.left-identity (f x) p₂) ⟩
    (p₁ >>= λ x → p₂ (f x))             ∎

composition :
  ∀ {Tok R₁ R₂ R₃ fs gs xs}
  (p₁ : Parser Tok (R₂ → R₃) fs)
  (p₂ : Parser Tok (R₁ → R₂) gs)
  (p₃ : Parser Tok R₁        xs) →
  return _∘′_ ⊛ p₁ ⊛ p₂ ⊛ p₃ ≅P p₁ ⊛ (p₂ ⊛ p₃)
composition p₁ p₂ p₃ =
  return _∘′_ ⊛  p₁ ⊛  p₂ ⊛  p₃                   ≅⟨ ⊛-in-terms-of->>= (return _∘′_ ⊛ p₁ ⊛ p₂) p₃ ⟩
  return _∘′_ ⊛  p₁ ⊛  p₂ ⊛″ p₃                   ≅⟨ ⊛-in-terms-of->>= (return _∘′_ ⊛ p₁) p₂ ⊛-cong (p₃ ∎) ⟩
  return _∘′_ ⊛  p₁ ⊛″ p₂ ⊛″ p₃                   ≅⟨ ⊛-in-terms-of->>= (return _∘′_) p₁ ⊛-cong (p₂ ∎) ⊛-cong (p₃ ∎) ⟩
  return _∘′_ ⊛″ p₁ ⊛″ p₂ ⊛″ p₃                   ≅⟨ Monad.left-identity _∘′_ (pam p₁) ⊛-cong (p₂ ∎) ⊛-cong (p₃ ∎) ⟩
  pam p₁ _∘′_ ⊛″ p₂ ⊛″ p₃                         ≅⟨ pam-lemma p₁ _∘′_ (pam p₂) ⊛-cong (p₃ ∎) ⟩
  ((p₁ >>= λ f → pam p₂ (_∘′_ f)) ⊛″ p₃)          ≅⟨ sym $ Monad.associative p₁ (λ f → pam p₂ (_∘′_ f)) (pam p₃) ⟩
  (p₁ >>= λ f → pam p₂ (_∘′_ f) >>= pam p₃)       ≅⟨ ([ ○ - ○ - ○ - ○ ] p₁ ∎ >>= λ f →
                                                      pam-lemma p₂ (_∘′_ f) (pam p₃)) ⟩
  (p₁ >>= λ f → p₂ >>= λ g → pam p₃ (f ∘′ g))     ≅⟨ ([ ○ - ○ - ○ - ○ ] p₁ ∎ >>= λ f →
                                                      [ ○ - ○ - ○ - ○ ] p₂ ∎ >>= λ g →
                                                      sym $ pam-lemma p₃ g (return ∘ f)) ⟩
  (p₁ >>= λ f → p₂ >>= λ g → pam (pam p₃ g) f)    ≅⟨ ([ ○ - ○ - ○ - ○ ] p₁ ∎ >>= λ f →
                                                      Monad.associative p₂ (pam p₃) (return ∘ f)) ⟩
  p₁ ⊛″ (p₂ ⊛″ p₃)                                ≅⟨ sym $ (p₁ ∎) ⊛-cong ⊛-in-terms-of->>= p₂ p₃ ⟩
  p₁ ⊛″ (p₂ ⊛  p₃)                                ≅⟨ sym $ ⊛-in-terms-of->>= p₁ (p₂ ⊛ p₃) ⟩
  p₁ ⊛  (p₂ ⊛  p₃)                                ∎

interchange : ∀ {Tok R₁ R₂ fs}
              (p : Parser Tok (R₁ → R₂) fs) (x : R₁) →
              p ⊛ return x ≅P return (λ f → f x) ⊛ p
interchange p x =
  p ⊛  return x               ≅⟨ ⊛-in-terms-of->>= p (return x) ⟩
  p ⊛″ return x               ≅⟨ ([ ○ - ○ - ○ - ○ ] p ∎ >>= λ f →
                                    Monad.left-identity x (return ∘ f)) ⟩
  (p >>= λ f → return (f x))  ≅⟨ pam p (λ f → f x) ∎ ⟩
  pam p (λ f → f x)           ≅⟨ sym $ Monad.left-identity (λ f → f x) (pam p) ⟩
  return (λ f → f x) ⊛″ p     ≅⟨ sym $ ⊛-in-terms-of->>= (return (λ f → f x)) p ⟩
  return (λ f → f x) ⊛  p     ∎


open import Issue2229Base public


open import Data.Product using ( _×_ ; _,_ )
open import Relation.Binary.PropositionalEquality using ( refl )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.ABox using ( ABox ; ⟨ABox⟩ )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; Surjective ; _,_ ; ⌊_⌋ ; ind ; _*_ ; emp )
open import Web.Semantic.DL.ABox.Interp.Morphism using ( _≲_ ; _,_ ; ≲⌊_⌋ ; ≲-resp-ind ; _≋_ ; _**_ )
open import Web.Semantic.DL.ABox.Model using ( _⊨a_ ; ⟨ABox⟩-resp-⊨ ; *-resp-⟨ABox⟩ ; ⊨a-resp-≡ )
open import Web.Semantic.DL.Integrity using ( _⊕_⊨_ ; Initial ; Mediator ; Mediated ; _,_ )
open import Web.Semantic.DL.KB using ( KB ; _,_ )
open import Web.Semantic.DL.KB.Model using ( _⊨_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox.Interp using ( _⊨_≈_ ; ≈-refl )
open import Web.Semantic.DL.TBox.Interp.Morphism using ( morph ; ≲-image )
open import Web.Semantic.Util using ( False ; _∘_ ; _⊕_⊕_ ; bnode ; inode ; enode )

module Web.Semantic.DL.Integrity.Closed {Σ : Signature} {X : Set} where

infix 2 _⊨₀_ sur_⊨₀_
infixr 4 _,_

-- A closed-world variant on integrity constraints.

data Mediated₀ (I J : Interp Σ X) : Set where
  _,_ : (I≲J : I ≲ J) → (∀ (I≲₁J I≲₂J : I ≲ J) → (I≲₁J ≋ I≲₂J)) → Mediated₀ I J

data Initial₀ KB (I : Interp Σ X) : Set₁ where
  _,_ : (I ⊨ KB) → (∀ J → (J ⊨ KB) → Mediated₀ I J) → (I ∈ Initial₀ KB)

data _⊨₀_ (KB₁ KB₂ : KB Σ X) : Set₁ where
  _,_ : ∀ I → ((I ∈ Initial₀ KB₁) × (I ⊨ KB₂)) → (KB₁ ⊨₀ KB₂)

-- Surjective variant

data sur_⊨₀_ (KB₁ KB₂ : KB Σ X) : Set₁ where
  _,_ : ∀ I → ((I ∈ Surjective) × (I ∈ Initial₀ KB₁) × (I ⊨ KB₂)) → (sur KB₁ ⊨₀ KB₂)

-- Closed-world ICs are given by specializing the open-world case
-- to the empty imported interpretion.

exp : KB Σ X → KB Σ (False ⊕ False ⊕ X)
exp (T , A) = (T , ⟨ABox⟩ enode A)

enode⁻¹ : (False ⊕ False ⊕ X) → X
enode⁻¹ (inode ())
enode⁻¹ (bnode ())
enode⁻¹ (enode x) = x

emp-≲ : ∀ (I : Interp Σ False) → (emp ≲ I)
emp-≲ I = (morph (λ ()) (λ {}) (λ ()) (λ {r} → λ {}) , λ ())

⊨₀-impl-⊨ : ∀ KB₁ KB₂ → (KB₁ ⊨₀ KB₂) → (emp ⊕ exp KB₁ ⊨ KB₂)
⊨₀-impl-⊨ (T , A) (U , B) (I , ((I⊨T , I⊨A) , I-med) , I⊨U , I⊨B) =
  (I′ , I′-init , I⊨U , ⊨a-resp-≡ I (ind I) refl B I⊨B) where

  A′ : ABox Σ (False ⊕ False ⊕ X)
  A′ = ⟨ABox⟩ enode A

  I′ : Interp Σ (False ⊕ False ⊕ X)
  I′ = enode⁻¹ * I

  emp≲I′ : emp ≲ inode * I′
  emp≲I′ = emp-≲ (inode * I′)

  I′-med : Mediator emp I′ emp≲I′ (T , A′)
  I′-med J′ emp≲J′ (J′⊨T , J′⊨A′) = lemma (I-med J (J′⊨T , J⊨A)) where

    J : Interp Σ X
    J = enode * J′

    J⊨A : J ⊨a A
    J⊨A = *-resp-⟨ABox⟩ enode J′ A J′⊨A′

    lemma : Mediated₀ I J → Mediated emp I′ J′ emp≲I′ emp≲J′
    lemma ((I≲J , i≲j) , I≲J-uniq) = ((I≲J , i′≲j′) , (λ ()) , I′≲J′-uniq) where

      i′≲j′ : ∀ x → ⌊ J′ ⌋ ⊨ ≲-image I≲J (ind I (enode⁻¹ x)) ≈ ind J′ x
      i′≲j′ (inode ())
      i′≲j′ (bnode ())
      i′≲j′ (enode x) = i≲j x

      I′≲J′-uniq : ∀ (I≲₁J I≲₂J : I′ ≲ J′)_ _ →  I≲₁J ≋ I≲₂J
      I′≲J′-uniq I≲₁J I≲₂J _ _ = I≲J-uniq
        (≲⌊ I≲₁J ⌋ , λ x → ≲-resp-ind I≲₁J (enode x))
        (≲⌊ I≲₂J ⌋ , λ x → ≲-resp-ind I≲₂J (enode x))

  I′⊨A′ : I′ ⊨a A′
  I′⊨A′ = ⟨ABox⟩-resp-⊨ enode (λ x → ≈-refl ⌊ I ⌋) A I⊨A

  I′-init : I′ ∈ Initial emp (T , A′)
  I′-init = ( emp-≲ (inode * I′) , (I⊨T , I′⊨A′) , I′-med )

⊨-impl-⊨₀ : ∀ KB₁ KB₂ → (emp ⊕ exp KB₁ ⊨ KB₂) → (KB₁ ⊨₀ KB₂)
⊨-impl-⊨₀ (T , A) (U , B)
  (I′ , (emp≲I′ , (I′⊨T , I′⊨A) , I′-med) , I′⊨U , I′⊨B) =
    (I , ((I′⊨T , I⊨A) , I-med) , I′⊨U , I′⊨B) where

  I : Interp Σ X
  I = enode * I′

  I⊨A : I ⊨a A
  I⊨A = *-resp-⟨ABox⟩ enode I′ A I′⊨A

  I-med : ∀ J → (J ⊨ T , A) → Mediated₀ I J
  I-med J (J⊨T , J⊨A) = lemma (I′-med J′ emp≲J′ (J⊨T , J′⊨A)) where

    J′ : Interp Σ (False ⊕ False ⊕ X)
    J′ = enode⁻¹ * J

    emp≲J′ : emp ≲ inode * J′
    emp≲J′ = emp-≲ (inode * J′)

    J′⊨A : J′ ⊨a ⟨ABox⟩ enode A
    J′⊨A = ⟨ABox⟩-resp-⊨ enode (λ x → ≈-refl ⌊ J ⌋) A J⊨A

    I≲J-impl-I′≲J′ : (I ≲ J) → (I′ ≲ J′)
    I≲J-impl-I′≲J′ I≲J = (≲⌊ I≲J ⌋ , i≲j) where

      i≲j : ∀ x → ⌊ J ⌋ ⊨ ≲-image ≲⌊ I≲J ⌋ (ind I′ x) ≈ ind J (enode⁻¹ x)
      i≲j (inode ())
      i≲j (bnode ())
      i≲j (enode x) = ≲-resp-ind I≲J x

    lemma : Mediated emp I′ J′ emp≲I′ emp≲J′ → Mediated₀ I J
    lemma (I≲J , _ , I≲J-uniq) =
      ( (≲⌊ I≲J ⌋ , λ x → ≲-resp-ind I≲J (enode x))
      , λ I≲₁J I≲₂J x → I≲J-uniq
          (I≲J-impl-I′≲J′ I≲₁J) (I≲J-impl-I′≲J′ I≲₂J) (λ ()) (λ ()) x)


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Categories.Presheaf.Properties where

open import Cubical.Categories.Category
open import Cubical.Categories.NaturalTransformation
open import Cubical.Categories.Instances.Sets
open import Cubical.Categories.Instances.Functors
open import Cubical.Categories.Functor
open import Cubical.Categories.Presheaf.Base
open import Cubical.Categories.Equivalence
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv using (fiber)
open import Cubical.Data.Sigma

import Cubical.Categories.Morphism as Morphism
import Cubical.Categories.Constructions.Slice as Slice
import Cubical.Categories.Constructions.Elements as Elements
import Cubical.Functions.Fibration as Fibration

private
  variable
    ℓ ℓ' : Level
    e e' : Level

-- (PreShv C) / F ≃ᶜ PreShv (∫ᴾ F)
module _ {ℓS : Level} (C : Precategory ℓ ℓ') (F : Functor (C ^op) (SET ℓS)) where
  open Precategory
  open Functor
  open _≃ᶜ_
  open isEquivalence
  open NatTrans
  open NatIso
  open Slice (PreShv C ℓS) F ⦃ isCatPreShv {C = C} ⦄
  open Elements {C = C}

  open Fibration.ForSets

  -- specific case of fiber under natural transformation
  fibersEqIfRepsEqNatTrans : ∀ {A} (ϕ : A ⇒ F) {c x x'} {px : x ≡ x'} {a' : fiber (ϕ ⟦ c ⟧) x} {b' : fiber (ϕ ⟦ c ⟧) x'}
                  → fst a' ≡ fst b'
                  → PathP (λ i → fiber (ϕ ⟦ c ⟧) (px i)) a' b'
  fibersEqIfRepsEqNatTrans ϕ {c} {x} {x'} {px} {a , fiba} {b , fibb} p
    = fibersEqIfRepsEq {isSetB = snd (F ⟅ c ⟆)} (ϕ ⟦ c ⟧) p

  -- ========================================
  --            K : Slice → PreShv
  -- ========================================

  -- action on (slice) objects
  K-ob : (s : SliceCat .ob) → (PreShv (∫ᴾ F) ℓS .ob)
  -- we take (c , x) to the fiber in A of ϕ over x
  K-ob (sliceob {A} ϕ) .F-ob (c , x)
    = (fiber (ϕ ⟦ c ⟧) x)
    , isOfHLevelΣ 2 (snd (A ⟅ c ⟆)) λ _ → isSet→isGroupoid (snd (F ⟅ c ⟆)) _ _
  -- for morphisms, we just apply A ⟪ h ⟫ (plus equality proof)
  K-ob (sliceob {A} ϕ) .F-hom {d , y} {c , x} (h , com) (b , eq)
    = ((A ⟪ h ⟫) b)
    , ((ϕ ⟦ c ⟧) ((A ⟪ h ⟫) b)
    ≡[ i ]⟨ (ϕ .N-hom h) i b ⟩
      (F ⟪ h ⟫) ((ϕ ⟦ d ⟧) b)
    ≡[ i ]⟨ (F ⟪ h ⟫) (eq i) ⟩
      (F ⟪ h ⟫) y
    ≡⟨ sym com ⟩
      x
    ∎)
  -- functoriality follows from functoriality of A
  K-ob (sliceob {A} ϕ) .F-id {x = (c , x)}
    = funExt λ { (a , fibp)
                → fibersEqIfRepsEqNatTrans ϕ (λ i → A .F-id i a) }
  K-ob (sliceob {A} ϕ) .F-seq {x = (c , x)} {(d , y)} {(e , z)} (f' , eq1) (g' , eq2)
    = funExt λ { ( a , fibp )
                  → fibersEqIfRepsEqNatTrans ϕ (λ i → (A .F-seq f' g') i a) }

  -- action on morphisms (in this case, natural transformation)
  K-hom : {sA sB : SliceCat .ob}
        → (ε : SliceCat [ sA , sB ])
        → (K-ob sA) ⇒ (K-ob sB)
  K-hom {sA = s1@(sliceob {A} ϕ)} {s2@(sliceob {B} ψ)} (slicehom ε com) = natTrans η-ob (λ h → funExt (η-hom h))
    where
      P = K-ob s1
      Q = K-ob s2

      -- just apply the natural transformation (ε) we're given
      -- this ensures that we stay in the fiber over x due to the commutativity given by slicenesss
      η-ob : (el : (∫ᴾ F) .ob) → (fst (P ⟅ el ⟆) → fst (Q ⟅ el ⟆) )
      η-ob (c , x) (a , ϕa≡x) = ((ε ⟦ c ⟧) a) , εψ≡ϕ ∙ ϕa≡x
        where
          εψ≡ϕ : (ψ ⟦ c ⟧) ((ε ⟦ c ⟧) a) ≡ (ϕ ⟦ c ⟧) a
          εψ≡ϕ i = ((com i) ⟦ c ⟧) a

      η-hom : ∀ {el1 el2} (h : (∫ᴾ F) [ el1 , el2 ]) (ae : fst (P ⟅ el2 ⟆)) → η-ob el1 ((P ⟪ h ⟫) ae) ≡ (Q ⟪ h ⟫) (η-ob el2 ae)
      η-hom {el1 = (c , x)} {d , y} (h , eqh) (a , eqa)
        = fibersEqIfRepsEqNatTrans ψ (λ i → ε .N-hom h i a)

  K : Functor SliceCat (PreShv (∫ᴾ F) ℓS)
  K .F-ob = K-ob
  K .F-hom = K-hom
  K .F-id = makeNatTransPath
                          (funExt λ cx@(c , x)
                                  → funExt λ aeq@(a , eq)
                                            → fibersEqIfRepsEq {isSetB = snd (F ⟅ c ⟆)} _ refl)
  K .F-seq (slicehom α eqa) (slicehom β eqb)
    = makeNatTransPath
        (funExt λ cx@(c , x)
        → funExt λ aeq@(a , eq)
        → fibersEqIfRepsEq {isSetB = snd (F ⟅ c ⟆)} _ refl)

  -- ========================================
  --            L : PreShv → Slice
  -- ========================================

  -- action on objects (presheaves)
  L-ob : (P : PreShv (∫ᴾ F) ℓS .ob)
        → SliceCat .ob
  L-ob P = sliceob {S-ob = L-ob-ob} L-ob-hom
    where
      -- sends c to the disjoint union of all the images under P
      LF-ob : (c : C .ob) → (SET _) .ob
      LF-ob c = (Σ[ x ∈ fst (F ⟅ c ⟆) ] fst (P ⟅ c , x ⟆)) , isSetΣ (snd (F ⟅ c ⟆)) (λ x → snd (P ⟅ c , x ⟆))

      -- defines a function piecewise over the fibers by applying P
      LF-hom : ∀ {x y}
              → (f : C [ y , x ])
              → (SET _) [ LF-ob x , LF-ob y ]
      LF-hom {x = c} {d} f (x , a) = ((F ⟪ f ⟫) x) , (P ⟪ f , refl ⟫) a

      L-ob-ob : Functor (C ^op) (SET _)
      L-ob-ob .F-ob = LF-ob
      L-ob-ob .F-hom = LF-hom
      L-ob-ob .F-id {x = c}
        = funExt idFunExt
          where
            idFunExt : ∀ (un : fst (LF-ob c))
                      → (LF-hom (C .id c) un) ≡ un
            idFunExt (x , X) = ΣPathP (leftEq , rightEq)
              where
                leftEq : (F ⟪ C .id c ⟫) x ≡ x
                leftEq i = F .F-id i x

                rightEq : PathP (λ i → fst (P ⟅ c , leftEq i ⟆))
                          ((P ⟪ C .id c , refl ⟫) X) X
                rightEq = left ▷ right
                  where
                    -- the id morphism in (∫ᴾ F)
                    ∫id = C .id c , sym (funExt⁻ (F .F-id) x ∙ refl)

                    -- functoriality of P gives us close to what we want
                    right : (P ⟪ ∫id ⟫) X ≡ X
                    right i = P .F-id i X

                    -- but need to do more work to show that (C .id c , refl) ≡ ∫id
                    left : PathP (λ i → fst (P ⟅ c , leftEq i ⟆))
                                  ((P ⟪ C .id c , refl ⟫) X)
                                  ((P ⟪ ∫id ⟫) X)
                    left i = (P ⟪ ∫ᴾhomEq {F = F} (C .id c , refl) ∫id (λ i → (c , leftEq i)) refl refl i ⟫) X
      L-ob-ob .F-seq {x = c} {d} {e} f g
        = funExt seqFunEq
          where
            seqFunEq : ∀ (un : fst (LF-ob c))
                      → (LF-hom (g ⋆⟨ C ⟩ f) un) ≡ (LF-hom g) (LF-hom f un)
            seqFunEq un@(x , X) = ΣPathP (leftEq , rightEq)
              where
                -- the left component is comparing the action of F on x
                -- equality follows from functoriality of F
                -- leftEq : fst (LF-hom (g ⋆⟨ C ⟩ f) un) ≡ fst ((LF-hom g) (LF-hom f un))
                leftEq : (F ⟪ g ⋆⟨ C ⟩ f ⟫) x ≡ (F ⟪ g ⟫) ((F ⟪ f ⟫) x)
                leftEq i = F .F-seq f g i x

                -- on the right, equality also follows from functoriality of P
                -- but it's more complicated because of heterogeneity
                -- since leftEq is not a definitional equality
                rightEq : PathP (λ i → fst (P ⟅ e , leftEq i ⟆))
                                ((P ⟪ g ⋆⟨ C ⟩ f , refl ⟫) X)
                                ((P ⟪ g , refl ⟫) ((P ⟪ f , refl ⟫) X))
                rightEq = left ▷ right
                  where
                    -- functoriality of P only gets us to this weird composition on the left
                    right : (P ⟪ (g , refl) ⋆⟨ (∫ᴾ F) ⟩ (f , refl) ⟫) X ≡ (P ⟪ g , refl ⟫) ((P ⟪ f , refl ⟫) X)
                    right i = P .F-seq (f , refl) (g , refl) i X

                    -- so we need to show that this composition is actually equal to the one we want
                    left : PathP (λ i → fst (P ⟅ e , leftEq i ⟆))
                                  ((P ⟪ g ⋆⟨ C ⟩ f , refl ⟫) X)
                                  ((P ⟪ (g , refl) ⋆⟨ (∫ᴾ F) ⟩ (f , refl) ⟫) X)
                    left i = (P ⟪ ∫ᴾhomEq {F = F} (g ⋆⟨ C ⟩ f , refl) ((g , refl) ⋆⟨ (∫ᴾ F) ⟩ (f , refl)) (λ i → (e , leftEq i)) refl refl i ⟫) X
      L-ob-hom : L-ob-ob ⇒ F
      L-ob-hom .N-ob c (x , _) = x
      L-ob-hom .N-hom f = funExt λ (x , _) → refl

  -- action on morphisms (aka natural transformations between presheaves)
  -- is essentially the identity (plus equality proofs for naturality and slice commutativity)
  L-hom : ∀ {P Q} → PreShv (∫ᴾ F) ℓS [ P , Q ] →
        SliceCat [ L-ob P , L-ob Q ]
  L-hom {P} {Q} η = slicehom arr com
    where
      A = S-ob (L-ob P)
      ϕ = S-arr (L-ob P)
      B = S-ob (L-ob Q)
      ψ = S-arr (L-ob Q)
      arr : A ⇒ B
      arr .N-ob c (x , X) = x , ((η ⟦ c , x ⟧) X)
      arr .N-hom {c} {d} f = funExt natu
        where
          natuType : fst (A ⟅ c ⟆) → Type _
          natuType xX@(x , X) = ((F ⟪ f ⟫) x , (η ⟦ d , (F ⟪ f ⟫) x ⟧) ((P ⟪ f , refl ⟫) X)) ≡ ((F ⟪ f ⟫) x , (Q ⟪ f , refl ⟫) ((η ⟦ c , x ⟧) X))
          natu : ∀ (xX : fst (A ⟅ c ⟆)) → natuType xX
          natu (x , X) = ΣPathP (refl , λ i → (η .N-hom (f , refl) i) X)

      com : arr ⋆⟨ PreShv C ℓS ⟩ ψ ≡ ϕ
      com = makeNatTransPath (funExt comFunExt)
        where
          comFunExt : ∀ (c : C .ob)
                    → (arr ●ᵛ ψ) ⟦ c ⟧ ≡ ϕ ⟦ c ⟧
          comFunExt c = funExt λ x → refl

  L : Functor (PreShv (∫ᴾ F) ℓS) SliceCat
  L .F-ob = L-ob
  L .F-hom = L-hom
  L .F-id {cx} = SliceHom-≡-intro' (makeNatTransPath (funExt λ c → refl))
  L .F-seq {cx} {dy} P Q = SliceHom-≡-intro' (makeNatTransPath (funExt λ c → refl))

  -- ========================================
  --              η : 𝟙 ≅ LK
  -- ========================================

  module _ where
    open Iso
    open Morphism renaming (isIso to isIsoC)
    -- the iso we need
    -- a type is isomorphic to the disjoint union of all its fibers
    typeSectionIso : ∀ {A B : Type ℓS} {isSetB : isSet B} → (ϕ : A → B)
                  → Iso A (Σ[ b ∈ B ] fiber ϕ b)
    typeSectionIso ϕ .fun a = (ϕ a) , (a , refl)
    typeSectionIso ϕ .inv (b , (a , eq)) = a
    typeSectionIso {isSetB = isSetB} ϕ .rightInv (b , (a , eq))
      = ΣPathP (eq
                , ΣPathP (refl
                        , isOfHLevel→isOfHLevelDep 1 (λ b' → isSetB _ _) refl eq eq))
    typeSectionIso ϕ .leftInv a = refl

    -- the natural transformation
    -- just applies typeSectionIso
    ηTrans : 𝟙⟨ SliceCat ⟩ ⇒ (L ∘F K)
    ηTrans .N-ob sob@(sliceob {A} ϕ) = slicehom A⇒LK comm
      where
        LKA = S-ob  (L ⟅ K ⟅ sob ⟆ ⟆)
        ψ = S-arr  (L ⟅ K ⟅ sob ⟆ ⟆)

        A⇒LK : A ⇒ LKA
        A⇒LK .N-ob c = typeSectionIso {isSetB = snd (F ⟅ c ⟆)} (ϕ ⟦ c ⟧) .fun
        A⇒LK .N-hom {c} {d} f = funExt homFunExt
          where
            homFunExt : (x : fst (A ⟅ c ⟆))
                      → (((ϕ ⟦ d ⟧) ((A ⟪ f ⟫) x)) , ((A ⟪ f ⟫) x , refl))  ≡ ((F ⟪ f ⟫) ((ϕ ⟦ c ⟧) x) , (A ⟪ f ⟫) x , _)
            homFunExt x = ΣPathP ((λ i → (ϕ .N-hom f i) x) , fibersEqIfRepsEqNatTrans ϕ refl)

        comm : (A⇒LK) ●ᵛ ψ ≡ ϕ
        comm = makeNatTransPath (funExt λ x → refl)
    ηTrans .N-hom {sliceob {A} α} {sliceob {B} β} (slicehom ϕ eq)
      = SliceHom-≡-intro' (makeNatTransPath (funExt (λ c → funExt λ a → natFunExt c a)))
      where
        natFunExt : ∀ (c : C .ob) (a : fst (A ⟅ c ⟆))
                  → ((β ⟦ c ⟧) ((ϕ ⟦ c ⟧) a) , (ϕ ⟦ c ⟧) a , _) ≡ ((α ⟦ c ⟧) a , (ϕ ⟦ c ⟧) a , _)
        natFunExt c a = ΣPathP ((λ i → ((eq i) ⟦ c ⟧) a) , fibersEqIfRepsEqNatTrans β refl)

    -- isomorphism follows from typeSectionIso
    ηIso : ∀ (sob : SliceCat .ob)
          → isIsoC {C = SliceCat} (ηTrans ⟦ sob ⟧)
    ηIso sob@(sliceob ϕ) = sliceIso _ _ (FUNCTORIso _ _ _ isIsoCf)
      where
        isIsoCf : ∀ (c : C .ob)
                → isIsoC (ηTrans .N-ob sob .S-hom ⟦ c ⟧)
        isIsoCf c = CatIso→isIso (Iso→CatIso (typeSectionIso {isSetB = snd (F ⟅ c ⟆)} (ϕ ⟦ c ⟧)))

  -- ========================================
  --              ε : KL ≅ 𝟙
  -- ========================================

  module _ where
    open Iso
    open Morphism renaming (isIso to isIsoC)
    -- the iso we deserve
    -- says that a type family at x is isomorphic to the fiber over x of that type family packaged up
    typeFiberIso : ∀ {ℓ ℓ'} {A : Type ℓ} {isSetA : isSet A} {x} (B : A → Type ℓ')
                  → Iso (B x) (fiber {A = Σ[ a ∈ A ] B a} (λ (x , _) → x) x)
    typeFiberIso {x = x} _ .fun b = (x , b) , refl
    typeFiberIso _ .inv ((a , b) , eq) = subst _ eq b
    typeFiberIso {isSetA = isSetA} {x = x} B .rightInv ((a , b) , eq)
      = fibersEqIfRepsEq {isSetB = isSetA} (λ (x , _) → x) (ΣPathP (sym eq , symP (transport-filler (λ i → B (eq i)) b)))
    typeFiberIso {x = x} _ .leftInv b = sym (transport-filler refl b)

    -- the natural isomorphism
    -- applies typeFiberIso (inv)
    εTrans : (K ∘F L) ⇒ 𝟙⟨ PreShv (∫ᴾ F) ℓS ⟩
    εTrans .N-ob P = natTrans γ-ob (λ f → funExt (λ a → γ-homFunExt f a))
      where
        KLP = K ⟅ L ⟅ P ⟆ ⟆

        γ-ob : (el : (∫ᴾ F) .ob)
            → (fst (KLP ⟅ el ⟆) → fst (P ⟅ el ⟆) )
        γ-ob el@(c , _) = typeFiberIso {isSetA = snd (F ⟅ c ⟆)} (λ x → fst (P ⟅ c , x ⟆)) .inv

        -- naturality
        -- the annoying part is all the substs
        γ-homFunExt : ∀ {el2 el1} → (f' : (∫ᴾ F) [ el2 , el1 ])
              → (∀ (a : fst (KLP ⟅ el1 ⟆)) → γ-ob el2 ((KLP ⟪ f' ⟫) a) ≡ (P ⟪ f' ⟫) (γ-ob el1 a))
        γ-homFunExt {d , y} {c , x} f'@(f , comm) a@((x' , X') , eq) i
          = comp (λ j → fst (P ⟅ d , eq' j ⟆)) (λ j → λ { (i = i0) → left j
                                                        ; (i = i1) → right j }) ((P ⟪ f , refl ⟫) X')
            where
              -- fiber equality proof that we get from an application of KLP
              eq' = snd ((KLP ⟪ f' ⟫) a)

              -- top right of the commuting diagram
              -- "remove" the subst from the inside
              right : PathP (λ i → fst (P ⟅ d , eq' i ⟆)) ((P ⟪ f , refl ⟫) X') ((P ⟪ f , comm ⟫) (subst _ eq X'))
              right i = (P ⟪ f , refl≡comm i ⟫) (X'≡subst i)
                where
                  refl≡comm : PathP (λ i → (eq' i) ≡ (F ⟪ f ⟫) (eq i)) refl comm
                  refl≡comm = isOfHLevel→isOfHLevelDep 1 (λ (v , w) → snd (F ⟅ d ⟆) v ((F ⟪ f ⟫) w)) refl comm λ i → (eq' i , eq i)

                  X'≡subst : PathP (λ i → fst (P ⟅ c , eq i ⟆)) X' (subst _ eq X')
                  X'≡subst = transport-filler (λ i → fst (P ⟅ c , eq i ⟆)) X'

              -- bottom left of the commuting diagram
              -- "remove" the subst from the outside
              left : PathP (λ i → fst (P ⟅ d , eq' i ⟆)) ((P ⟪ f , refl ⟫) X') (subst (λ v → fst (P ⟅ d , v ⟆)) eq' ((P ⟪ f , refl ⟫) X'))
              left = transport-filler (λ i → fst (P ⟅ d , eq' i ⟆)) ((P ⟪ f , refl ⟫) X')
    εTrans .N-hom {P} {Q} α = makeNatTransPath (funExt λ cx → funExt λ xX' → ε-homFunExt cx xX')
      where
        KLP = K ⟅ L ⟅ P ⟆ ⟆

        -- naturality of the above construction applies a similar argument as in `γ-homFunExt`
        ε-homFunExt : ∀ (cx@(c , x) : (∫ᴾ F) .ob) (xX'@((x' , X') , eq) : fst (KLP ⟅ cx ⟆))
                    → subst (λ v → fst (Q ⟅ c , v ⟆)) (snd ((K ⟪ L ⟪ α ⟫ ⟫ ⟦ cx ⟧) xX')) ((α ⟦ c , x' ⟧) X')
                    ≡ (α ⟦ c , x ⟧) (subst _ eq X')
        ε-homFunExt cx@(c , x) xX'@((x' , X') , eq) i
          = comp (λ j → fst (Q ⟅ c , eq j ⟆)) (λ j → λ { (i = i0) → left j
                                                        ; (i = i1) → right j }) ((α ⟦ c , x' ⟧) X')
          where
            eq' : x' ≡ x
            eq' = snd ((K ⟪ L ⟪ α ⟫ ⟫ ⟦ cx ⟧) xX')

            right : PathP (λ i → fst (Q ⟅ c , eq i ⟆)) ((α ⟦ c , x' ⟧) X') ((α ⟦ c , x ⟧) (subst _ eq X'))
            right i = (α ⟦ c , eq i ⟧) (X'≡subst i)
              where
                -- this is exactly the same as the one from before, can refactor?
                X'≡subst : PathP (λ i → fst (P ⟅ c , eq i ⟆)) X' (subst _ eq X')
                X'≡subst = transport-filler _ _

            -- extracted out type since need to use in in 'left' body as well
            leftTy : (x' ≡ x) → Type _
            leftTy eq* = PathP (λ i → fst (Q ⟅ c , eq* i ⟆)) ((α ⟦ c , x' ⟧) X') (subst (λ v → fst (Q ⟅ c , v ⟆)) eq' ((α ⟦ c , x' ⟧) X'))

            left : leftTy eq
            left = subst
                    (λ eq* → leftTy eq*)
                    eq'≡eq
                    (transport-filler _ _)
              where
                eq'≡eq : eq' ≡ eq
                eq'≡eq = snd (F ⟅ c ⟆) _ _ eq' eq

    εIso : ∀ (P : PreShv (∫ᴾ F) ℓS .ob)
          → isIsoC {C = PreShv (∫ᴾ F) ℓS} (εTrans ⟦ P ⟧)
    εIso P = FUNCTORIso _ _ _ isIsoC'
      where
        isIsoC' : ∀ (cx : (∫ᴾ F) .ob)
                → isIsoC {C = SET _} ((εTrans ⟦ P ⟧) ⟦ cx ⟧)
        isIsoC' cx@(c , _) = CatIso→isIso (Iso→CatIso (invIso (typeFiberIso {isSetA = snd (F ⟅ c ⟆)} _)))

  -- putting it all together

  preshvSlice≃preshvElem : SliceCat ≃ᶜ PreShv (∫ᴾ F) ℓS
  preshvSlice≃preshvElem .func = K
  preshvSlice≃preshvElem .isEquiv .invFunc = L
  preshvSlice≃preshvElem .isEquiv .η .trans = ηTrans
  preshvSlice≃preshvElem .isEquiv .η .nIso = ηIso
  preshvSlice≃preshvElem .isEquiv .ε .trans = εTrans
  preshvSlice≃preshvElem .isEquiv .ε .nIso = εIso


{-# OPTIONS --without-K --rewriting #-}

open import lib.Basics
open import lib.NType2
open import lib.types.Bool
open import lib.types.Empty
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Sigma

{-
This file contains various lemmas that rely on lib.types.Paths or
functional extensionality for pointed maps.
-}

module lib.types.Pointed where

{- Pointed maps -}

-- function extensionality for pointed maps
⊙λ= : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  (p : ∀ x → fst f x == fst g x)
  (α : snd f == snd g [ (λ y → y == pt Y) ↓ p (pt X) ])
  → f == g
⊙λ= {g = g} p α =
  pair= (λ= p) (↓-app=cst-in (↓-idf=cst-out α ∙ ap (_∙ snd g) (! (app=-β p _))))

{-
⊙λ=' : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  (p : ∀ x → fst f x == fst g x) (α : snd f == p (pt X) ∙ snd g)
  → f == g
⊙λ=' p α = ⊙λ= p (↓-idf=cst-in α)
-}

-- associativity of pointed maps
⊙∘-assoc-pt : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  {a₁ a₂ : A} (f : A → B) {b : B} (g : B → C) {c : C}
  (p : a₁ == a₂) (q : f a₂ == b) (r : g b == c)
  → ⊙∘-pt (g ∘ f) p (⊙∘-pt g q r) == ⊙∘-pt g (⊙∘-pt f p q) r
⊙∘-assoc-pt _ _ idp _ _ = idp

⊙∘-assoc : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (h : Z ⊙→ W) (g : Y ⊙→ Z) (f : X ⊙→ Y)
  → ((h ⊙∘ g) ⊙∘ f) == (h ⊙∘ (g ⊙∘ f))
⊙∘-assoc (h , hpt) (g , gpt) (f , fpt) = ⊙λ= (λ _ → idp) (⊙∘-assoc-pt g h fpt gpt hpt)

{- Pointed equivalences -}

-- Extracting data from an pointed equivalence
module _ {i j} {X : Ptd i} {Y : Ptd j} (⊙e : X ⊙≃ Y) where

  private
    e : de⊙ X ≃ de⊙ Y
    e = (fst (fst ⊙e) , snd ⊙e)

  ⊙≃-to-≃ = e

  ⊙–>-pt : –> e (pt X) == pt Y
  ⊙–>-pt = snd (fst ⊙e)

  private
    p = ⊙–>-pt

  ⊙–> : X ⊙→ Y
  ⊙–> = fst ⊙e

  ⊙<–-pt : <– e (pt Y) == pt X
  ⊙<–-pt = ap (<– e) (! ⊙–>-pt) ∙ <–-inv-l e (pt X)

  ⊙<– : Y ⊙→ X
  ⊙<– = <– e , ⊙<–-pt

  infix 120 _⊙⁻¹
  _⊙⁻¹ : Y ⊙≃ X
  _⊙⁻¹ = ⊙<– , is-equiv-inverse (snd ⊙e)

  ⊙<–-inv-l : ⊙<– ⊙∘ ⊙–> == ⊙idf _
  ⊙<–-inv-l = ⊙λ= (<–-inv-l e) $ ↓-idf=cst-in $
    ap (<– e) p ∙ ap (<– e) (! p) ∙ <–-inv-l e (pt X)
      =⟨ ! (∙-assoc (ap (<– e) p) (ap (<– e) (! p)) (<–-inv-l e (pt X))) ⟩
    (ap (<– e) p ∙ ap (<– e) (! p)) ∙ <–-inv-l e (pt X)
      =⟨ ∙-ap (<– e) p (! p) ∙ ap (ap (<– e)) (!-inv-r p)
         |in-ctx (λ w → w ∙ <–-inv-l e (pt X)) ⟩
    <–-inv-l e (pt X)
      =⟨ ! (∙-unit-r _) ⟩
    <–-inv-l e (pt X) ∙ idp =∎

  ⊙<–-inv-r : ⊙–> ⊙∘ ⊙<– == ⊙idf _
  ⊙<–-inv-r = ⊙λ= (<–-inv-r e) $ ↓-idf=cst-in $
    ap (–> e) (ap (<– e) (! p) ∙ <–-inv-l e (pt X)) ∙ p
      =⟨ ap-∙ (–> e) (ap (<– e) (! p)) (<–-inv-l e (pt X))
         |in-ctx (λ w → w ∙ p) ⟩
    (ap (–> e) (ap (<– e) (! p)) ∙ ap (–> e) (<–-inv-l e (pt X))) ∙ p
      =⟨ <–-inv-adj e (pt X)
         |in-ctx (λ w → (ap (–> e) (ap (<– e) (! p)) ∙ w) ∙ p) ⟩
    (ap (–> e) (ap (<– e) (! p)) ∙ <–-inv-r e (–> e (pt X))) ∙ p
      =⟨ ∘-ap (–> e) (<– e) (! p)
         |in-ctx (λ w → (w ∙ <–-inv-r e (–> e (pt X))) ∙ p) ⟩
    (ap (–> e ∘ <– e) (! p) ∙ <–-inv-r e (–> e (pt X))) ∙ p
      =⟨ ap (_∙ p) (! (↓-app=idf-out (apd (<–-inv-r e) (! p))))  ⟩
    (<–-inv-r e (pt Y) ∙' (! p)) ∙ p
      =⟨ ∙'=∙ (<–-inv-r e (pt Y)) (! p) |in-ctx _∙ p ⟩
    (<–-inv-r e (pt Y) ∙ (! p)) ∙ p
      =⟨ ∙-assoc (<–-inv-r e (pt Y)) (! p) p ⟩
    <–-inv-r e (pt Y) ∙ (! p ∙ p)
      =⟨ !-inv-l p |in-ctx (<–-inv-r e (pt Y)) ∙_ ⟩
    <–-inv-r e (pt Y) ∙ idp =∎

module _ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} (⊙e : X ⊙≃ Y) where

  post⊙∘-is-equiv : is-equiv (λ (k : Z ⊙→ X) → ⊙–> ⊙e ⊙∘ k)
  post⊙∘-is-equiv = is-eq f g f-g g-f
    where f = ⊙–> ⊙e ⊙∘_
          g = ⊙<– ⊙e ⊙∘_
          abstract
            f-g = λ k → ! (⊙∘-assoc (⊙–> ⊙e) (⊙<– ⊙e) k) ∙ ap (_⊙∘ k) (⊙<–-inv-r ⊙e) ∙ ⊙∘-unit-l k
            g-f = λ k → ! (⊙∘-assoc (⊙<– ⊙e) (⊙–> ⊙e) k) ∙ ap (_⊙∘ k) (⊙<–-inv-l ⊙e) ∙ ⊙∘-unit-l k

  pre⊙∘-is-equiv : is-equiv (λ (k : Y ⊙→ Z) → k ⊙∘ ⊙–> ⊙e)
  pre⊙∘-is-equiv = is-eq f g f-g g-f
    where f = _⊙∘ ⊙–> ⊙e
          g = _⊙∘ ⊙<– ⊙e
          abstract
            f-g = λ k → ⊙∘-assoc k (⊙<– ⊙e) (⊙–> ⊙e) ∙ ap (k ⊙∘_) (⊙<–-inv-l ⊙e) ∙ ⊙∘-unit-r k
            g-f = λ k → ⊙∘-assoc k (⊙–> ⊙e) (⊙<– ⊙e) ∙ ap (k ⊙∘_) (⊙<–-inv-r ⊙e) ∙ ⊙∘-unit-r k

  pre⊙∘-equiv : (Y ⊙→ Z) ≃ (X ⊙→ Z)
  pre⊙∘-equiv = _ , pre⊙∘-is-equiv

{- Pointed maps out of bool -}

-- intuition : [f true] is fixed and the only changable part is [f false].

⊙Bool→-to-idf : ∀ {i} {X : Ptd i}
  → ⊙Bool ⊙→ X → de⊙ X
⊙Bool→-to-idf (h , _) = h false

⊙Bool→-equiv-idf : ∀ {i} (X : Ptd i)
  → (⊙Bool ⊙→ X) ≃ de⊙ X
⊙Bool→-equiv-idf {i} X = equiv ⊙Bool→-to-idf g f-g g-f
  where
  g : de⊙ X → ⊙Bool ⊙→ X
  g x = (if_then pt X else x) , idp

  abstract
    f-g : ∀ x → ⊙Bool→-to-idf (g x) == x
    f-g x = idp

    g-f : ∀ H → g (⊙Bool→-to-idf H) == H
    g-f (h , hpt) = pair=
      (λ= lemma)
      (↓-app=cst-in $
        idp
          =⟨ ! (!-inv-l hpt) ⟩
        ! hpt ∙ hpt
          =⟨ ! (app=-β lemma true) |in-ctx (λ w → w ∙ hpt) ⟩
        app= (λ= lemma) true ∙ hpt
          =∎)
      where lemma : ∀ b → fst (g (h false)) b == h b
            lemma true = ! hpt
            lemma false = idp


module logic where

open import empty public
open import eq public
open import level public
open import negation public
open import neq public
open import product public
open import sum public
open import unit public


-- Andreas, 2013-03-20 Problem was that CompiledClause.Match.unfoldCoinduction
-- did not instantiate metas
-- {-# OPTIONS -v tc.meta.assign:10 -v tc.reduce:100 -v tc.with.abstract:50 #-}
{-# OPTIONS --allow-unsolved-metas #-}
module Issue826 where

open import Common.Coinduction

postulate
  A : Set
  x : A
  P : A → Set
  p : P x

data Q : ∞ A → Set where

♯x = ♯ x

Foo : Q ♯x
Foo = goal
  where
  x′ : _
  x′ = _ -- problem went away if we wrote ♯x here

  goal : Q x′ -- ensures that x′ = ♯ x (instantiates meta)
  goal = {!♭ x′!} -- normalization of this expression should be x, but was not

  -- Note that ♭ x′ is definitionally equal to x:

  ok : P (♭ x′)
  ok = p

  good : P x
  good with (♭ x′) | p
  good | y | p′ = p′

{- This still does not work because the underscore is solved too late,
   only after with-abstraction is taking place.

  bad : P (♭ x′)
  bad with x | p
  bad | y | p′ = p′

-}