{-# OPTIONS --copatterns #-}
{-# IMPORT Ex4Haskell #-}
{-# IMPORT System.IO #-}

module Ex4 where -- Conor: 8/20

{- I'm sorry I haven't quite finished setting this exercise yet, but by
   the joy of version control, the rest of it can be merged in later
   (quite soon). At least you can get cracking: I promise not to break
   anything, just to add a bit more on the end.

   The deadline for this is Friday of Week 12 (11 Dec).
   It'd be good to get the marks in before Christmas, but if the end of
   term is looking deadlinetastic, please open negotiations.

   UPDATE: I had to work around a bug in Agda to get this finished, so
   it took longer than I had hoped. I apologise, and will be flexible
   with deadlines, consequently. Also, I had to tweak the setup for
   cp a little, asking you to abstract out your definition of the
   FinalState of cp. I need to refer to it in the later code. That may
   cause a wee merge conflict, easily rectified with cut and paste.
-}

open import CS410-Prelude
open import CS410-Indexed

{-
data List (X : Set) : Set where  -- X scopes over the whole declaration...
  []    : List X                 -- ...so you can use it here...
  _::_  : X -> List X -> List X  -- ...and here.
infixr 3 _::_

{-# BUILTIN BOOL Two #-}
{-# BUILTIN TRUE tt #-}
{-# BUILTIN FALSE ff #-}
{-# BUILTIN LIST List #-}
{-# BUILTIN NIL [] #-}
{-# BUILTIN CONS _::_ #-}
{-# COMPILED_DATA List [] [] (:) #-}

postulate -- this means that we just suppose the following things exist...
  Char : Set
  String : Set

{-# BUILTIN CHAR Char #-}
{-# COMPILED_TYPE Char Char #-}
{-# BUILTIN STRING String #-}
{-# COMPILED_TYPE String String #-}

primitive -- these are baked in; they even work!
  primCharEquality : Char -> Char -> Two
  primStringAppend : String -> String -> String
  primStringToList : String -> List Char
  primStringFromList : List Char -> String
-}

---------------------------------------------------------------------------
-- WRITING FILES, AN INTERFACE
---------------------------------------------------------------------------

{- If you possess the ability to open a file for writing, you might
   have the following interface. -}

-- States
data WriteState : Set where
  opened closed : WriteState  -- do you currently have a file open or not?

-- Commands
data WriteC : WriteState -> Set where
  openWrite   : (fileName : String)  -> WriteC closed
  writeChar   : Char                 -> WriteC opened
  closeWrite  :                         WriteC opened

-- Responses
WriteR : (j : WriteState)(c : WriteC j) -> Set
WriteR .closed (openWrite fileName)  = WriteState  -- we get told whether it worked
WriteR .opened (writeChar x)         = One  -- always works
WriteR .opened closeWrite            = One  -- always works

{- 4.1 Implement the following operation which determines the next
   state. You should ensure that you can write characters only to
   a successfully opened file, and that you can write as many as
   you want. It should also be possible to insist that a process
   closes its file. -} -- Conor: 1/1

writeNext : (j : WriteState)(c : WriteC j) -> WriteR j c -> WriteState
writeNext .closed (openWrite fileName) r = r
writeNext .opened (writeChar x) r = opened
writeNext .opened closeWrite r = closed
-- the file writing interface, assembled as an indexed container
WRITE : WriteState => WriteState
WRITE = WriteC <! WriteR / writeNext

---------------------------------------------------------------------------
-- READING FILES, AN INTERFACE
---------------------------------------------------------------------------

{- To read from a file, it should be open, and you shouldn't be at the
   end of it. -}

-- States
data ReadState : Set where
  opened : (eof : Two) -> ReadState -- eof is tt if we're at end of file
  closed : ReadState

{- 4.2 Finish the READ implementation, in accordance with the description. -}
-- Conor: 2.5/3

-- Commands
data ReadC : ReadState -> Set where
  openRead    : (fileName : String) -> ReadC closed
 -- needs a filename; might not open successfully;
 -- might open an empty file
  readChar : ReadC (opened ff)
 -- makes sense only if we're not at end of file
 -- and might take us to end of file
  closeRead   : (eof : Two) -> ReadC (opened eof)
 -- makes sense only if the file is open

-- Responses
ReadR : (j : ReadState)(c : ReadC j) -> Set
ReadR .closed (openRead fileName) = ReadState
ReadR .(opened ff) readChar = Two  -- Conor: the character read should also be given
ReadR .(opened eof) (closeRead eof) = One

-- next State; you need to make sure the response gives enough info
readNext : (j : ReadState)(c : ReadC j) -> ReadR j c -> ReadState
readNext .closed (openRead fileName) r = r
readNext .(opened ff) readChar r =  opened r
readNext .(opened eof) (closeRead eof) r = closed

READ : ReadState => ReadState
READ = ReadC <! ReadR / readNext

---------------------------------------------------------------------------
-- COMBINING TWO INTERFACES WITH SHARED STATE
---------------------------------------------------------------------------

{- 4.3 Let's suppose we have two command-response interfaces which offer
       different functionality for the same system. Correspondingly, we'll
       have two indexed containers for the same index set. Show that you
       can combine them into one indexed container which lets you choose a
       command from either menu and evolves the state as specified by
       whichever interface offered the chosen command.
-} -- Conor: 1/1

_=+=_ : {I : Set} -> I => I -> I => I -> I => I
(Shape <! Position / index) =+= (Shape1 <! Position1 / index1) =
 (Shape +: Shape1) <!
 (λ j → λ {(inl x) → Position j x; (inr x) -> Position1 j x }) /
 (λ j → \{(inl x) → index j x ; (inr x) -> index1 j x})

--  {!λ {(inl x) Position → index j x Position ;(inl x) Position → index1 j x Position1 }!})

--_=+=_ : {I : Set} -> I => I -> I => I -> I => I
--(Shape <! Position / index) =+= (Shape1 <! Position1 / index1)
--  = (Shape +: Shape1) <!
-- (λ j → λ {(inl x) → Position j x; (inr x) -> Position1 j x }) /
-- (λ j x y → {! λ {?}!})
--
--(λ j x y → {!λ {(inl x) y → index j x y ;(inl x) y → index1 j x y }!})

--record _=>_ (I J : Set) : Set1 where
--  constructor _<!_/_
--  field
--    Shape     : J -> Set
--    Position  : (j : J) -> Shape j -> Set
--    index     : (j : J)(s : Shape j) -> Position j s -> I

---------------------------------------------------------------------------
-- WHEN IGNORANCE IS BLISS, BIS
---------------------------------------------------------------------------

{- 4.4 If we have a command-response interface with index I representing
       states of the system, show that we can index basically the same
       commands and responses over a state, I * J, where the J is just
       useless information which never changes. (This operation isn't
       super-useful on its own, but it's handy in combination with other
       things. -} -- Conor: 2/2

GrowR : {I J : Set} -> I => I -> (I * J) => (I * J)
GrowR (Shape <! Position / index)
  = (λ z → Shape (fst z))
  <! (λ j z → Position (fst j) z )
  / (λ j s x → index (fst j) s x , snd j)

-- do the same for "growing the index on the left"

GrowL : {I J : Set} -> I => I -> (J * I) => (J * I)
GrowL (Shape <! Position / index)
  = (λ z → Shape (snd z))
  <! (λ j z → Position (snd j) z)
  / (λ j s x → fst j , index (snd j) s x)

---------------------------------------------------------------------------
-- COMBINING TWO INTERFACES WITH SEPARATE STATE
---------------------------------------------------------------------------

{- 4.5 Making use of 4.3 and 4.4, show how to combine two interfaces which
       operate independently on separate state: commands from one should
       not affect the state of the other.
-} -- Conor: 1/1

_<+>_ : {I0 I1 : Set} -> I0 => I0 -> I1 => I1 -> (I0 * I1) => (I0 * I1)
CRn0 <+> CRn1 = GrowR CRn0 =+= GrowL CRn1

---------------------------------------------------------------------------
-- ERROR REPORTING, AN INTERFACE
---------------------------------------------------------------------------

{- I'm building the next bit for you.

   When things go wrong, we need to trigger an error condition and abort
   mission. However, if we have other stuff going on (open files, etc),
   it may not always be ok to drop everything and run away. There will
   be some states in which it is safe to escape (and deliver a suitable
   error message, perhaps) and other states in which escape should be
   impossible.

   If it is safe to issue an error message, we should be able to do so
   without fear of any response from the environment that would oblige
   us to carry on.
-}

data ErrorC {I : Set}(SafeMessage : I -> Set)(i : I) : Set where
  error : SafeMessage i -> ErrorC SafeMessage i
    -- the SafeMessage parameter tells us what is an acceptable
    -- error message in any given state; in states where this gives
    -- Zero, it will be impossible to trigger an error!

ErrorR : {I : Set}{SafeMessage : I -> Set}(i : I)(c : ErrorC SafeMessage i) -> Set
ErrorR _ _ = Zero  -- there's no comeback

errorNext : {I : Set}{SafeMessage : I -> Set}
            (i : I)(c : ErrorC SafeMessage i) -> ErrorR i c -> I
errorNext i c ()  -- so we don't have to say how the state will evolve

ERROR : {I : Set}(SafeMessage : I -> Set) -> I => I
ERROR SafeMessage = ErrorC SafeMessage <! ErrorR / errorNext

---------------------------------------------------------------------------
-- COPY A FILE
---------------------------------------------------------------------------

{- 4.6 Implement a process which, given access to suitable interfaces, will
       give the process for copying a named source file to a named target
       file. This goes in two phases.
-}

{- 4.6.1 Firstly, you should identify the command-reponse interface within
   which you need to work. You will need to be able to read and write files,
   but also to signal errors (in case a file fails to open for some reason).
   You must ensure that it is impossible for any process using your interface
   to escape with an error leaving a file open. You must also make it
   possible to guarantee that your copying process will, error or not, leave
   all files closed.
-} -- Conor: 0.5/1

CPState : Set
CPState =  ReadState * WriteState

CPInterface : CPState => CPState
CPInterface = (READ <+> WRITE) -- Conor: good start but, yes
--ERROR -- Conor: is the question

{-
 ReadState  WriteState
-}

{- 4.6.2 Secondly, you should implement your copying process, working to your
   interface.
-} -- Conor: 0/3

FinalState : CPState -> Set
FinalState c = {!!}

cp : (sourceFile targetFile : String) -> IterIx CPInterface FinalState {!!}
cp sourceFile targetFile = {!!}

{- HINTS
  You will certainly need to build some extra bits and pieces.

  You have the components for reading, writing and error handling, and
  suitable kit with which to combine them. Reading and writing don't
  interfere with each other, but it's important to make sure that you
  can't bomb out with an error, so some shared state seems important.

  There are really two phases to the process:
    (1) getting the files open  -- this may go wrong
    (2) copying from one to the other  -- this will work if we reach it
  You might want to split these phases apart.
-}

---------------------------------------------------------------
-- TO BE CONTINUED...
---------------------------------------------------------------

-- The rest of the exercise is to fill selected gaps in code that
-- gets your cp process to the stage where it actually compiles.

-- Agda version 2.4.2.4 is needed t compile the "copatterns" involved
-- in the code, but you should be able to complete the exercise
-- without upgrading, if you are currently using an earlier version.
-- It is only the business of generating a standalone executable that
-- needs the upgrade. Still, it'd be nice to see it go, wouldn't it?

-- The key is to build a device driver between your carefully
-- designed command-response system and "scripts" built from
-- low-level Haskell commands, maintaining the file handles
-- involved as you go.

-- Then you'll need to explain how to run the low-level script.

---------------------------------------------------------------
-- What's a Device Driver? (My bit. Do read.)
---------------------------------------------------------------

open _=>_ public

Driver :
  {I J : Set}              -- I is "high-level state" ; J, "low"
  (Sync : I -> J -> Set)   -- when are states "in sync"?
  (Hi : I => I)            -- high-level command-response system
  (Lo : J => J)            -- low-level command-response system
  -> Set

Driver {I}{J} Sync Hi Lo =
  forall i j -> Sync i j ->     -- whenever we're in sync,
  (c : Shape Hi i) ->           -- we can take a high-level command
  Sg (Shape Lo j) \ c' ->       -- and give the low-level version,
  (r' : Position Lo j c') ->    -- then take the low-level response
  Sg (Position Hi i c) \ r ->   -- and give the high-level version,
  Sync (index Hi i c r) (index Lo j c' r')  -- and stay in sync!

drive : forall  {I J}{Sync : I -> J -> Set}
                {Hi : I => I}{Lo : J => J}
                (D : Driver Sync Hi Lo)
                {X : I -> Set}
                (i : I)(j : J)
                (ij : Sync i j) ->  -- if we're in sync and have
                IC Hi X i ->        -- a high-level way to get an X
                IC Lo (\ j -> Sg I \ i -> Sync i j * X i) j
                  -- then we have a low-level plan to
                  -- stay in sync and get an X
drive D i j ij (c , k) =
  let x = D i j ij c ; c' = fst x ; D' = snd x
  in  c' , \ r' ->  -- issue low-level command c', get response r'
      let y = D' r' ; r = fst y ; s = snd y
      in  _ , s , k r  -- choose sync state from driver, call continuation

---------------------------------------------------------------
-- SCRIPTING COMMANDS (your bit)
---------------------------------------------------------------

{- 4.7 Complete the definition of the command response system
   for scripting commands built from another command response system,
   C. A scripted command is a whole strategy for interacting with C,
   the way you can write shell scripts which give strategies for
   issuing commands at a terminal. Your job is to give the type
   for responses (which should pack up all the responses to the
   commands) and compute the next state (which should be the state
   the system reaches when the script stops).

   Then you should construct the function which translates
   one SCRIPT C interaction to many C interactions. That's to say,
   implement the "script interpreter".
-} -- Conor: 0/2

SCRIPT : forall {I} -> (I => I) -> (I => I)
SCRIPT {I} C = FreeIx C (\ _ -> One) <! ScriptR / ScriptN where
  ScriptR : (i : I) -> FreeIx C (\ _ -> One) i -> Set
  ScriptR i cs = {!!}
  ScriptN : (i : I)(c : FreeIx C (\ _ -> One) i) -> ScriptR i c -> I
  ScriptN i cs rs = {!!}

unscript : forall {I}{X : I -> Set}(C : I => I) ->
           [ IC (SCRIPT C) X -:> FreeIx C X ]
unscript {I}{X} C (c , k) = help c k where
  help : {i : I}(c : FreeIx C (\ _ -> One) i)
         (k : (p : Position (SCRIPT C) i c) ->
                X (index (SCRIPT C) i c p)) ->
         FreeIx C X i
  help cs k = {!!}

---------------------------------------------------------------
-- An Interface to Haskell IO (also my bit)
---------------------------------------------------------------

-- an Agda Maybe-type which connects to Haskell's
data Maybe (X : Set) : Set where
  yes : X -> Maybe X
  no  : Maybe X
{-# COMPILED_DATA Maybe Maybe Just Nothing #-}

-- an Agda Either-type which connects to Haskell's
data Either (S T : Set) : Set where
  left  : S -> Either S T
  right : T -> Either S T
{-# COMPILED_DATA Either Either Left Right #-}

-- a copy of Haskell's file access more datatype
data IOMode : Set where
  readMode writeMode appendMode readWriteMode : IOMode
{-# COMPILED_DATA IOMode System.IO.IOMode System.IO.ReadMode System.IO.WriteMode System.IO.AppendMode System.IO.ReadWriteMode #-}

-- Haskell's file handles imported abstractly
postulate Handle : Set
{-# COMPILED_TYPE Handle System.IO.Handle #-}

-- The Low-Level Haskell Command-Response System. Please use wisely.

data HaskellIOCommand : Set where
  hOpen                   : String  -> IOMode  -> HaskellIOCommand
  hClose hIsEOF hGetChar  : Handle             -> HaskellIOCommand
  hPutChar                : Handle  -> Char    -> HaskellIOCommand
  hError                  : String             -> HaskellIOCommand

HaskellIOResponse : HaskellIOCommand -> Set
HaskellIOResponse (hOpen f m)     = Maybe Handle
HaskellIOResponse (hClose h)      = One
HaskellIOResponse (hIsEOF h)      = Two
HaskellIOResponse (hGetChar h)    = Char
HaskellIOResponse (hPutChar h c)  = One
HaskellIOResponse (hError e)      = Zero

HASKELLIO : One => One
HASKELLIO = (\ _ -> HaskellIOCommand) <! (\ _ -> HaskellIOResponse) / _

postulate       -- Haskell has a monad for doing IO, which we use at the top level
  IO      : Set -> Set
  return  : {A : Set} -> A -> IO A
  _>>=_   : {A B : Set} -> IO A -> (A -> IO B) -> IO B
  hOpenIO : String -> IOMode -> IO (Maybe Handle)
  hCloseIO : Handle -> IO One
  hIsEOFIO : Handle -> IO Two
  hGetCharIO : Handle -> IO Char
  hPutCharIO : Handle -> Char -> IO One
  hErrorIO : {X : Set} -> String -> IO X
  mainLoop : {S : Set} -> (S -> Either String (IO S)) -> (String -> String -> S) -> IO One
infixl 1 _>>=_
{-# BUILTIN IO IO #-}
{-# COMPILED_TYPE IO IO #-}
{-# COMPILED return (\ _ -> return)    #-}
{-# COMPILED _>>=_  (\ _ _ -> (>>=)) #-}
{-# COMPILED hOpenIO Ex4Haskell.hOpenIO #-}
{-# COMPILED hCloseIO Ex4Haskell.hCloseIO #-}
{-# COMPILED hIsEOFIO Ex4Haskell.hIsEOFIO #-}
{-# COMPILED hGetCharIO Ex4Haskell.hGetCharIO #-}
{-# COMPILED hPutCharIO Ex4Haskell.hPutCharIO #-}
{-# COMPILED hErrorIO (\ _ -> Ex4Haskell.hErrorIO) #-}
{-# COMPILED mainLoop (\ _ -> Ex4Haskell.mainLoop) #-}

-- We explain how to do one command.

doHaskellCommand : (c : HaskellIOCommand) -> IO (HaskellIOResponse c)
doHaskellCommand (hOpen n m) = hOpenIO n m
doHaskellCommand (hClose h)       = hCloseIO h
doHaskellCommand (hIsEOF h)       = hIsEOFIO h
doHaskellCommand (hGetChar h)     = hGetCharIO h
doHaskellCommand (hPutChar h c)   = hPutCharIO h c
doHaskellCommand (hError e)       = hErrorIO e

-- We need a MONAD MORPHISM to translate our HASKELLIO monad to
-- Haskell's IO Monad. A monad morphism is a function between monads
-- which respects return and >>=. Every monad morphism from a FREE
-- monad is given by explaining how to do one command.

haskellIO : forall {X} -> FreeIx HASKELLIO (\ _ -> X) <> -> IO X
haskellIO (ret x)        = return x
haskellIO (do (c , k))   = doHaskellCommand c >>= \ v -> haskellIO (k v)

---------------------------------------------------------------
-- The Driver (your bit)
---------------------------------------------------------------

-- Due to an annoying bug in Agda (which I reported and which has
-- been fixed in the head version), I had to resort to making
-- a rubbish version of One, called Dull.

postulate
  Dull : Set       -- it's a unit type
  dull : Dull      -- see? it has one thing in it?
                   -- you can't pattern match on it

-- For read and write states, we can say which handles we need to
-- know. We should know handles only when files are open.

RH : ReadState -> Set
RH (opened eof)  = Handle
RH closed        = Dull

WH : WriteState -> Set
WH opened        = Handle
WH closed        = Dull

{- 4.8 Define the appropriate notion of Sync for your notion of
   CPState. It should be a collection of the handles appropriate
   for the files currently open, built using RH and WH.

   Then build the driver, carefully. Remember, when reading, to
   check the end-of-file status as required.
-} -- Conor: 0/4

HANDLES : CPState -> One -> Set
HANDLES cps = {!!}

haskellDriver : Driver HANDLES CPInterface (SCRIPT HASKELLIO)
haskellDriver i j s c = {!!}

---------------------------------------------------------------
-- Putting it all together
---------------------------------------------------------------

-- A concrete STATE is some CPState for which we have
--   (i)   the right handles, and
--   (ii)  a plan for how to make progress with copying.

STATE : Set
STATE = Sg CPState \ i ->
        HANDLES i <> * IterIx CPInterface FinalState i

{- 4.9 For your chosen final state, you need to explain how to
   issue a message signalling successful completion. The empty
   string will do, but perhaps you want more. -} -- Conor: 0/1

finalMessage : (i : CPState) -> FinalState i -> String
finalMessage i x = {!!}

-- Now, in each state, we will either discover we're done, or
-- we'll learn the next bunch of Haskell commands to do.

runCP : STATE -> Either String (IO STATE)
runCP (i , h , cp) with force cp
runCP (i , h , cp)  | ret x  = left (finalMessage i x)
runCP (i , h , cp)  | do c   = right
  (haskellIO (unscript HASKELLIO
    (drive haskellDriver {IterIx CPInterface FinalState} i <> h c)))

{- 4.10 To complete the main program, fill in the starting
   CPState and its associated handle information. -} -- Conor: 0/1

main : IO One
main = mainLoop runCP \ src trg ->
         {!!} , {!!} , cp src trg

-- Now, to compile this (using Agda 2.4.2.4), grab a terminal and
-- issue the command
--
--   agda --compile Ex4.agda
--
-- and if you're very lucky, you should be able to issue commands
--
--   ./Ex4 <sourceFile> <targetFile>
--
-- Be careful not to overwrite your homework.
--
-- PS if in doubt about Agda versions, try
--
--   agda -V


------------------------------------------------------------------------
-- The Agda standard library
--
-- Infinite merge operation for coinductive lists
------------------------------------------------------------------------

{-# OPTIONS --without-K --guardedness #-}

module Codata.Musical.Colist.Infinite-merge where

open import Codata.Musical.Notation
open import Codata.Musical.Colist as Colist hiding (_⋎_)
open import Data.Nat
open import Data.Nat.Properties
open import Data.Product as Prod
open import Data.Sum
open import Data.Sum.Properties
open import Data.Sum.Function.Propositional using (_⊎-cong_)
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as Inv using (_↔_; Inverse; inverse)
import Function.Related as Related
open import Function.Related.TypeIsomorphisms
open import Induction.Nat using (<′-wellFounded)
import Induction.WellFounded as WF
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- Some code that is used to work around Agda's syntactic guardedness
-- checker.

private

  infixr 5 _∷_ _⋎_

  data ColistP {a} (A : Set a) : Set a where
    []  : ColistP A
    _∷_ : A → ∞ (ColistP A) → ColistP A
    _⋎_ : ColistP A → ColistP A → ColistP A

  data ColistW {a} (A : Set a) : Set a where
    []  : ColistW A
    _∷_ : A → ColistP A → ColistW A

  program : ∀ {a} {A : Set a} → Colist A → ColistP A
  program []       = []
  program (x ∷ xs) = x ∷ ♯ program (♭ xs)

  mutual

    _⋎W_ : ∀ {a} {A : Set a} → ColistW A → ColistP A → ColistW A
    []       ⋎W ys = whnf ys
    (x ∷ xs) ⋎W ys = x ∷ (ys ⋎ xs)

    whnf : ∀ {a} {A : Set a} → ColistP A → ColistW A
    whnf []        = []
    whnf (x ∷ xs)  = x ∷ ♭ xs
    whnf (xs ⋎ ys) = whnf xs ⋎W ys

  mutual

    ⟦_⟧P : ∀ {a} {A : Set a} → ColistP A → Colist A
    ⟦ xs ⟧P = ⟦ whnf xs ⟧W

    ⟦_⟧W : ∀ {a} {A : Set a} → ColistW A → Colist A
    ⟦ [] ⟧W     = []
    ⟦ x ∷ xs ⟧W = x ∷ ♯ ⟦ xs ⟧P

  mutual

    ⋎-homP : ∀ {a} {A : Set a} (xs : ColistP A) {ys} →
             ⟦ xs ⋎ ys ⟧P ≈ ⟦ xs ⟧P Colist.⋎ ⟦ ys ⟧P
    ⋎-homP xs = ⋎-homW (whnf xs) _

    ⋎-homW : ∀ {a} {A : Set a} (xs : ColistW A) ys →
             ⟦ xs ⋎W ys ⟧W ≈ ⟦ xs ⟧W Colist.⋎ ⟦ ys ⟧P
    ⋎-homW (x ∷ xs) ys = x ∷ ♯ ⋎-homP ys
    ⋎-homW []       ys = begin ⟦ ys ⟧P ∎
      where open ≈-Reasoning

  ⟦program⟧P : ∀ {a} {A : Set a} (xs : Colist A) →
               ⟦ program xs ⟧P ≈ xs
  ⟦program⟧P []       = []
  ⟦program⟧P (x ∷ xs) = x ∷ ♯ ⟦program⟧P (♭ xs)

  Any-⋎P : ∀ {a p} {A : Set a} {P : A → Set p} xs {ys} →
           Any P ⟦ program xs ⋎ ys ⟧P ↔ (Any P xs ⊎ Any P ⟦ ys ⟧P)
  Any-⋎P {P = P} xs {ys} =
    Any P ⟦ program xs ⋎ ys ⟧P                ↔⟨ Any-cong Inv.id (⋎-homP (program xs)) ⟩
    Any P (⟦ program xs ⟧P Colist.⋎ ⟦ ys ⟧P)  ↔⟨ Any-⋎ _ ⟩
    (Any P ⟦ program xs ⟧P ⊎ Any P ⟦ ys ⟧P)   ↔⟨ Any-cong Inv.id (⟦program⟧P _) ⊎-cong (_ ∎) ⟩
    (Any P xs ⊎ Any P ⟦ ys ⟧P)                ∎
    where open Related.EquationalReasoning

  index-Any-⋎P :
    ∀ {a p} {A : Set a} {P : A → Set p} xs {ys}
    (p : Any P ⟦ program xs ⋎ ys ⟧P) →
    index p ≥′ [ index , index ]′ (Inverse.to (Any-⋎P xs) ⟨$⟩ p)
  index-Any-⋎P xs p
    with       Any-resp      id  (⋎-homW (whnf (program xs)) _) p
       | index-Any-resp {f = id} (⋎-homW (whnf (program xs)) _) p
  index-Any-⋎P xs p | q | q≡p
    with Inverse.to (Any-⋎ ⟦ program xs ⟧P) ⟨$⟩ q
       |       index-Any-⋎ ⟦ program xs ⟧P      q
  index-Any-⋎P xs p | q | q≡p | inj₂ r | r≤q rewrite q≡p = r≤q
  index-Any-⋎P xs p | q | q≡p | inj₁ r | r≤q
    with       Any-resp      id  (⟦program⟧P xs) r
       | index-Any-resp {f = id} (⟦program⟧P xs) r
  index-Any-⋎P xs p | q | q≡p | inj₁ r | r≤q | s | s≡r
    rewrite s≡r | q≡p = r≤q

------------------------------------------------------------------------
-- Infinite variant of _⋎_.

private

  merge′ : ∀ {a} {A : Set a} → Colist (A × Colist A) → ColistP A
  merge′ []               = []
  merge′ ((x , xs) ∷ xss) = x ∷ ♯ (program xs ⋎ merge′ (♭ xss))

merge : ∀ {a} {A : Set a} → Colist (A × Colist A) → Colist A
merge xss = ⟦ merge′ xss ⟧P

------------------------------------------------------------------------
-- Any lemma for merge.

module _ {a p} {A : Set a} {P : A → Set p} where

  Any-merge : ∀ xss → Any P (merge xss) ↔ Any (λ { (x , xs) → P x ⊎ Any P xs }) xss
  Any-merge xss = inverse (proj₁ ∘ to xss) from (proj₂ ∘ to xss) to∘from
    where
    open P.≡-Reasoning

    -- The from function.

    Q = λ { (x , xs) → P x ⊎ Any P xs }

    from : ∀ {xss} → Any Q xss → Any P (merge xss)
    from (here (inj₁ p))        = here p
    from (here (inj₂ p))        = there (Inverse.from (Any-⋎P _)  ⟨$⟩ inj₁ p)
    from (there {x = _ , xs} p) = there (Inverse.from (Any-⋎P xs) ⟨$⟩ inj₂ (from p))

    -- The from function is injective.

    from-injective : ∀ {xss} (p₁ p₂ : Any Q xss) →
                     from p₁ ≡ from p₂ → p₁ ≡ p₂
    from-injective (here (inj₁ p))  (here (inj₁ .p)) P.refl = P.refl
    from-injective (here (inj₁ _))  (here (inj₂ _))  ()
    from-injective (here (inj₂ _))  (here (inj₁ _))  ()
    from-injective (here (inj₂ p₁)) (here (inj₂ p₂)) eq     =
      P.cong (here ∘ inj₂) $
      inj₁-injective $
      Inverse.injective (Inv.sym (Any-⋎P _)) {x = inj₁ p₁} {y = inj₁ p₂} $
      there-injective eq
    from-injective (here (inj₁ _))  (there _)  ()
    from-injective (here (inj₂ p₁)) (there p₂) eq
      with Inverse.injective (Inv.sym (Any-⋎P _))
                             {x = inj₁ p₁} {y = inj₂ (from p₂)}
                             (there-injective eq)
    ... | ()
    from-injective (there _)  (here (inj₁ _))  ()
    from-injective (there p₁) (here (inj₂ p₂)) eq
      with Inverse.injective (Inv.sym (Any-⋎P _))
                             {x = inj₂ (from p₁)} {y = inj₁ p₂}
                             (there-injective eq)
    ... | ()
    from-injective (there {x = _ , xs} p₁) (there p₂) eq =
      P.cong there $
      from-injective p₁ p₂ $
      inj₂-injective $
      Inverse.injective (Inv.sym (Any-⋎P xs))
                        {x = inj₂ (from p₁)} {y = inj₂ (from p₂)} $
      there-injective eq

    -- The to function (defined as a right inverse of from).

    Input = ∃ λ xss → Any P (merge xss)

    Pred : Input → Set _
    Pred (xss , p) = ∃ λ (q : Any Q xss) → from q ≡ p

    to : ∀ xss p → Pred (xss , p)
    to = λ xss p →
      WF.All.wfRec (WF.InverseImage.wellFounded size <′-wellFounded) _
                   Pred step (xss , p)
      where
      size : Input → ℕ
      size (_ , p) = index p

      step : ∀ p → WF.WfRec (_<′_ on size) Pred p → Pred p
      step ([]             , ())      rec
      step ((x , xs) ∷ xss , here  p) rec = here (inj₁ p) , P.refl
      step ((x , xs) ∷ xss , there p) rec
        with Inverse.to (Any-⋎P xs) ⟨$⟩ p
           | Inverse.left-inverse-of (Any-⋎P xs) p
           | index-Any-⋎P xs p
      ... | inj₁ q | P.refl | _   = here (inj₂ q) , P.refl
      ... | inj₂ q | P.refl | q≤p =
        Prod.map there
                 (P.cong (there ∘ _⟨$⟩_ (Inverse.from (Any-⋎P xs)) ∘ inj₂))
                 (rec (♭ xss , q) (s≤′s q≤p))

    to∘from = λ p → from-injective _ _ (proj₂ (to xss (from p)))

-- Every member of xss is a member of merge xss, and vice versa (with
-- equal multiplicities).

∈-merge : ∀ {a} {A : Set a} {y : A} xss →
          y ∈ merge xss ↔ ∃₂ λ x xs → (x , xs) ∈ xss × (y ≡ x ⊎ y ∈ xs)
∈-merge {y = y} xss =
  y ∈ merge xss                                           ↔⟨ Any-merge _ ⟩
  Any (λ { (x , xs) → y ≡ x ⊎ y ∈ xs }) xss               ↔⟨ Any-∈ ⟩
  (∃ λ { (x , xs) → (x , xs) ∈ xss × (y ≡ x ⊎ y ∈ xs) })  ↔⟨ Σ-assoc ⟩
  (∃₂ λ x xs → (x , xs) ∈ xss × (y ≡ x ⊎ y ∈ xs))         ∎
  where open Related.EquationalReasoning


module Readme where

-- SystemF with small-step semantics
-- and normal forms
open import SystemF.Everything

-- SystemF extended with functions that take implicit parameters
-- including a reduction to SystemF
open import Implicits.Everything

-- Simply typed lambda calculus with references,
-- accompanied by a store-passing small-step semantics
open import Impure.STLCRef.Readme

-- First order dependently typed lambda calculus with references,
-- accompanied by a store-passing small-step semantics
-- and a proof that the small-step semantics is deterministic
open import Impure.LFRef.Readme


-- Jesper, 2018-11-29: Instances with explicit arguments will never be
-- used, so declaring them should give a warning.

postulate
  X : Set
  instance _ : Set → X -- this should give a warning

it : {{_ : X}} → X
it {{x}} = x

-- OTOH, this is fine as the instance can be used inside the module
module _ (A : Set) where
  postulate instance instX : X

  test : X
  test = it

-- Andreas, 2020-01-29, issue #4360:
-- Such warnings should also be given for data and record constructors.

record R (A : Set) : Set where
  instance constructor r
  field
    a : A

data D (A : Set) : Set where
  instance c : A → D A


module Issue332 where

id : {A : Set} → A → A
id x = x

syntax id x = id x -- This makes parsing id x ambiguous


module CTL.Modalities.AG where

open import FStream.Core
open import Library

-- Certainly forever : s₀ ⊧ φ ⇔ ∀ s₀ R s₁ R ... ∀ i . sᵢ ⊧ φ
{-# NO_POSITIVITY_CHECK #-} -- Not necessary from Agda 2.6 upwards
record AG' {i : Size} {ℓ₁ ℓ₂} {C : Container ℓ₁}
  (props : FStream' C (Set ℓ₂)) : Set (ℓ₁ ⊔ ℓ₂) where
  coinductive
  field
    nowA   : head props
    laterA : {j : Size< i} → A (fmap AG' (inF (tail props)))
open AG' public

AG : ∀ {i : Size} {ℓ₁ ℓ₂} {C : Container ℓ₁}
   → FStream C (Set ℓ₂) → Set (ℓ₁ ⊔ ℓ₂)
AG props = APred AG' (inF props)

mutual
  AGₛ' : ∀ {i ℓ₁ ℓ₂} {C : Container ℓ₁}
       → FStream' C (Set ℓ₂) → FStream' {i} C (Set (ℓ₁ ⊔ ℓ₂))
  head (AGₛ' props) = AG' props
  tail (AGₛ' props) = AGₛ (tail props)

  AGₛ : ∀ {i ℓ₁ ℓ₂} {C : Container ℓ₁}
      → FStream C (Set ℓ₂) → FStream {i} C (Set (ℓ₁ ⊔ ℓ₂))
  inF (AGₛ props) = fmap AGₛ' (inF props)


postulate
  U V W X Y Z : Set
  u : U
  v : V
  w : W
  x : X
  y : Y
  z : Z

module Top (u : U) where
  module A (v : V) where
    module M (w : W) where
      module O (x : X) where
      postulate O : X
    postulate O : X
  module B (y : Y) where
    open A public

module Test0 where
  module C = Top.B u y
  module D = C.M.O v w x
  O₁ : X
  O₁ = C.M.O v w
  O₂ : X
  O₂ = C.O v

module Test1 where
  module C (i g n o r i n g m e : Z) = Top.B u y
  module D = C.M.O z z z z z z z z z z v w x
  O : X
  O = C.M.O z z z z z z z z z z v w

module Test2 where
  module C (y : Y) = Top.B u y
  module D = C.M.O y v w x
  O : X
  O = C.M.O y v w

module Test3 where
  module C (z : Z) = Top.B u y
  module D = C.M.O z v w x


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Cowriter type and some operations
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe --sized-types #-}

module Codata.Cowriter where

open import Size
import Level as L
open import Codata.Thunk using (Thunk; force)
open import Codata.Conat
open import Codata.Delay using (Delay; later; now)
open import Codata.Stream as Stream using (Stream; _∷_)

open import Data.Unit
open import Data.List using (List; []; _∷_)
open import Data.List.NonEmpty using (List⁺; _∷_)
open import Data.Nat.Base as Nat using (ℕ; zero; suc)
open import Data.Product as Prod using (_×_; _,_)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂)
open import Data.Vec using (Vec; []; _∷_)
open import Data.BoundedVec as BVec using (BoundedVec)
open import Function

data Cowriter {w a} (W : Set w) (A : Set a) (i : Size) : Set (a L.⊔ w) where
  [_] : A → Cowriter W A i
  _∷_ : W → Thunk (Cowriter W A) i → Cowriter W A i

------------------------------------------------------------------------
-- Relationship to Delay.

module _ {a} {A : Set a} where

  fromDelay : ∀ {i} → Delay A i → Cowriter ⊤ A i
  fromDelay (now a)    = [ a ]
  fromDelay (later da) = _ ∷ λ where .force → fromDelay (da .force)

module _ {w a} {W : Set w} {A : Set a} where

  toDelay : ∀ {i} → Cowriter W A i → Delay A i
  toDelay [ a ]    = now a
  toDelay (_ ∷ ca) = later λ where .force → toDelay (ca .force)

------------------------------------------------------------------------
-- Basic functions.

  fromStream : ∀ {i} → Stream W i → Cowriter W A i
  fromStream (w ∷ ws) = w ∷ λ where .force → fromStream (ws .force)

  repeat : W → Cowriter W A ∞
  repeat = fromStream ∘′ Stream.repeat

  length : ∀ {i} → Cowriter W A i → Conat i
  length [ _ ]    = zero
  length (w ∷ cw) = suc λ where .force → length (cw .force)

  splitAt : ∀ (n : ℕ) → Cowriter W A ∞ → (Vec W n × Cowriter W A ∞) ⊎ (BoundedVec W n × A)
  splitAt zero    cw       = inj₁ ([] , cw)
  splitAt (suc n) [ a ]    = inj₂ (BVec.[] , a)
  splitAt (suc n) (w ∷ cw) = Sum.map (Prod.map₁ (w ∷_)) (Prod.map₁ (w BVec.∷_))
                           $ splitAt n (cw .force)

  take : ∀ (n : ℕ) → Cowriter W A ∞ → Vec W n ⊎ (BoundedVec W n × A)
  take n = Sum.map₁ Prod.proj₁ ∘′ splitAt n

  infixr 5 _++_ _⁺++_
  _++_ : ∀ {i} → List W → Cowriter W A i → Cowriter W A i
  []       ++ ca = ca
  (w ∷ ws) ++ ca = w ∷ λ where .force → ws ++ ca

  _⁺++_ : ∀ {i} → List⁺ W → Thunk (Cowriter W A) i → Cowriter W A i
  (w ∷ ws) ⁺++ ca = w ∷ λ where .force → ws ++ ca .force

  concat : ∀ {i} → Cowriter (List⁺ W) A i → Cowriter W A i
  concat [ a ]    = [ a ]
  concat (w ∷ ca) = w ⁺++ λ where .force → concat (ca .force)

module _ {w x a b} {W : Set w} {X : Set x} {A : Set a} {B : Set b} where

------------------------------------------------------------------------
-- Functor, Applicative and Monad

  map : ∀ {i} → (W → X) → (A → B) → Cowriter W A i → Cowriter X B i
  map f g [ a ]    = [ g a ]
  map f g (w ∷ cw) = f w ∷ λ where .force → map f g (cw .force)

module _ {w a r} {W : Set w} {A : Set a} {R : Set r} where

  map₁ : ∀ {i} → (W → R) → Cowriter W A i → Cowriter R A i
  map₁ f = map f id

  map₂ : ∀ {i} → (A → R) → Cowriter W A i → Cowriter W R i
  map₂ = map id

  ap : ∀ {i} → Cowriter W (A → R) i → Cowriter W A i → Cowriter W R i
  ap [ f ]    ca = map₂ f ca
  ap (w ∷ cf) ca = w ∷ λ where .force → ap (cf .force) ca

  _>>=_ : ∀ {i} → Cowriter W A i → (A → Cowriter W R i) → Cowriter W R i
  [ a ]    >>= f = f a
  (w ∷ ca) >>= f = w ∷ λ where .force → ca .force >>= f

------------------------------------------------------------------------
-- Construction.

module _ {w s a} {W : Set w} {S : Set s} {A : Set a} where

  unfold : ∀ {i} → (S → (W × S) ⊎ A) → S → Cowriter W A i
  unfold next seed with next seed
  ... | inj₁ (w , seed') = w ∷ λ where .force → unfold next seed'
  ... | inj₂ a           = [ a ]


-- Andreas, 2020-06-23, issue #4773
-- reported by gallais, originally reported on mailing list by mechvel

-- Regression in 2.5.1:
-- import directives applied to modules no longer warn
-- when private names are mentioned

-- {-# OPTIONS -v scope:40 #-}

module _ where

-- MWE:
-------

module M where
  private
    X = Set
    Y = Set
    Z = Set

module N  = M using  (X) renaming (Y to Y') hiding (Z)

-- EXPECTED: warning about X, Y, Z

-- Extended original example, using 'open M args'
-------------------------------------------------

module A (X : Set₁) where
 Y = X

module B (X : Set₁) where
  open A X using (Y)
  private Z = Set

open B Set renaming (Y to Y') renaming (Z to Z')

-- EXPECTED: warning about Y, Z

-- Y' is not in scope
-- test = Y'


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import Util.PKCS
open import Util.Prelude
open import Yasm.Types

-- This module defines the types used to define a SystemModel.
module Yasm.Base (ℓ-PeerState : Level) where
 -- Our system is configured through a value of type
 -- SystemParameters where we specify:
 record SystemTypeParameters : Set (ℓ+1 ℓ-PeerState) where
  constructor mkSysTypeParms
  field
    PeerId    : Set
    _≟PeerId_ : ∀ (p₁ p₂ : PeerId) → Dec (p₁ ≡ p₂)
    Bootstrap : Set
    -- A relation specifying what Signatures are included in bootstrapInfo
    ∈BootstrapInfo  : Bootstrap → Signature → Set
    PeerState : Set ℓ-PeerState
    Msg       : Set
    Part      : Set -- Types of interest that can be represented in Msgs

    -- The messages must be able to carry signatures
    instance Part-sig : WithSig Part

    -- A relation specifying what Parts are included in a Msg.

    -- TODO-2: I changed the name of this to append the G because of the pain disambiguating it from
    -- NetworkMsg.⊂Msg.  This issue https://github.com/agda/agda/issues/2175 suggests I should have
    -- been able to get this right without renaming, but...  I'd like to underastand how to do this
    -- right, but for expedience, not now.
    _⊂MsgG_       : Part → Msg → Set

 module _ (systypes : SystemTypeParameters) where
   open SystemTypeParameters systypes

   record SystemInitAndHandlers : Set (ℓ+1 ℓ-PeerState) where
    constructor mkSysInitAndHandlers
    field
      -- The same bootstrap information is given to any uninitialised peer before
      -- it can handle any messages.
      bootstrapInfo : Bootstrap

      -- Represents an uninitialised PeerState, about which we know nothing whatsoever
      initPS    : PeerState

      -- Bootstraps a peer.  Our current system model is simplistic in that unsuccessful
      -- initialisation of a peer has no side effects.  In future, we could change the return type
      -- of bootstrap to Maybe PeerState × List (Action Msg), allowing for it to return nothing, but
      -- to include actions such as sending messages, logging, etc.  We are not doing so now as it
      -- is disruptive to existing proofs and modeling and verifying properties about unsuccessful
      -- initialisation is not a priority.
      bootstrap : PeerId → Bootstrap → Maybe (PeerState × List (Action Msg))

      -- Handles a message on a previously initialized peer.
      handle : PeerId → Msg → PeerState → PeerState × List (Action Msg)


------------------------------------------------------------------------
-- A coinductive definition of weak bisimilarity
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Labelled-transition-system

module Bisimilarity.Weak {ℓ} (lts : LTS ℓ) where

open import Equality.Propositional
open import Prelude
open import Prelude.Size

import Function-universe equality-with-J as F

import Bisimilarity
import Bisimilarity.Equational-reasoning-instances
import Bisimilarity.General
open import Equational-reasoning
import Expansion
import Expansion.Equational-reasoning-instances
open import Indexed-container using (Container; ν; ν′)
open import Relation
open import Up-to

open LTS lts
private
  open module SB = Bisimilarity lts
    using (_∼_; _∼′_; [_]_∼_; [_]_∼′_)
  open module E = Expansion lts
    using (_≳_; _≳′_; _≲_; [_]_≳_; [_]_≳′_)

private
  module General = Bisimilarity.General lts _[_]⇒̂_ _[_]⇒̂_ ⟶→⇒̂ ⟶→⇒̂

open General public
  using (module StepC; ⟨_,_⟩; left-to-right; right-to-left; force;
         [_]_≡_; [_]_≡′_; []≡↔; Extensionality; extensionality)
  renaming ( reflexive-∼ to reflexive-≈
           ; reflexive-∼′ to reflexive-≈′
           ; ≡⇒∼ to ≡⇒≈
           ; ∼:_ to ≈:_
           ; ∼′:_ to ≈′:_
           ; module Bisimilarity-of-∼ to Bisimilarity-of-≈
           )

-- StepC is given in the following way, rather than via open public,
-- to make hyperlinks to it more informative.

StepC : Container (Proc × Proc) (Proc × Proc)
StepC = General.StepC

-- The following definitions are given explicitly, to make the code
-- easier to follow for readers of the paper.

Weak-bisimilarity : Size → Rel₂ ℓ Proc
Weak-bisimilarity = ν StepC

Weak-bisimilarity′ : Size → Rel₂ ℓ Proc
Weak-bisimilarity′ = ν′ StepC

infix 4 [_]_≈_ [_]_≈′_ _≈_ _≈′_

[_]_≈_ : Size → Proc → Proc → Type ℓ
[ i ] p ≈ q = ν StepC i (p , q)

[_]_≈′_ : Size → Proc → Proc → Type ℓ
[ i ] p ≈′ q = ν′ StepC i (p , q)

_≈_ : Proc → Proc → Type ℓ
_≈_ = [ ∞ ]_≈_

_≈′_ : Proc → Proc → Type ℓ
_≈′_ = [ ∞ ]_≈′_

private

  -- However, these definitions are definitionally equivalent to
  -- corresponding definitions in General.

  indirect-Weak-bisimilarity :
    Weak-bisimilarity ≡ General.Bisimilarity
  indirect-Weak-bisimilarity = refl

  indirect-Weak-bisimilarity′ :
    Weak-bisimilarity′ ≡ General.Bisimilarity′
  indirect-Weak-bisimilarity′ = refl

  indirect-[]≈ : [_]_≈_ ≡ General.[_]_∼_
  indirect-[]≈ = refl

  indirect-[]≈′ : [_]_≈′_ ≡ General.[_]_∼′_
  indirect-[]≈′ = refl

  indirect-≈ : _≈_ ≡ General._∼_
  indirect-≈ = refl

  indirect-≈′ : _≈′_ ≡ General._∼′_
  indirect-≈′ = refl

-- Combinators that can perhaps make the code a bit nicer to read.

infix -3 lr-result rl-result

lr-result : ∀ {i p′ q q′} μ → [ i ] p′ ≈′ q′ → q [ μ ]⇒̂ q′ →
            ∃ λ q′ → q [ μ ]⇒̂ q′ × [ i ] p′ ≈′ q′
lr-result _ p′≈′q′ q⇒̂q′ = _ , q⇒̂q′ , p′≈′q′

rl-result : ∀ {i p p′ q′} μ → p [ μ ]⇒̂ p′ → [ i ] p′ ≈′ q′ →
            ∃ λ p′ → p [ μ ]⇒̂ p′ × [ i ] p′ ≈′ q′
rl-result _ p⇒̂p′ p′≈′q′ = _ , p⇒̂p′ , p′≈′q′

syntax lr-result μ p′≈′q′ q⇒̂q′ = p′≈′q′ ⇐̂[ μ ] q⇒̂q′
syntax rl-result μ p⇒̂p′ p′≈′q′ = p⇒̂p′ ⇒̂[ μ ] p′≈′q′

-- Processes that are related by the expansion ordering are weakly
-- bisimilar.

mutual

  ≳⇒≈ : ∀ {i p q} → [ i ] p ≳ q → [ i ] p ≈ q
  ≳⇒≈ {i} = λ p≳q → StepC.⟨ lr p≳q , rl p≳q ⟩
    where
    lr : ∀ {p p′ q μ} →
         [ i ] p ≳ q → p [ μ ]⟶ p′ →
         ∃ λ q′ → q [ μ ]⇒̂ q′ × [ i ] p′ ≈′ q′
    lr p≳q q⟶q′ =
      let p′ , p⟶̂p′ , p′≳′q′ = E.left-to-right p≳q q⟶q′
      in p′ , ⟶̂→⇒̂ p⟶̂p′ , ≳⇒≈′ p′≳′q′

    rl : ∀ {p q q′ μ} →
         [ i ] p ≳ q → q [ μ ]⟶ q′ →
         ∃ λ p′ → p [ μ ]⇒̂ p′ × [ i ] p′ ≈′ q′
    rl p≳q q⟶q′ =
      let p′ , p⇒p′ , p′≳′q′ = E.right-to-left p≳q q⟶q′
      in p′ , ⇒→⇒̂ p⇒p′ , ≳⇒≈′ p′≳′q′

  ≳⇒≈′ : ∀ {i p q} → [ i ] p ≳′ q → [ i ] p ≈′ q
  force (≳⇒≈′ p≳′q) = ≳⇒≈ (SB.force p≳′q)

-- Strongly bisimilar processes are weakly bisimilar.

∼⇒≈ : ∀ {i p q} → [ i ] p ∼ q → [ i ] p ≈ q
∼⇒≈ = ≳⇒≈ ∘ convert {a = ℓ}

∼⇒≈′ : ∀ {i p q} → [ i ] p ∼′ q → [ i ] p ≈′ q
∼⇒≈′ = ≳⇒≈′ ∘ convert {a = ℓ}

-- Weak bisimilarity is a weak simulation (of one kind).

weak-is-weak⇒ :
  ∀ {p p′ q} →
  p ≈ q → p ⇒ p′ →
  ∃ λ q′ → q ⇒ q′ × p′ ≈ q′
weak-is-weak⇒ = is-weak⇒ StepC.left-to-right (λ p≈′q → force p≈′q) ⇒̂→⇒

-- Weak bisimilarity is a weak simulation (of another kind).

weak-is-weak⇒̂ :
  ∀ {p p′ q μ} →
  p ≈ q → p [ μ ]⇒̂ p′ →
  ∃ λ q′ → q [ μ ]⇒̂ q′ × p′ ≈ q′
weak-is-weak⇒̂ =
  is-weak⇒̂ StepC.left-to-right (λ p≈′q → force p≈′q) ⇒̂→⇒ id

mutual

  -- Weak bisimilarity is symmetric.

  symmetric-≈ : ∀ {i p q} → [ i ] p ≈ q → [ i ] q ≈ p
  symmetric-≈ p≈q =
    StepC.⟨ Σ-map id (Σ-map id symmetric-≈′) ∘ StepC.right-to-left p≈q
          , Σ-map id (Σ-map id symmetric-≈′) ∘ StepC.left-to-right p≈q
          ⟩

  symmetric-≈′ : ∀ {i p q} → [ i ] p ≈′ q → [ i ] q ≈′ p
  force (symmetric-≈′ p≈q) = symmetric-≈ (force p≈q)

private

  -- An alternative proof of symmetry.

  alternative-proof-of-symmetry : ∀ {i p q} → [ i ] p ≈ q → [ i ] q ≈ p
  alternative-proof-of-symmetry {i} =
    uncurry [ i ]_≈_ ⁻¹  ⊆⟨ ν-symmetric _ _ swap refl F.id ⟩∎
    uncurry [ i ]_≈_     ∎

mutual

  -- Weak bisimilarity is transitive.
  --
  -- Note that the transitivity proof is not claimed to be
  -- size-preserving. For proofs showing that transitivity cannot, in
  -- general, be size-preserving in any of its arguments, see
  -- Bisimilarity.Weak.Delay-monad.size-preserving-transitivityʳ⇔uninhabited
  -- and size-preserving-transitivityˡ⇔uninhabited.

  transitive-≈ : ∀ {i p q r} → p ≈ q → q ≈ r → [ i ] p ≈ r
  transitive-≈ {i} = λ p≈q q≈r →
    StepC.⟨ lr p≈q q≈r
          , Σ-map id (Σ-map id symmetric-≈′) ∘
            lr (symmetric-≈ q≈r) (symmetric-≈ p≈q)
          ⟩
    where
    lr : ∀ {p p′ q r μ} →
         p ≈ q → q ≈ r → p [ μ ]⟶ p′ →
         ∃ λ r′ → r [ μ ]⇒̂ r′ × [ i ] p′ ≈′ r′
    lr p≈q q≈r p⟶p′ =
      let q′ , q⇒̂q′ , p′≈′q′ = StepC.left-to-right p≈q p⟶p′
          r′ , r⇒̂r′ , q′≈r′  = weak-is-weak⇒̂ q≈r q⇒̂q′
      in r′ , r⇒̂r′ , transitive-≈′ p′≈′q′ q′≈r′

  transitive-≈′ : ∀ {i p q r} → p ≈′ q → q ≈ r → [ i ] p ≈′ r
  force (transitive-≈′ p≈q q≈r) = transitive-≈ (force p≈q) q≈r

-- The following variants of transitivity are partially
-- size-preserving.
--
-- For proofs showing that they cannot, in general, be size-preserving
-- in the "other" argument, see the following lemmas in
-- Bisimilarity.Weak.Delay-monad:
-- size-preserving-transitivity-≳≈ˡ⇔uninhabited,
-- size-preserving-transitivity-≈≲ʳ⇔uninhabited and
-- size-preserving-transitivity-≈∼ʳ⇔uninhabited.

mutual

  transitive-≳≈ : ∀ {i p q r} →
                  p ≳ q → [ i ] q ≈ r → [ i ] p ≈ r
  transitive-≳≈ {i} {p} {r = r} p≳q q≈r = StepC.⟨ lr , rl ⟩
    where
    lr : ∀ {p′ μ} → p [ μ ]⟶ p′ →
         ∃ λ r′ → r [ μ ]⇒̂ r′ × [ i ] p′ ≈′ r′
    lr p⟶p′ with E.left-to-right p≳q p⟶p′
    ... | _  , done s , p≳′q′  =
      r , silent s done
        , transitive-≳≈′ p≳′q′ (record { force = λ { {_} → q≈r } })
    ... | q′ , step q⟶q′ , p′≳′q′ =
      let r′ , r⇒̂r′ , q′≈′r′ = StepC.left-to-right q≈r q⟶q′
      in r′ , r⇒̂r′ , transitive-≳≈′ p′≳′q′ q′≈′r′

    rl : ∀ {r′ μ} → r [ μ ]⟶ r′ →
         ∃ λ p′ → p [ μ ]⇒̂ p′ × [ i ] p′ ≈′ r′
    rl r⟶r′ =
      let q′ , q⇒̂q′ , q′≈′r′ = StepC.right-to-left q≈r r⟶r′
          p′ , p⇒̂p′ , p′≳q′  = E.converse-of-expansion-is-weak⇒̂ p≳q q⇒̂q′
      in p′ , p⇒̂p′ , transitive-≳≈′ (record { force = p′≳q′ }) q′≈′r′

  transitive-≳≈′ : ∀ {i p q r} →
                   p ≳′ q → [ i ] q ≈′ r → [ i ] p ≈′ r
  force (transitive-≳≈′ p≳′q q≈′r) =
    transitive-≳≈ (force p≳′q) (force q≈′r)

transitive-≈≲ : ∀ {i p q r} →
                [ i ] p ≈ q → q ≲ r → [ i ] p ≈ r
transitive-≈≲ p≈q q≲r =
  symmetric-≈ (transitive-≳≈ q≲r (symmetric-≈ p≈q))

transitive-≈∼ : ∀ {i p q r} →
                [ i ] p ≈ q → q ∼ r → [ i ] p ≈ r
transitive-≈∼ p≈q q∼r =
  symmetric-≈ $
    transitive-≳≈ (convert {a = ℓ} (symmetric q∼r)) (symmetric-≈ p≈q)


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

open import Agda.Primitive using (Prop)

postulate
  Set₁ : Prop

open import Agda.Primitive using (Set)

postulate
  A : Set₁


module reverse_string where

open import Data.String
open import Data.List

reverse_string : String → String
reverse_string s = fromList (reverse (toList s))


------------------------------------------------------------------------
-- Experiments related to equality
--
-- Nils Anders Danielsson
--
-- Some files have been developed in collaboration with others, see
-- the individual files.
------------------------------------------------------------------------

{-# OPTIONS --cubical --with-K --guardedness --sized-types --prop #-}

module README where

-- "Safe" code that uses --without-K.

import README.Safe.Without-K

-- "Safe" code that uses --erased-cubical.

import README.Safe.Cubical.Erased

-- "Safe" code that uses --erased-cubical and --guardedness.

import README.Safe.Cubical.Erased.Guardedness

-- "Safe" code that uses --erased-cubical and --prop.

import README.Safe.Cubical.Erased.Prop

-- "Safe" code that uses --cubical.

import README.Safe.Cubical

-- "Safe" code that uses --with-K.

import README.Safe.With-K

-- Code which might depend on potentially unsafe features (other than
-- --sized-types).

import README.Unsafe

-- Code which is "safe", except for the use of --sized-types.

import README.Unsafe.Sized-types

-- Code related to the paper "Logical properties of a modality for
-- erasure". This code uses both --cubical and --with-K, but not at
-- the same time, except in the module README.Erased, which for that
-- reason cannot use --safe.

import README.Erased


module Issue892b where

record R : Set₁ where
  field A : Set
        B : A → Set

-- The type of R.B should print as (r : R) → R.A r → Set
-- rather than ( : R) → R.A  → Set.
bad : R.B
bad = ?


module Data.List.SizeOrdering where

open import Data.List


open import Agda.Builtin.List
open import Agda.Builtin.Reflection

macro

  print : (Set → Set) → Term → TC _
  print t _ = bindTC (quoteTC t) λ t →
              typeError (termErr t ∷ [])

-- Prints λ { X → X }.

Test₁ : Set
Test₁ = {!print (λ { X → X })!}

module _ (A : Set) where

  -- Prints λ { A₁ X → X }.

  Test₂ : Set
  Test₂ = {!print (λ { X → X })!}

  -- Prints λ { B₁ X → X } B.

  Test₃ : Set → Set
  Test₃ B = {!print (λ { X → X })!}

module _ (A : Set) where

  -- Prints λ { A₁ X → A₁ }. Note that A is not mentioned at all.

  Test₄ : Set
  Test₄ = {!print (λ { X → A })!}

  -- Prints λ { B₁ X → A } B.

  Test₅ : Set → Set
  Test₅ B = {!print (λ { X → A })!}


open import MJ.Types
import MJ.Classtable.Core as Core

module MJ.Syntax.Untyped {c}(Ct : Core.Classtable c) where

open import Prelude
open import Data.Maybe as Maybe using (Maybe; just; nothing)
open import Data.Maybe.All as MayAll
open import Data.Vec as Vec hiding (_∈_)
open import Data.Star
open import Data.List.Most
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
open import Data.String

import Data.Vec.All as Vec∀

open Core c
open Classtable Ct
open import MJ.Classtable.Membership Ct
open import MJ.LexicalScope Ct

NativeBinOp = ℕ → ℕ → ℕ

data Expr (n : ℕ) : Set where
  new      : Cid c → List (Expr n) → Expr n
  unit     : Expr n
  null     : Expr n
  num      : ℕ → Expr n
  iop      : NativeBinOp → (l r : Expr n) → Expr n
  call     : Expr n → String → List (Expr n) → Expr n
  var      : Fin n → Expr n
  get      : Expr n → String → Expr n

mutual
  data Stmt (i : ℕ) : ℕ → Set where
    loc        : Ty c → Stmt i (suc i)
    asgn       : Fin i → Expr i → Stmt i i
    set        : Expr i → String → Expr i → Stmt i i
    do         : Expr i → Stmt i i
    ret        : Expr i → Stmt i i
    raise      : Stmt i i
    try_catch_ : ∀ {o o'} → Stmt i o → Stmt i o' → Stmt i i
    while_do_  : ∀ {o} → Expr i → Stmt i o → Stmt i i
    block      : ∀ {o} → Stmts i o → Stmt i i

  Stmts : ℕ → ℕ → Set
  Stmts = Star Stmt

data Body (i : ℕ) : Set where
  body : ∀ {o} → Stmts i o → Expr o → Body i

-- let n be the number of formal method arguments
data Method (n : ℕ) : Set where
  super⟨_⟩then_ : List (Expr (suc n)) → Body (suc (suc n)) → Method n
  body          : Body (suc n) → Method n

-- let n be the number of formal constructor arguments
data Constructor (n : ℕ) : Set where
  super_then_ : List (Expr (suc n)) → Body (suc n) → Constructor n
  body        : Body (suc n) → Constructor n

record Implementation (cid : _): Set where
  constructor implementation
  open Class (Σ cid) public
  field
    construct : Constructor (length constr)
    mbodies   : All (λ{ (name , (as , b)) → Method (length as) }) (decls METHOD)

Classes = ∀ cid → Implementation cid

Prog : Set
Prog = Classes × (Body 0)


------------------------------------------------------------------------
-- A variant of the lens type in
-- Lens.Non-dependent.Higher.Capriotti.Variant.Erased
--
-- This variant uses ∥_∥ᴱ instead of ∥_∥.
------------------------------------------------------------------------

import Equality.Path as P

module Lens.Non-dependent.Higher.Capriotti.Variant.Erased.Variant
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J as B using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
open import Equivalence.Erased.Cubical eq as EEq using (_≃ᴱ_)
open import Equivalence.Erased.Contractible-preimages.Cubical eq as ECP
  using (_⁻¹ᴱ_; Contractibleᴱ)
open import Erased.Cubical eq
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as PT using (∥_∥; ∣_∣)
open import H-level.Truncation.Propositional.Erased eq as T
  using (∥_∥ᴱ; ∣_∣)
open import Preimage equality-with-J using (_⁻¹_)
open import Univalence-axiom equality-with-J

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher.Erased eq as Higher
import Lens.Non-dependent.Higher.Capriotti.Variant eq as V

private
  variable
    a b p q  : Level
    A B      : Type a
    P Q      : A → Type p
    b₁ b₂ b₃ : A
    f        : (x : A) → P x

------------------------------------------------------------------------
-- Coherently-constant

-- Coherently constant type-valued functions.

Coherently-constant :
  {A : Type a} → (A → Type p) → Type (a ⊔ lsuc p)
Coherently-constant {p = p} {A = A} P =
  ∃ λ (Q : ∥ A ∥ᴱ → Type p) →
    (∀ x → P x ≃ᴱ Q ∣ x ∣) ×
    ∃ λ (Q→Q : ∀ x y → Q x → Q y) →
      Erased (∀ x y → Q→Q x y ≡
                      subst Q (T.truncation-is-proposition x y))

-- The "last part" of Coherently-constant is contractible (in erased
-- contexts).

@0 Contractible-last-part-of-Coherently-constant :
  Contractible
    (∃ λ (Q→Q : ∀ x y → Q x → Q y) →
     Erased (∀ x y → Q→Q x y ≡
                     subst Q (T.truncation-is-proposition x y)))
Contractible-last-part-of-Coherently-constant {Q = Q} =           $⟨ Contractibleᴱ-Erased-singleton ⟩
  Contractibleᴱ
    (∃ λ (Q→Q : ∀ x y → Q x → Q y) →
     Erased (Q→Q ≡ λ x y →
                   subst Q (T.truncation-is-proposition x y)))    ↝⟨ (ECP.Contractibleᴱ-cong _ $
                                                                      ∃-cong λ _ → Erased-cong (inverse $
                                                                      Eq.extensionality-isomorphism ext F.∘
                                                                      ∀-cong ext λ _ → Eq.extensionality-isomorphism ext)) ⦂ (_ → _) ⟩
  Contractibleᴱ
    (∃ λ (Q→Q : ∀ x y → Q x → Q y) →
     Erased (∀ x y → Q→Q x y ≡
                     subst Q (T.truncation-is-proposition x y)))  ↝⟨ ECP.Contractibleᴱ→Contractible ⟩□

  Contractible
    (∃ λ (Q→Q : ∀ x y → Q x → Q y) →
     Erased (∀ x y → Q→Q x y ≡
                     subst Q (T.truncation-is-proposition x y)))  □

-- In erased contexts Coherently-constant P is equivalent to
-- V.Coherently-constant P.

@0 Coherently-constant≃Variant-coherently-constant :
  {P : A → Type p} →
  Coherently-constant P ≃ V.Coherently-constant P
Coherently-constant≃Variant-coherently-constant {A = A} {P = P} =
  (∃ λ (Q : ∥ A ∥ᴱ → _) → (∀ x → P x ≃ᴱ Q ∣ x ∣) × _)  ↔⟨ (∃-cong λ _ → drop-⊤-right λ _ →
                                                           _⇔_.to contractible⇔↔⊤
                                                           Contractible-last-part-of-Coherently-constant) ⟩
  (∃ λ (Q : ∥ A ∥ᴱ → _) → ∀ x → P x ≃ᴱ Q ∣ x ∣)        ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → inverse
                                                           EEq.≃≃≃ᴱ) ⟩
  (∃ λ (Q : ∥ A ∥ᴱ → _) → ∀ x → P x ≃  Q ∣ x ∣)        ↝⟨ (Σ-cong {k₁ = equivalence} (→-cong₁ ext PT.∥∥ᴱ≃∥∥) λ _ → F.id) ⟩□
  (∃ λ (Q : ∥ A ∥  → _) → ∀ x → P x ≃  Q ∣ x ∣)        □

-- In erased contexts Coherently-constant (f ⁻¹ᴱ_) is equivalent to
-- V.Coherently-constant (f ⁻¹_).

@0 Coherently-constant-⁻¹ᴱ≃Variant-coherently-constant-⁻¹ :
  Coherently-constant (f ⁻¹ᴱ_) ≃ V.Coherently-constant (f ⁻¹_)
Coherently-constant-⁻¹ᴱ≃Variant-coherently-constant-⁻¹ {f = f} =
  Coherently-constant (f ⁻¹ᴱ_)        ↝⟨ Coherently-constant≃Variant-coherently-constant ⟩
  V.Coherently-constant (f ⁻¹ᴱ_)      ↔⟨⟩
  (∃ λ Q → ∀ x → f ⁻¹ᴱ x ≃  Q ∣ x ∣)  ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ →
                                          Eq.≃-preserves ext (inverse ECP.⁻¹≃⁻¹ᴱ) F.id) ⟩
  (∃ λ Q → ∀ x → f ⁻¹ x ≃  Q ∣ x ∣)   ↔⟨⟩
  V.Coherently-constant (f ⁻¹_)       □

-- A variant of Coherently-constant.

Coherently-constant′ :
  {A : Type a} → (A → Type p) → Type (a ⊔ lsuc p)
Coherently-constant′ {p = p} {A = A} P =
  ∃ λ (P→P : ∀ x y → P x → P y) →
  ∃ λ (Q : ∥ A ∥ᴱ → Type p) →
  ∃ λ (P≃Q : ∀ x → P x ≃ᴱ Q ∣ x ∣) →
  Erased (P→P ≡
          λ x y →
          _≃ᴱ_.from (P≃Q y) ∘
          subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
          _≃ᴱ_.to (P≃Q x))

-- Coherently-constant and Coherently-constant′ are pointwise
-- equivalent (with erased proofs).

Coherently-constant≃ᴱCoherently-constant′ :
  Coherently-constant P ≃ᴱ Coherently-constant′ P
Coherently-constant≃ᴱCoherently-constant′ {P = P} =
  (∃ λ Q →
   (∀ x → P x ≃ᴱ Q ∣ x ∣) ×
   ∃ λ (Q→Q : ∀ x y → Q x → Q y) →
   Erased (∀ x y → Q→Q x y ≡ subst Q (T.truncation-is-proposition x y)))  ↝⟨ lemma ⟩

  (∃ λ Q →
   ∃ λ (P≃Q : ∀ x → P x ≃ᴱ Q ∣ x ∣) →
   ∃ λ (P→P : ∀ x y → P x → P y) →
   Erased (P→P ≡
           λ x y →
           _≃ᴱ_.from (P≃Q y) ∘
           subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
           _≃ᴱ_.to (P≃Q x)))                                              ↔⟨ ∃-comm F.∘
                                                                             (∃-cong λ _ → ∃-comm) ⟩□
  (∃ λ (P→P : ∀ x y → P x → P y) →
   ∃ λ Q →
   ∃ λ (P≃Q : ∀ x → P x ≃ᴱ Q ∣ x ∣) →
   Erased (P→P ≡
           λ x y →
           _≃ᴱ_.from (P≃Q y) ∘
           subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
           _≃ᴱ_.to (P≃Q x)))                                              □
  where
  lemma =
    ∃-cong λ Q → ∃-cong λ P≃Q →

    (∃ λ (Q→Q : ∀ x y → Q x → Q y) →
     Erased (∀ x y →
             Q→Q x y ≡ subst Q (T.truncation-is-proposition x y)))        ↔⟨ (∀-cong ext λ _ → ∃-cong λ _ → Erased-cong (from-equivalence $
                                                                              Eq.extensionality-isomorphism bad-ext)) F.∘
                                                                             inverse ΠΣ-comm F.∘
                                                                             (∃-cong λ _ → Erased-Π↔Π) ⟩
    (∀ x →
     ∃ λ (Q→Q : ∀ y → Q x → Q y) →
     Erased (Q→Q ≡ λ y → subst Q (T.truncation-is-proposition x y)))      ↔⟨ (∀-cong ext λ _ →
                                                                              T.Σ-Π-∥∥ᴱ-Erased-≡-≃) ⟩
    (∀ x →
     ∃ λ (Q→Q : ∀ y → Q x → Q ∣ y ∣) →
     Erased (Q→Q ≡ λ y → subst Q (T.truncation-is-proposition x ∣ y ∣)))  ↔⟨ (∃-cong λ _ →
                                                                              (Erased-cong (from-equivalence $
                                                                               Eq.extensionality-isomorphism bad-ext)) F.∘
                                                                              inverse Erased-Π↔Π) F.∘
                                                                             ΠΣ-comm ⟩
    (∃ λ (Q→Q : ∀ x y → Q x → Q ∣ y ∣) →
     Erased (Q→Q ≡
             λ x y → subst Q (T.truncation-is-proposition x ∣ y ∣)))      ↔⟨ T.Σ-Π-∥∥ᴱ-Erased-≡-≃ ⟩

    (∃ λ (Q→Q : ∀ x y → Q ∣ x ∣ → Q ∣ y ∣) →
     Erased (Q→Q ≡
             λ x y → subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣)))  ↔⟨ (inverse $
                                                                              ΠΣ-comm F.∘
                                                                              (∀-cong ext λ _ → ΠΣ-comm)) F.∘
                                                                             (∃-cong λ _ →
                                                                              ((∀-cong ext λ _ → Erased-Π↔Π) F.∘
                                                                               Erased-Π↔Π) F.∘
                                                                              Erased-cong (from-equivalence $ inverse $
                                                                              Eq.extensionality-isomorphism bad-ext F.∘
                                                                              (∀-cong ext λ _ → Eq.extensionality-isomorphism bad-ext))) ⟩
    (∀ x y →
     ∃ λ (Q→Q : Q ∣ x ∣ → Q ∣ y ∣) →
     Erased (Q→Q ≡ subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣)))    ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                              let lemma = inverse $ →-cong ext (P≃Q _) (P≃Q _) in
                                                                              EEq.Σ-cong-≃ᴱ-Erased lemma λ _ →
                                                                              Erased-cong (from-equivalence $ inverse $
                                                                              Eq.≃-≡ $ EEq.≃ᴱ→≃ lemma)) ⟩
    (∀ x y →
     ∃ λ (P→P : P x → P y) →
     Erased (P→P ≡
             _≃ᴱ_.from (P≃Q y) ∘
             subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
             _≃ᴱ_.to (P≃Q x)))                                            ↔⟨ (∃-cong λ _ → Erased-cong (from-equivalence $
                                                                              Eq.extensionality-isomorphism bad-ext F.∘
                                                                              (∀-cong ext λ _ → Eq.extensionality-isomorphism bad-ext))) F.∘
                                                                             (∃-cong λ _ →
                                                                              inverse $
                                                                              (∀-cong ext λ _ → Erased-Π↔Π) F.∘
                                                                              Erased-Π↔Π) F.∘
                                                                             ΠΣ-comm F.∘
                                                                             (∀-cong ext λ _ → ΠΣ-comm) ⟩□
    (∃ λ (P→P : ∀ x y → P x → P y) →
     Erased (P→P ≡
             λ x y →
             _≃ᴱ_.from (P≃Q y) ∘
             subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
             _≃ᴱ_.to (P≃Q x)))                                            □

------------------------------------------------------------------------
-- The lens type family

-- Higher lenses with erased "proofs".

Lens : Type a → Type b → Type (lsuc (a ⊔ b))
Lens A B = ∃ λ (get : A → B) → Coherently-constant (get ⁻¹ᴱ_)

-- In erased contexts Lens A B is equivalent to V.Lens A B.

@0 Lens≃Variant-lens : Lens A B ≃ V.Lens A B
Lens≃Variant-lens {B = B} =
  (∃ λ get → Coherently-constant (get ⁻¹ᴱ_))   ↝⟨ (∃-cong λ _ → Coherently-constant-⁻¹ᴱ≃Variant-coherently-constant-⁻¹) ⟩□
  (∃ λ get → V.Coherently-constant (get ⁻¹_))  □

-- Some derived definitions.

module Lens {A : Type a} {B : Type b} (l : Lens A B) where

  -- A getter.

  get : A → B
  get = proj₁ l

  -- A predicate.

  H : Pow a ∥ B ∥ᴱ
  H = proj₁ (proj₂ l)

  -- An equivalence (with erased proofs).

  get⁻¹ᴱ-≃ᴱ : ∀ b → get ⁻¹ᴱ b ≃ᴱ H ∣ b ∣
  get⁻¹ᴱ-≃ᴱ = proj₁ (proj₂ (proj₂ l))

  -- The predicate H is, in a certain sense, constant.

  H→H : ∀ b₁ b₂ → H b₁ → H b₂
  H→H = proj₁ (proj₂ (proj₂ (proj₂ l)))

  -- In erased contexts H→H can be expressed using
  -- T.truncation-is-proposition.

  @0 H→H≡ : H→H b₁ b₂ ≡ subst H (T.truncation-is-proposition b₁ b₂)
  H→H≡ = erased (proj₂ (proj₂ (proj₂ (proj₂ l)))) _ _

  -- In erased contexts H→H b₁ b₂ is an equivalence.

  @0 H→H-equivalence : ∀ b₁ b₂ → Is-equivalence (H→H b₁ b₂)
  H→H-equivalence b₁ b₂ =                                         $⟨ _≃_.is-equivalence $ Eq.subst-as-equivalence _ _ ⟩
    Is-equivalence (subst H (T.truncation-is-proposition b₁ b₂))  ↝⟨ subst Is-equivalence $ sym H→H≡ ⟩□
    Is-equivalence (H→H b₁ b₂)                                    □

  -- One can convert from any "preimage" (with erased proofs) of the
  -- getter to any other.

  get⁻¹ᴱ-const : (b₁ b₂ : B) → get ⁻¹ᴱ b₁ → get ⁻¹ᴱ b₂
  get⁻¹ᴱ-const b₁ b₂ =
    get ⁻¹ᴱ b₁  ↝⟨ _≃ᴱ_.to $ get⁻¹ᴱ-≃ᴱ b₁ ⟩
    H ∣ b₁ ∣    ↝⟨ H→H ∣ b₁ ∣ ∣ b₂ ∣ ⟩
    H ∣ b₂ ∣    ↝⟨ _≃ᴱ_.from $ get⁻¹ᴱ-≃ᴱ b₂ ⟩□
    get ⁻¹ᴱ b₂  □

  -- The function get⁻¹ᴱ-const b₁ b₂ is an equivalence (in erased
  -- contexts).

  @0 get⁻¹ᴱ-const-equivalence :
    (b₁ b₂ : B) → Is-equivalence (get⁻¹ᴱ-const b₁ b₂)
  get⁻¹ᴱ-const-equivalence b₁ b₂ = _≃_.is-equivalence (
    get ⁻¹ᴱ b₁  ↝⟨ EEq.≃ᴱ→≃ $ get⁻¹ᴱ-≃ᴱ b₁ ⟩
    H ∣ b₁ ∣    ↝⟨ Eq.⟨ _ , H→H-equivalence ∣ b₁ ∣ ∣ b₂ ∣ ⟩ ⟩
    H ∣ b₂ ∣    ↝⟨ EEq.≃ᴱ→≃ $ inverse $ get⁻¹ᴱ-≃ᴱ b₂ ⟩□
    get ⁻¹ᴱ b₂  □)

  -- Some coherence properties.

  @0 H→H-∘ : H→H b₂ b₃ ∘ H→H b₁ b₂ ≡ H→H b₁ b₃
  H→H-∘ {b₂ = b₂} {b₃ = b₃} {b₁ = b₁} =
    H→H b₂ b₃ ∘ H→H b₁ b₂                               ≡⟨ cong₂ (λ f g → f ∘ g) H→H≡ H→H≡ ⟩

    subst H (T.truncation-is-proposition b₂ b₃) ∘
    subst H (T.truncation-is-proposition b₁ b₂)         ≡⟨ (⟨ext⟩ λ _ → subst-subst _ _ _ _) ⟩

    subst H (trans (T.truncation-is-proposition b₁ b₂)
               (T.truncation-is-proposition b₂ b₃))     ≡⟨ cong (subst H) $
                                                           mono₁ 1 T.truncation-is-proposition _ _ ⟩

    subst H (T.truncation-is-proposition b₁ b₃)         ≡⟨ sym H→H≡ ⟩∎

    H→H b₁ b₃                                           ∎

  @0 H→H-id : ∀ {b} → H→H b b ≡ id
  H→H-id {b = b} =
    H→H b b                                    ≡⟨ H→H≡ ⟩
    subst H (T.truncation-is-proposition b b)  ≡⟨ cong (subst H) $
                                                  mono₁ 1 T.truncation-is-proposition _ _ ⟩
    subst H (refl b)                           ≡⟨ (⟨ext⟩ λ _ → subst-refl _ _) ⟩∎
    id                                         ∎

  @0 H→H-inverse : H→H b₁ b₂ ∘ H→H b₂ b₁ ≡ id
  H→H-inverse {b₁ = b₁} {b₂ = b₂} =
    H→H b₁ b₂ ∘ H→H b₂ b₁  ≡⟨ H→H-∘ ⟩
    H→H b₂ b₂              ≡⟨ H→H-id ⟩∎
    id                     ∎

  @0 get⁻¹ᴱ-const-∘ :
    get⁻¹ᴱ-const b₂ b₃ ∘ get⁻¹ᴱ-const b₁ b₂ ≡ get⁻¹ᴱ-const b₁ b₃
  get⁻¹ᴱ-const-∘ {b₂ = b₂} {b₃ = b₃} {b₁ = b₁} = ⟨ext⟩ λ p →
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃)
      (H→H _ _
         (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₂)
            (_≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₂)
               (H→H _ _ (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₁) p)))))             ≡⟨ cong (_≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ _) ∘ H→H _ _) $
                                                                      _≃ᴱ_.right-inverse-of (get⁻¹ᴱ-≃ᴱ _) _ ⟩
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃)
      (H→H _ _ (H→H _ _ (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₁) p)))               ≡⟨ cong (λ f → _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ _) (f (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ _) _)))
                                                                      H→H-∘ ⟩∎
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃) (H→H _ _ (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₁) p))  ∎

  @0 get⁻¹ᴱ-const-id : ∀ {b} → get⁻¹ᴱ-const b b ≡ id
  get⁻¹ᴱ-const-id {b = b} = ⟨ext⟩ λ p →
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b) (H→H _ _ (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b) p))  ≡⟨ cong (_≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b)) $ cong (_$ _) H→H-id  ⟩
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b) (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b) p)            ≡⟨ _≃ᴱ_.left-inverse-of (get⁻¹ᴱ-≃ᴱ b) _ ⟩∎
    p                                                            ∎

  @0 get⁻¹ᴱ-const-inverse :
    get⁻¹ᴱ-const b₁ b₂ ∘ get⁻¹ᴱ-const b₂ b₁ ≡ id
  get⁻¹ᴱ-const-inverse {b₁ = b₁} {b₂ = b₂} =
    get⁻¹ᴱ-const b₁ b₂ ∘ get⁻¹ᴱ-const b₂ b₁  ≡⟨ get⁻¹ᴱ-const-∘ ⟩
    get⁻¹ᴱ-const b₂ b₂                       ≡⟨ get⁻¹ᴱ-const-id ⟩∎
    id                                       ∎

  -- A setter.

  set : A → B → A
  set a b =                      $⟨ get⁻¹ᴱ-const _ _ ⟩
    (get ⁻¹ᴱ get a → get ⁻¹ᴱ b)  ↝⟨ _$ (a , [ refl _ ]) ⟩
    get ⁻¹ᴱ b                    ↝⟨ proj₁ ⟩□
    A                            □

  -- Lens laws.

  @0 get-set : ∀ a b → get (set a b) ≡ b
  get-set a b =
    get (proj₁ (get⁻¹ᴱ-const (get a) b (a , [ refl _ ])))  ≡⟨ erased (proj₂ (get⁻¹ᴱ-const (get a) b (a , [ refl _ ]))) ⟩∎
    b                                                      ∎

  @0 set-get : ∀ a → set a (get a) ≡ a
  set-get a =
    proj₁ (get⁻¹ᴱ-const (get a) (get a) (a , [ refl _ ]))  ≡⟨ cong proj₁ $ cong (_$ a , [ refl _ ]) get⁻¹ᴱ-const-id ⟩∎
    a                                                      ∎

  @0 set-set : ∀ a b₁ b₂ → set (set a b₁) b₂ ≡ set a b₂
  set-set a b₁ b₂ =
    proj₁ (get⁻¹ᴱ-const (get (set a b₁)) b₂ (set a b₁ , [ refl _ ]))  ≡⟨ elim¹
                                                                           (λ {b} eq →
                                                                              proj₁ (get⁻¹ᴱ-const (get (set a b₁)) b₂ (set a b₁ , [ refl _ ])) ≡
                                                                              proj₁ (get⁻¹ᴱ-const b b₂ (set a b₁ , [ eq ])))
                                                                           (refl _)
                                                                           (get-set a b₁) ⟩
    proj₁ (get⁻¹ᴱ-const b₁ b₂ (set a b₁ , [ get-set a b₁ ]))          ≡⟨⟩

    proj₁ (get⁻¹ᴱ-const b₁ b₂
             (get⁻¹ᴱ-const (get a) b₁ (a , [ refl _ ])))              ≡⟨ cong proj₁ $ cong (_$ a , [ refl _ ]) get⁻¹ᴱ-const-∘ ⟩∎

    proj₁ (get⁻¹ᴱ-const (get a) b₂ (a , [ refl _ ]))                  ∎

  -- TODO: Can get-set-get and get-set-set be proved for the lens laws
  -- given above?

instance

  -- The lenses defined above have getters and setters.

  has-getter-and-setter :
    Has-getter-and-setter (Lens {a = a} {b = b})
  has-getter-and-setter = record
    { get = Lens.get
    ; set = Lens.set
    }

------------------------------------------------------------------------
-- Equality characterisation lemmas

-- An equality characterisation lemma.

@0 equality-characterisation₁ :
  {A : Type a} {B : Type b} {l₁ l₂ : Lens A B} →
  Block "equality-characterisation" →
  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     subst (_$ ∣ b ∣) h
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym g) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)
equality-characterisation₁
  {a = a} {b = b} {A = A} {B = B} {l₁ = l₁} {l₂ = l₂} ⊠ =

  l₁ ≡ l₂                                                              ↝⟨ inverse $ Eq.≃-≡ $ Eq.↔⇒≃ (Σ-assoc F.∘ ∃-cong λ _ → Σ-assoc) ⟩

  ((get l₁ , H l₁ , get⁻¹ᴱ-≃ᴱ l₁) , _) ≡
  ((get l₂ , H l₂ , get⁻¹ᴱ-≃ᴱ l₂) , _)                                 ↔⟨ inverse $ ignore-propositional-component $ mono₁ 0
                                                                          Contractible-last-part-of-Coherently-constant ⟩

  (get l₁ , H l₁ , get⁻¹ᴱ-≃ᴱ l₁) ≡ (get l₂ , H l₂ , get⁻¹ᴱ-≃ᴱ l₂)      ↝⟨ inverse $ Eq.≃-≡ $ Eq.↔⇒≃ Σ-assoc ⟩

  ((get l₁ , H l₁) , get⁻¹ᴱ-≃ᴱ l₁) ≡ ((get l₂ , H l₂) , get⁻¹ᴱ-≃ᴱ l₂)  ↔⟨ inverse B.Σ-≡,≡↔≡ ⟩

  (∃ λ (eq : (get l₁ , H l₁) ≡ (get l₂ , H l₂)) →
     subst (λ (g , H) → ∀ b → g ⁻¹ᴱ b ≃ᴱ H ∣ b ∣) eq (get⁻¹ᴱ-≃ᴱ l₁) ≡
     get⁻¹ᴱ-≃ᴱ l₂)                                                     ↝⟨ (Σ-cong-contra ≡×≡↔≡ λ _ → F.id) ⟩

  (∃ λ ((g , h) : get l₁ ≡ get l₂ × H l₁ ≡ H l₂) →
     subst (λ (g , H) → ∀ b → g ⁻¹ᴱ b ≃ᴱ H ∣ b ∣)
       (cong₂ _,_ g h) (get⁻¹ᴱ-≃ᴱ l₁) ≡
     get⁻¹ᴱ-≃ᴱ l₂)                                                     ↔⟨ inverse Σ-assoc ⟩

  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     subst (λ (g , H) → ∀ b → g ⁻¹ᴱ b ≃ᴱ H ∣ b ∣)
       (cong₂ _,_ g h) (get⁻¹ᴱ-≃ᴱ l₁) ≡
     get⁻¹ᴱ-≃ᴱ l₂)                                                     ↝⟨ (∃-cong λ _ → ∃-cong λ _ → inverse $
                                                                           Eq.extensionality-isomorphism ext) ⟩
  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b → subst (λ (g , H) → ∀ b → g ⁻¹ᴱ b ≃ᴱ H ∣ b ∣)
             (cong₂ _,_ g h) (get⁻¹ᴱ-≃ᴱ l₁) b ≡
           get⁻¹ᴱ-≃ᴱ l₂ b)                                             ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → ≡⇒↝ _ $ cong (_≡ _) $ sym $
                                                                           push-subst-application _ _) ⟩
  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b → subst (λ (g , H) → g ⁻¹ᴱ b ≃ᴱ H ∣ b ∣)
             (cong₂ _,_ g h) (get⁻¹ᴱ-≃ᴱ l₁ b) ≡
           get⁻¹ᴱ-≃ᴱ l₂ b)                                             ↔⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → inverse $
                                                                           EEq.to≡to≃≡ ext) ⟩
  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     _≃ᴱ_.to (subst (λ (g , H) → g ⁻¹ᴱ b ≃ᴱ H ∣ b ∣)
               (cong₂ _,_ g h) (get⁻¹ᴱ-≃ᴱ l₁ b)) p ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                       ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                           ≡⇒↝ _ $ cong (_≡ _) $ lemma _ _ _ _) ⟩□
  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     subst (_$ ∣ b ∣) h
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym g) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                       □

  where

  open Lens

  lemma : ∀ _ _ _ _ → _ ≡ _
  lemma g h b p =
    _≃ᴱ_.to (subst (λ (g , H) → g ⁻¹ᴱ b ≃ᴱ H ∣ b ∣)
              (cong₂ _,_ g h) (get⁻¹ᴱ-≃ᴱ l₁ b)) p                ≡⟨ cong (_$ p) EEq.to-subst ⟩

    subst (λ (g , H) → g ⁻¹ᴱ b → H ∣ b ∣)
      (cong₂ _,_ g h) (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b)) p               ≡⟨ subst-→ ⟩

    subst (λ (g , H) → H ∣ b ∣) (cong₂ _,_ g h)
      (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b)
         (subst (λ (g , H) → g ⁻¹ᴱ b) (sym $ cong₂ _,_ g h) p))  ≡⟨ subst-∘ _ _ _ ⟩

    subst (_$ ∣ b ∣) (cong proj₂ $ cong₂ _,_ g h)
      (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b)
         (subst (λ (g , H) → g ⁻¹ᴱ b) (sym $ cong₂ _,_ g h) p))  ≡⟨ cong₂ (λ p q → subst (λ (H : Pow a ∥ _ ∥ᴱ) → H ∣ b ∣)
                                                                                p (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) q))
                                                                      (cong-proj₂-cong₂-, _ _)
                                                                      (subst-∘ _ _ _) ⟩
    subst (_$ ∣ b ∣) h
      (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b)
         (subst (_⁻¹ᴱ b) (cong proj₁ $ sym $ cong₂ _,_ g h) p))  ≡⟨ cong (λ eq → subst (_$ ∣ b ∣) h
                                                                                (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) eq p))) $
                                                                    trans (cong-sym _ _) $
                                                                    cong sym $ cong-proj₁-cong₂-, _ _ ⟩∎
    subst (_$ ∣ b ∣) h
      (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym g) p))      ∎

-- Another equality characterisation lemma.

@0 equality-characterisation₂ :
  {l₁ l₂ : Lens A B} →
  Block "equality-characterisation" →
  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst id (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)
equality-characterisation₂ {l₁ = l₁} {l₂ = l₂} ⊠ =
  l₁ ≡ l₂                                                               ↝⟨ equality-characterisation₁ ⊠ ⟩

  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     subst (_$ ∣ b ∣) h
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym g) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (Σ-cong-contra (Eq.extensionality-isomorphism bad-ext) λ _ →
                                                                            Σ-cong-contra (Eq.extensionality-isomorphism bad-ext) λ _ →
                                                                            F.id) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst (_$ ∣ b ∣) (⟨ext⟩ h)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                            ≡⇒↝ _ $ cong (_≡ _) $
                                                                            subst-ext _ _) ⟩□
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst id (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        □
  where
  open Lens

-- Yet another equality characterisation lemma.

@0 equality-characterisation₃ :
  {A : Type a} {B : Type b}
  {l₁ l₂ : Lens A B} →
  Block "equality-characterisation" →
  Univalence (a ⊔ b) →
  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     ∀ b p →
     _≃_.to (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)
equality-characterisation₃ {l₁ = l₁} {l₂ = l₂} ⊠ univ =
  l₁ ≡ l₂                                                               ↝⟨ equality-characterisation₂ ⊠ ⟩

  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst id (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (∃-cong λ _ →
                                                                            Σ-cong-contra (∀-cong ext λ _ → inverse $ ≡≃≃ univ) λ _ → F.id) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     ∀ b p →
     subst id (≃⇒≡ univ (h ∣ b ∣))
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                            ≡⇒↝ _ $ cong (_≡ _) $
                                                                            trans (subst-id-in-terms-of-≡⇒↝ equivalence) $
                                                                            cong (λ eq → _≃_.to eq _) $
                                                                            _≃_.right-inverse-of (≡≃≃ univ) _) ⟩□
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     ∀ b p →
     _≃_.to (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        □
  where
  open Lens

------------------------------------------------------------------------
-- Conversion functions

-- The lenses defined above can be converted to and from the lenses
-- defined in Higher.

Lens⇔Higher-lens :
  Block "conversion" →
  Lens A B ⇔ Higher.Lens A B
Lens⇔Higher-lens {A = A} {B = B} ⊠ = record
  { to = λ l → let open Lens l in record
      { R = Σ ∥ B ∥ᴱ H

      ; equiv =
          A                                                      ↝⟨ (inverse $ drop-⊤-right λ _ → Erased-other-singleton≃ᴱ⊤) ⟩
          (∃ λ (a : A) → ∃ λ (b : B) → Erased (get a ≡ b))       ↔⟨ ∃-comm ⟩
          (∃ λ (b : B) → get ⁻¹ᴱ b)                              ↝⟨ ∃-cong get⁻¹ᴱ-≃ᴱ ⟩
          (∃ λ (b : B) → H ∣ b ∣)                                ↝⟨ EEq.↔→≃ᴱ
                                                                      (λ (b , h) → (∣ b ∣ , b) , h)
                                                                      (λ ((∥b∥ , b) , h) → b , H→H ∥b∥ ∣ b ∣ h)
                                                                      (λ ((∥b∥ , b) , h) →
                                                                         Σ-≡,≡→≡ (cong (_, _) (T.truncation-is-proposition _ _)) (
              subst (H ∘ proj₁)
                (cong (_, _) (T.truncation-is-proposition _ _))
                (H→H _ _ h)                                                ≡⟨ trans (subst-∘ _ _ _) $
                                                                              trans (cong (flip (subst H) _) $ cong-∘ _ _ _) $
                                                                              cong (flip (subst H) _) $ sym $ cong-id _ ⟩
              subst H (T.truncation-is-proposition _ _)
                (H→H _ _ h)                                                ≡⟨ cong (_$ _) $ sym H→H≡ ⟩

              H→H _ _ (H→H _ _ h)                                          ≡⟨ cong (_$ h) H→H-∘ ⟩

              H→H _ _ h                                                    ≡⟨ cong (_$ h) H→H-id ⟩∎

              h                                                            ∎))
                                                                      (λ (b , h) → cong (_ ,_) (
              H→H _ _ h                                                  ≡⟨ cong (_$ h) H→H-id ⟩∎
              h                                                          ∎)) ⟩

          (∃ λ ((b , _) : ∥ B ∥ᴱ × B) → H b)                     ↔⟨ Σ-assoc F.∘
                                                                    (∃-cong λ _ → ×-comm) F.∘
                                                                    inverse Σ-assoc ⟩□
          Σ ∥ B ∥ᴱ H × B                                         □

      ; inhabited = _≃_.to PT.∥∥ᴱ≃∥∥ ∘ proj₁
      }
  ; from = λ l →
        Higher.Lens.get l
      , (λ _ → Higher.Lens.R l)
      , (λ b → inverse (Higher.remainder≃ᴱget⁻¹ᴱ l b))
      , (λ _ _ → id)
      , [ (λ _ _ → ⟨ext⟩ λ r →
             r                                    ≡⟨ sym $ subst-const _ ⟩∎
             subst (const (Higher.Lens.R l)) _ r  ∎)
        ]
  }

-- The conversion preserves getters and setters.

Lens⇔Higher-lens-preserves-getters-and-setters :
  (bl : Block "conversion") →
  Preserves-getters-and-setters-⇔ A B (Lens⇔Higher-lens bl)
Lens⇔Higher-lens-preserves-getters-and-setters ⊠ =
    (λ _ → refl _ , refl _)
  , (λ _ → refl _ , refl _)

-- Lens A B is equivalent to Higher.Lens A B (with erased proofs,
-- assuming univalence).

Lens≃ᴱHigher-lens :
  {A : Type a} {B : Type b} →
  Block "conversion" →
  @0 Univalence (a ⊔ b) →
  Lens A B ≃ᴱ Higher.Lens A B
Lens≃ᴱHigher-lens {A = A} {B = B} bl univ =
  EEq.↔→≃ᴱ
    (_⇔_.to (Lens⇔Higher-lens bl))
    (_⇔_.from (Lens⇔Higher-lens bl))
    (to∘from bl)
    (from∘to bl)
  where
  @0 to∘from :
    (bl : Block "conversion") →
    ∀ l →
    _⇔_.to (Lens⇔Higher-lens bl) (_⇔_.from (Lens⇔Higher-lens bl) l) ≡ l
  to∘from ⊠ l = _↔_.from (Higher.equality-characterisation₁ univ)
    ( (∥ B ∥ᴱ × R  ↔⟨ (drop-⊤-left-× λ r → _⇔_.to contractible⇔↔⊤ $
                       propositional⇒inhabited⇒contractible
                         T.truncation-is-proposition
                         (_≃_.from PT.∥∥ᴱ≃∥∥ (inhabited r))) ⟩□
       R          □)
    , (λ _ → refl _)
    )
    where
    open Higher.Lens l

  @0 from∘to :
    (bl : Block "conversion") →
    ∀ l →
    _⇔_.from (Lens⇔Higher-lens bl) (_⇔_.to (Lens⇔Higher-lens bl) l) ≡ l
  from∘to bl@⊠ l = _≃_.from (equality-characterisation₃ ⊠ univ)
    ( (λ _ → refl _)
    , Σ∥B∥ᴱH≃H
    , (λ b p@(a , [ get-a≡b ]) →
         _≃_.to (Σ∥B∥ᴱH≃H ∣ b ∣)
           (_≃ᴱ_.from (Higher.remainder≃ᴱget⁻¹ᴱ
                         (_⇔_.to (Lens⇔Higher-lens bl) l) b)
              (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ λ _ → refl _)) p))       ≡⟨ cong (_≃_.to (Σ∥B∥ᴱH≃H ∣ b ∣) ∘
                                                                            _≃ᴱ_.from (Higher.remainder≃ᴱget⁻¹ᴱ
                                                                                (_⇔_.to (Lens⇔Higher-lens bl) l) b)) $
                                                                      trans (cong (flip (subst (_⁻¹ᴱ b)) p) $
                                                                             trans (cong sym ext-refl) $
                                                                             sym-refl) $
                                                                      subst-refl _ _ ⟩
         _≃_.to (Σ∥B∥ᴱH≃H ∣ b ∣)
           (_≃ᴱ_.from (Higher.remainder≃ᴱget⁻¹ᴱ
                         (_⇔_.to (Lens⇔Higher-lens bl) l) b)
              p)                                                   ≡⟨⟩

         _≃_.to (Σ∥B∥ᴱH≃H ∣ b ∣)
           (Higher.Lens.remainder
              (_⇔_.to (Lens⇔Higher-lens bl) l) a)                  ≡⟨⟩

         subst H _ (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))  ≡⟨ cong (λ eq → subst H eq (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))) $
                                                                      mono₁ 1 T.truncation-is-proposition _ _ ⟩
         subst H (cong ∣_∣ get-a≡b)
           (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))          ≡⟨ elim¹
                                                                        (λ {b} eq →
                                                                           subst H (cong ∣_∣ eq)
                                                                             (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ])) ≡
                                                                           _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b) (a , [ eq ]))
                                                                        (
           subst H (cong ∣_∣ (refl _))
             (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))              ≡⟨ trans (cong (flip (subst H) _) $ cong-refl _) $
                                                                            subst-refl _ _ ⟩
           _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ])                  ∎)
                                                                        _ ⟩∎
         _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b) p                                   ∎)
    )
    where
    open Lens l

    Σ∥B∥ᴱH≃H = λ b →
      Σ ∥ B ∥ᴱ H  ↔⟨ (drop-⊤-left-Σ $ _⇔_.to contractible⇔↔⊤ $
                      propositional⇒inhabited⇒contractible
                        T.truncation-is-proposition b) ⟩□
      H b         □

-- The equivalence preserves getters and setters.

Lens≃ᴱHigher-lens-preserves-getters-and-setters :
  {A : Type a} {B : Type b}
  (bl : Block "conversion")
  (@0 univ : Univalence (a ⊔ b)) →
  Preserves-getters-and-setters-⇔ A B
    (_≃ᴱ_.logical-equivalence (Lens≃ᴱHigher-lens bl univ))
Lens≃ᴱHigher-lens-preserves-getters-and-setters bl univ =
  Lens⇔Higher-lens-preserves-getters-and-setters bl


import Issue2217.M

{-# TERMINATING #-}

A : Set
A = ?

a : A
a = ?


{-# OPTIONS --without-K --safe #-}

module Fragment.Tactic.Fragment where

open import Reflection hiding (name; Type; _≟_)
open import Reflection.Term using (_≟_)

open import Level using (_⊔_)
open import Relation.Binary using (Setoid)

open import Data.Bool using (Bool; _∨_; true; false; if_then_else_)
open import Data.Nat using (ℕ)
open import Data.List using (List; []; _∷_; map; sum; length)
open import Data.Vec using (fromList)
open import Data.Product using (_×_; _,_)
open import Data.Unit using (⊤; tt)
open import Data.String using (String; _++_)
open import Data.Maybe using (Maybe; just; nothing)

open import Fragment.Tactic.Utils

open import Fragment.Equational.Theory
open import Fragment.Equational.Model
open import Fragment.Equational.FreeExtension hiding (reduce)
open import Fragment.Algebra.Signature
import Fragment.Algebra.Free as Free

read-goal : List (Arg Term) → TC (Term × List (Arg Term))
read-goal (vArg x ∷ xs) = return (x , xs)
read-goal (_ ∷ xs)      = read-goal xs
read-goal []            = typeError (strErr "failed to read goal" ∷ [])

read-goals : List (Arg Term) → TC (Term × Term)
read-goals xs = do (fst , xs) ← read-goal xs
                   (snd , _) ← read-goal xs
                   return (fst , snd)

extract-goals : Term → TC (Term × Term)
extract-goals (var _ args)  = read-goals args
extract-goals (con _ args)  = read-goals args
extract-goals (def _ args)  = read-goals args
extract-goals (meta _ args) = read-goals args
extract-goals t             =
  typeError (strErr "can't read goals from" ∷ termErr t ∷ [])

record Operator : Set where
  constructor operator
  field
    name       : Name
    normalised : Term
    arity      : ℕ

open Operator

record CoreCtx : Set where
  field
    signature : Term
    theory    : Term
    model     : Term
    carrier   : Term
    frex      : Term

record GlobalCtx : Set where
  field
    core      : CoreCtx
    operators : List Operator

    telescope : List (Arg String)
    lhs       : Term
    rhs       : Term

  open CoreCtx core public

pattern modelType Θ a ℓ = def (quote Model) (vArg Θ ∷ hArg a ∷ hArg ℓ ∷ [])

ctx : Name → Term → Term → TC GlobalCtx
ctx frex model goal
  = do τ ← inferType model
       γ ← inferType goal

       signature ← extract-Σ τ
       theory ← extract-Θ τ
       carrier ← normalise (def (quote ∥_∥) (vra theory ∷ vra model ∷ []))

       let core = record { signature = signature
                         ; theory    = theory
                         ; model     = model
                         ; carrier   = carrier
                         ; frex      = def frex []
                         }

       operators ← extract-ops core

       (inner , telescope) ← strip-telescope γ
       (lhs , rhs) ← extract-goals inner

       return (record { core      = core
                      ; operators = operators
                      ; telescope = telescope
                      ; lhs       = lhs
                      ; rhs       = rhs
                      })

  where modelErr : ∀ {a} {A : Set a} → Term → String → TC A
        modelErr t err =
          typeError ( termErr t
                    ∷ strErr "isn't a"
                    ∷ nameErr (quote Model)
                    ∷ strErr ("(" ++ err ++ ")")
                    ∷ []
                    )

        extract-Σ : Term → TC Term
        extract-Σ (modelType Θ _ _) = normalise (def (quote Theory.Σ) (vra Θ ∷ []))
        extract-Σ t                 = modelErr t "when extracting the signature"

        extract-Θ : Term → TC Term
        extract-Θ (modelType Θ _ _) = normalise Θ
        extract-Θ t                 = modelErr t "when extracting the theory"

        extract-arity : CoreCtx → Name → TC ℕ
        extract-arity ctx op
          = do τ ← inferType (def (quote _⟦_⟧_)
                                  ( vra (CoreCtx.theory ctx)
                                  ∷ vra (CoreCtx.model ctx)
                                  ∷ vra (con op [])
                                  ∷ []
                                  ))
               α ← extract-type-arg τ
               vec-len α

        extract-interp : CoreCtx → Name → ℕ → TC Term
        extract-interp ctx op arity
          = do let t = def (quote _⟦_⟧_)
                           ( vra (CoreCtx.theory ctx)
                           ∷ vra (CoreCtx.model ctx)
                           ∷ vra (con op [])
                           ∷ []
                           )
               normalise (n-ary arity (apply t (vra (vec (debrujin arity)) ∷ [])))

        extract-ops : CoreCtx → TC (List Operator)
        extract-ops ctx
          = do ops ← normalise (def (quote ops) (vra (CoreCtx.signature ctx) ∷ []))
               symbols ← extract-constructors ops
               arities ← listTC (map (extract-arity ctx) symbols)
               interps ← listTC (mapList (map (extract-interp ctx) symbols) arities)
               return (mapList (mapList (map operator symbols) interps) arities)

record FoldCtx {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  constructor foldCtx
  field
    global : GlobalCtx

    f : Term → B → A × B
    g : Operator → List A → A
    ε : B

  open GlobalCtx global public

mutual

  map-fold : ∀ {a b} {A : Set a} {B : Set b}
             → FoldCtx A B → List (Arg Term) → B → TC (List A × B)
  map-fold ctx [] acc = return ([] , acc)
  map-fold ctx (vArg x ∷ xs) acc
    = do (x , acc) ← fold-acc ctx x acc
         (xs , acc) ← map-fold ctx xs acc
         return (x ∷ xs , acc)
  map-fold ctx (_ ∷ xs) acc = map-fold ctx xs acc

  fold-inner : ∀ {a b} {A : Set a} {B : Set b}
                → FoldCtx A B → Operator → Term → B → TC (List A × B)
  fold-inner ctx op (var _ args)     acc = map-fold ctx (ekat (arity op) args) acc
  fold-inner ctx op (con _ args)     acc = map-fold ctx (ekat (arity op) args) acc
  fold-inner ctx op (def _ args)     acc = map-fold ctx (ekat (arity op) args) acc
  fold-inner ctx op (meta _ args)    acc = map-fold ctx (ekat (arity op) args) acc
  fold-inner ctx op (pat-lam _ args) acc = map-fold ctx (ekat (arity op) args) acc
  fold-inner _ _ t _ = typeError (termErr t ∷ strErr "has no arguments" ∷ [])

  fold-acc : ∀ {a b} {A : Set a} {B : Set b} → FoldCtx A B → Term → B → TC (A × B)
  fold-acc ctx t acc
    = do op? ← find (λ x → prefix (arity x) (normalised x) t) (FoldCtx.operators ctx)
         resolve op?
    where resolve : Maybe Operator → TC _
          resolve (just op)
            = do (args , acc) ← fold-inner ctx op t acc
                 return ((FoldCtx.g ctx) op args , acc)
          resolve nothing = return ((FoldCtx.f ctx) t acc)

fold : ∀ {a b} {A : Set a} {B : Set b} → FoldCtx A B → Term → TC (A × B)
fold ctx t = fold-acc ctx t (FoldCtx.ε ctx)

fold-⊤ : ∀ {a} {A : Set a} → GlobalCtx
         → (Term → A) → (Operator → List A → A) → Term → TC A
fold-⊤ ctx f g t
  = do (x , _) ← fold (foldCtx ctx (λ x _ → (f x , tt)) g tt) t
       return x

accumulate : ∀ {a} {A : Set a} → GlobalCtx
             → (Term → A → A) → A → Term → TC A
accumulate ctx f ε t
  = do (_ , acc) ← fold (foldCtx ctx (λ x acc → (tt , f x acc)) (λ _ _ → tt) ε) t
       return acc

leaves : GlobalCtx → Term → TC ℕ
leaves ctx = fold-⊤ ctx (λ _ → 1) (λ _ → sum)

mutual
  argsOpen : Term → List (Arg Term) → TC Bool
  argsOpen τ [] = return false
  argsOpen τ (vArg x ∷ xs)
    = do head ← isOpen τ x
         tail ← argsOpen τ xs
         return (head ∨ tail)
  argsOpen τ (_ ∷ xs) = argsOpen τ xs

  isOpen : Term → Term → TC Bool
  isOpen τ t@(var _ _)  = hasType τ t
  isOpen τ t@(meta _ _) = hasType τ t
  isOpen τ (con c args) = argsOpen τ args
  isOpen τ (def f args) = argsOpen τ args
  isOpen τ unknown      = return true
  isOpen τ _            = return false

findOpen : GlobalCtx → List Term → Term → TC (List Term)
findOpen ctx ε t = flatten (accumulate ctx binding (return ε) t)
  where binding : Term → TC (List Term) → TC (List Term)
        binding t env
          = do env ← env
               let τ = CoreCtx.carrier (GlobalCtx.core ctx)
               open? ← isOpen τ t
               if open? then return (insert env t)
                        else return env

buildSyntax : GlobalCtx → List Term → Term → TC Term
buildSyntax ctx env t = fold-⊤ ctx buildInj buildTerm t
  where bt : Term
        bt = def (quote Free.BT)
                 ( vra (GlobalCtx.signature ctx)
                 ∷ vra (GlobalCtx.carrier ctx)
                 ∷ vra (lit (nat (length env)))
                 ∷ []
                 )

        buildAtom : Term → Term
        buildAtom t =
          con (quote Free.Term.atom)
              ( hra (GlobalCtx.signature ctx)
              ∷ hra unknown
              ∷ hra bt
              ∷ vra t
              ∷ []
              )

        buildDyn : ℕ → Term
        buildDyn n =
          con (quote Free.BT.dyn)
              ( hra (GlobalCtx.signature ctx)
              ∷ hra unknown
              ∷ hra (GlobalCtx.carrier ctx)
              ∷ hra (lit (nat (length env)))
              ∷ vra (fin n)
              ∷ []
              )

        buildSta : Term → Term
        buildSta t =
          con (quote Free.BT.sta)
              ( hra (GlobalCtx.signature ctx)
              ∷ hra unknown
              ∷ hra (GlobalCtx.carrier ctx)
              ∷ hra (lit (nat (length env)))
              ∷ vra t
              ∷ []
              )

        buildInj : Term → Term
        buildInj t with indexOf env t
        ...           | just n  = buildAtom (buildDyn n)
        ...           | nothing = buildAtom (buildSta t)

        buildTerm : Operator → List Term → Term
        buildTerm op xs =
          con (quote Free.Term.term)
               ( hra (GlobalCtx.signature ctx)
               ∷ hra unknown
               ∷ hra bt
               ∷ hra (lit (nat (arity op)))
               ∷ vra (con (name op) [])
               ∷ vra (vec (fromList xs))
               ∷ []
               )

environment : List Term → Term
environment env = vec (fromList env)

macro
  fragment : Name → Term → Term → TC ⊤
  fragment frex model goal
    = do ctx ← ctx frex model goal
         env ← findOpen ctx [] (GlobalCtx.lhs ctx)
         env ← findOpen ctx env (GlobalCtx.rhs ctx)
         lhs ← buildSyntax ctx env (GlobalCtx.lhs ctx)
         rhs ← buildSyntax ctx env (GlobalCtx.rhs ctx)
         let n = length env
         let frex = def (quote FreeExtension._[_])
                        ( hra (GlobalCtx.theory ctx)
                        ∷ vra (GlobalCtx.frex ctx)
                        ∷ vra (GlobalCtx.model ctx)
                        ∷ vra (lit (nat n))
                        ∷ []
                        )
         let setoid = def (quote ∥_∥/≈)
                          ( hra (GlobalCtx.theory ctx)
                          ∷ vra frex
                          ∷ []
                          )
         let p = def (quote Setoid.refl) (vra setoid ∷ [])
         let frexify = def (quote frexify)
                           ( vra (GlobalCtx.theory ctx)
                           ∷ vra (GlobalCtx.frex ctx)
                           ∷ vra (GlobalCtx.model ctx)
                           ∷ vra (vec (fromList env))
                           ∷ hra lhs
                           ∷ hra rhs
                           ∷ vra p
                           ∷ []
                           )
         frexify ← restore-telescope (GlobalCtx.telescope ctx) frexify
         unify frexify goal


module _ where

module M where

  F : Set → Set
  F A = A

open M

infix 0 F
syntax F A = [ A ]

G : Set → Set
G A = [ A ]


-- Andreas, 2017-05-13, issue reported by nad

module Issue2579 where

open import Common.Bool

open import Issue2579.Import
import Issue2579.Instance Bool true as I
-- without the "as I" the instance is not in scope
-- (and you get a parse error)

theWrapped : {{w : Wrap Bool}} → Bool
theWrapped {{w}} = Wrap.wrapped w

test : Bool
test = theWrapped


module left-kan-extensions where

open import functor

-- The left-kan extension of G along J.
record left-kan (G : Set → Set) (J : Set → Set) (pG : Functor G) (pJ : Functor J) : Set₁ where
  field
    lan : Set → Set
    pLan : Functor lan