├── .gitignore ├── src ├── agda-system-io.agda-lib ├── Data │ ├── Strict │ │ ├── AgdaFFI.hs │ │ └── Primitive.agda │ ├── Char │ │ ├── Classifier.agda │ │ └── Classifier │ │ │ └── Primitive.agda │ ├── Word.agda │ ├── Natural.agda │ ├── Strict.agda │ ├── Word │ │ └── Primitive.agda │ ├── Natural │ │ ├── Primitive.agda │ │ └── AgdaFFI.hs │ ├── ByteString │ │ ├── UTF8.agda │ │ ├── UTF8 │ │ │ └── Primitive.agda │ │ └── Primitive.agda │ └── ByteString.agda └── System │ ├── IO │ ├── Examples │ │ ├── Four.agda │ │ ├── HelloRaw.agda │ │ ├── HelloWorld.agda │ │ ├── DevNull.agda │ │ ├── HelloFour.agda │ │ ├── HelloUser.agda │ │ ├── WC.agda │ │ └── Transducers.agda │ ├── Transducers │ │ ├── Properties.agda │ │ ├── Weight.agda │ │ ├── IO.agda │ │ ├── List.agda │ │ ├── Trace.agda │ │ ├── Bytes.agda │ │ ├── Function.agda │ │ ├── UTF8.agda │ │ ├── Strict.agda │ │ ├── Properties │ │ │ ├── LaxProduct.agda │ │ │ ├── TwoCategory.agda │ │ │ ├── Equivalences.agda │ │ │ ├── Lemmas.agda │ │ │ ├── Category.agda │ │ │ ├── LaxBraided.agda │ │ │ └── Monoidal.agda │ │ ├── Session.agda │ │ ├── Stateful.agda │ │ └── Lazy.agda │ ├── Transducers.agda │ ├── Primitive.agda │ └── AgdaFFI.hs │ └── IO.agda ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.agdai 3 | *.hi 4 | *.o 5 | src/MAlonzo/* 6 | -------------------------------------------------------------------------------- /src/agda-system-io.agda-lib: -------------------------------------------------------------------------------- 1 | name: agda-system-io 2 | include: src -------------------------------------------------------------------------------- /src/Data/Strict/AgdaFFI.hs: -------------------------------------------------------------------------------- 1 | module Data.Strict.AgdaFFI where 2 | 3 | data Strict a = Strict !a 4 | -------------------------------------------------------------------------------- /src/Data/Char/Classifier.agda: -------------------------------------------------------------------------------- 1 | module Data.Char.Classifier where 2 | 3 | open import Data.Char.Classifier.Primitive public 4 | -------------------------------------------------------------------------------- /src/System/IO/Examples/Four.agda: -------------------------------------------------------------------------------- 1 | open import Data.Natural using ( Natural ; # ; _+_ ) 2 | 3 | module System.IO.Examples.Four where 4 | 5 | four : Natural 6 | four = # 2 + # 2 -------------------------------------------------------------------------------- /src/System/IO/Examples/HelloRaw.agda: -------------------------------------------------------------------------------- 1 | open import IO using ( _>>_ ; putStr ; run ) 2 | 3 | module System.IO.Examples.HelloRaw where 4 | 5 | main = run (putStr "Hello, World\n") 6 | -------------------------------------------------------------------------------- /src/System/IO/Examples/HelloWorld.agda: -------------------------------------------------------------------------------- 1 | open import System.IO using ( _>>_ ; putStr ; commit ) 2 | 3 | module System.IO.Examples.HelloWorld where 4 | 5 | main = putStr "Hello, World\n" >> commit 6 | -------------------------------------------------------------------------------- /src/Data/Strict/Primitive.agda: -------------------------------------------------------------------------------- 1 | module Data.Strict.Primitive where 2 | 3 | data Strict (A : Set) : Set where 4 | ! : A → Strict A 5 | 6 | {-# IMPORT Data.Strict.AgdaFFI #-} 7 | {-# COMPILED_DATA Strict Data.Strict.AgdaFFI.Strict Data.Strict.AgdaFFI.Strict #-} 8 | -------------------------------------------------------------------------------- /src/System/IO/Examples/DevNull.agda: -------------------------------------------------------------------------------- 1 | open import Data.ByteString.Static using ( lazy ; strict ) 2 | open import System.IO using ( _>>_ ; _>>=_ ; getBytes ; putStr ; commit ) 3 | 4 | module System.IO.Examples.DevNull where 5 | 6 | main = 7 | getBytes {lazy} >>= λ bs → 8 | putStr "Done.\n" >> 9 | commit 10 | -------------------------------------------------------------------------------- /src/System/IO/Examples/HelloFour.agda: -------------------------------------------------------------------------------- 1 | open import System.IO using ( _>>_ ; putStr ; commit ) 2 | open import Data.Natural using ( show ) 3 | open import System.IO.Examples.Four using ( four ) 4 | 5 | module System.IO.Examples.HelloFour where 6 | 7 | main = putStr "Hello, " >> putStr (show four) >> putStr ".\n" >> commit 8 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties.agda: -------------------------------------------------------------------------------- 1 | module System.IO.Transducers.Properties where 2 | 3 | open import System.IO.Transducers.Properties.Category public 4 | open import System.IO.Transducers.Properties.Monoidal public 5 | open import System.IO.Transducers.Properties.LaxBraided public 6 | open import System.IO.Transducers.Properties.Equivalences public 7 | -------------------------------------------------------------------------------- /src/Data/Word.agda: -------------------------------------------------------------------------------- 1 | open import Data.Word.Primitive public using ( Word8 ; Word16 ; Word32 ; Word64 ) 2 | 3 | module Data.Word where 4 | 5 | data WordSize : Set where 6 | #8 #16 #32 #64 : WordSize 7 | 8 | Word : WordSize → Set 9 | Word #8 = Word8 10 | Word #16 = Word16 11 | Word #32 = Word32 12 | Word #64 = Word64 13 | 14 | Byte : Set 15 | Byte = Word8 16 | -------------------------------------------------------------------------------- /src/System/IO/Examples/HelloUser.agda: -------------------------------------------------------------------------------- 1 | open import Data.String using ( _++_ ) 2 | open import System.IO using ( _>>_ ; _>>=_ ; getStr ; putStr ; commit ) 3 | 4 | module System.IO.Examples.HelloUser where 5 | 6 | main = 7 | putStr "What is your name?\n" >> 8 | commit >> 9 | getStr >>= λ name → 10 | putStr ("Hello, " ++ name ++ "\n") >> 11 | commit 12 | -------------------------------------------------------------------------------- /src/Data/Natural.agda: -------------------------------------------------------------------------------- 1 | -- A binding to a Haskell natural numbers type 2 | 3 | open import Data.Nat using ( ℕ ) renaming ( zero to zero' ; suc to suc' ) 4 | 5 | module Data.Natural where 6 | 7 | open import Data.Natural.Primitive public 8 | using ( Natural ; zero ; suc ; _+_ ; show ; foldl ; foldl' ; foldr ) 9 | renaming ( fromℕ to # ) 10 | 11 | % : Natural → ℕ 12 | % = foldr suc' zero' 13 | -------------------------------------------------------------------------------- /src/Data/Strict.agda: -------------------------------------------------------------------------------- 1 | -- Strict A is a datatype isomorphic to A, with constructor ! : A → Strict A 2 | -- Semantically it has no impact, but its constructor is strict, so it can be 3 | -- used to force evaluation of a term to whnf by pattern-matching. 4 | 5 | open import Data.Strict.Primitive using () 6 | 7 | module Data.Strict where 8 | 9 | open Data.Strict.Primitive public using ( Strict ; ! ) 10 | 11 | -------------------------------------------------------------------------------- /src/Data/Word/Primitive.agda: -------------------------------------------------------------------------------- 1 | module Data.Word.Primitive where 2 | 3 | postulate 4 | Word : Set 5 | Word8 : Set 6 | Word16 : Set 7 | Word32 : Set 8 | Word64 : Set 9 | 10 | {-# FOREIGN GHC import qualified Data.Word #-} 11 | {-# COMPILE GHC Word = type Data.Word.Word #-} 12 | {-# COMPILE GHC Word8 = type Data.Word.Word8 #-} 13 | {-# COMPILE GHC Word16 = type Data.Word.Word16 #-} 14 | {-# COMPILE GHC Word32 = type Data.Word.Word32 #-} 15 | {-# COMPILE GHC Word64 = type Data.Word.Word64 #-} 16 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Weight.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♯_ ) 2 | open import Data.Natural using ( Natural ; # ; _+_ ) 3 | open import Data.Strict using ( Strict ; ! ) 4 | open import System.IO.Transducers.Session using ( I ; Σ ; ⟨_⟩ ) 5 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ) 6 | 7 | module System.IO.Transducers.Weight where 8 | 9 | -- Weight of a trace 10 | 11 | weight' : ∀ {S} → (Strict Natural) → S ⇒ ⟨ Natural ⟩ 12 | weight' {I} (! n) = out n done 13 | weight' {Σ W F} (! n) = inp (♯ λ a → weight' (! (n + W a))) 14 | 15 | weight : ∀ {S} → S ⇒ ⟨ Natural ⟩ 16 | weight = weight' (! (# 0)) -------------------------------------------------------------------------------- /src/System/IO/Transducers.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♭ ) 2 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ) 3 | open import System.IO.Transducers.Lazy using () 4 | renaming ( done to doneL ; _⟫_ to _⟫L_ ) 5 | open import System.IO.Transducers.Strict using () 6 | renaming ( done to doneS ; _⟫_ to _⟫S_ ) 7 | open import System.IO.Transducers.Session using ( Session ; I ; Σ ) 8 | open import System.IO.Transducers.Trace using ( Trace ) 9 | 10 | module System.IO.Transducers where 11 | 12 | open System.IO.Transducers.Lazy public 13 | using ( _⇒_ ; inp ; out ; id ; ⟦_⟧ ; _≃_ ) 14 | 15 | open System.IO.Transducers.Strict public 16 | using ( _⇛_ ) 17 | 18 | data Style : Set where 19 | lazy strict : Style 20 | 21 | _⇒_is_ : Session → Session → Style → Set 22 | S ⇒ T is lazy = S ⇒ T 23 | S ⇒ T is strict = S ⇛ T 24 | 25 | done : ∀ {s S} → (S ⇒ S is s) 26 | done {lazy} = doneL 27 | done {strict} = doneS 28 | 29 | _⟫_ : ∀ {s S T U} → (S ⇒ T is s) → (T ⇒ U is s) → (S ⇒ U is s) 30 | _⟫_ {lazy} = _⟫L_ 31 | _⟫_ {strict} = _⟫S_ 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010 Alcatel-Lucent. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /src/Data/Char/Classifier/Primitive.agda: -------------------------------------------------------------------------------- 1 | open import Data.Char using ( Char ) 2 | open import Data.Bool using ( Bool ) 3 | 4 | module Data.Char.Classifier.Primitive where 5 | 6 | postulate 7 | isAscii : Char → Bool 8 | isLatin1 : Char → Bool 9 | isControl : Char → Bool 10 | isSpace : Char → Bool 11 | isLower : Char → Bool 12 | isUpper : Char → Bool 13 | isAlpha : Char → Bool 14 | isAlphaNum : Char → Bool 15 | isPrint : Char → Bool 16 | isDigit : Char → Bool 17 | isOctDigit : Char → Bool 18 | isHexDigit : Char → Bool 19 | 20 | {-# FOREIGN GHC import qualified Data.Char #-} 21 | {-# COMPILE GHC isAscii = type Data.Char.isAscii #-} 22 | {-# COMPILE GHC isLatin1 = type Data.Char.isLatin1 #-} 23 | {-# COMPILE GHC isControl = type Data.Char.isControl #-} 24 | {-# COMPILE GHC isSpace = type Data.Char.isSpace #-} 25 | {-# COMPILE GHC isLower = type Data.Char.isLower #-} 26 | {-# COMPILE GHC isUpper = type Data.Char.isUpper #-} 27 | {-# COMPILE GHC isAlpha = type Data.Char.isAlpha #-} 28 | {-# COMPILE GHC isAlphaNum = type Data.Char.isAlphaNum #-} 29 | {-# COMPILE GHC isPrint = type Data.Char.isPrint #-} 30 | {-# COMPILE GHC isDigit = type Data.Char.isDigit #-} 31 | {-# COMPILE GHC isOctDigit = type Data.Char.isOctDigit #-} 32 | {-# COMPILE GHC isHexDigit = type Data.Char.isHexDigit #-} 33 | -------------------------------------------------------------------------------- /src/Data/Natural/Primitive.agda: -------------------------------------------------------------------------------- 1 | open import Data.Nat using ( ℕ ) renaming ( zero to zero' ; suc to suc' ) 2 | open import Data.Nat.GeneralisedArithmetic using ( fold ) 3 | open import Data.String using ( String ) 4 | 5 | module Data.Natural.Primitive where 6 | 7 | infixl 6 _+_ 8 | 9 | postulate 10 | Natural : Set 11 | zero : Natural 12 | suc : Natural → Natural 13 | _+_ : Natural → Natural → Natural 14 | show : Natural → String 15 | foldl : {A : Set} → (A → A) → A → Natural → A 16 | foldl' : {A : Set} → (A → A) → A → Natural → A 17 | foldr : {A : Set} → (A → A) → A → Natural → A 18 | 19 | {-# FOREIGN GHC import qualified Data.Natural.AgdaFFI #-} 20 | {-# COMPILE GHC Natural = type Data.Natural.AgdaFFI.Natural #-} 21 | {-# COMPILE GHC zero = 0 #-} 22 | {-# COMPILE GHC suc = succ #-} 23 | {-# COMPILE GHC _+_ = (+) #-} 24 | {-# COMPILE GHC show = show #-} 25 | {-# COMPILE GHC foldl = (\ _ -> Data.Natural.AgdaFFI.nfoldl) #-} 26 | {-# COMPILE GHC foldl' = (\ _ -> Data.Natural.AgdaFFI.nfoldl') #-} 27 | {-# COMPILE GHC foldr = (\ _ -> Data.Natural.AgdaFFI.nfoldr) #-} 28 | 29 | private 30 | postulate 31 | # : ∀ {i} {A : Set i} → A → Natural 32 | {-# COMPILE GHC # = (\ _ _ -> Data.Natural.AgdaFFI.convert MAlonzo.Data.Nat.mazNatToInteger) #-} 33 | 34 | fromℕ : ℕ → Natural 35 | fromℕ = # 36 | -------------------------------------------------------------------------------- /src/System/IO/Examples/WC.agda: -------------------------------------------------------------------------------- 1 | -- A simple word counter 2 | 3 | open import Coinduction using ( ♯_ ) 4 | open import Data.Char.Classifier using ( isSpace ) 5 | open import Data.Bool using ( Bool ; true ; false ) 6 | open import Data.Natural using ( Natural ; show ) 7 | open import System.IO using ( Command ) 8 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; _⟫_ ; _⟨&⟩_ ) 9 | open import System.IO.Transducers.List using ( length ) 10 | open import System.IO.Transducers.Bytes using ( bytes ) 11 | open import System.IO.Transducers.IO using ( run ) 12 | open import System.IO.Transducers.UTF8 using ( split ; encode ) 13 | open import System.IO.Transducers.Session using ( ⟨_⟩ ; _&_ ; Bytes ; Strings ) 14 | 15 | module System.IO.Examples.WC where 16 | 17 | words : Bytes ⇒ ⟨ Natural ⟩ 18 | words = split isSpace ⟫ inp (♯ length { Bytes }) 19 | 20 | -- TODO: this isn't exactly lovely user syntax. 21 | 22 | report : ⟨ Natural ⟩ & ⟨ Natural ⟩ ⇒ Strings 23 | report = 24 | (inp (♯ λ #bytes → 25 | (out true 26 | (out (show #bytes) 27 | (out true 28 | (out " " 29 | (inp (♯ λ #words → 30 | (out true 31 | (out (show #words) 32 | (out true 33 | (out "\n" 34 | (out false done))))))))))))) 35 | 36 | wc : Bytes ⇒ Bytes 37 | wc = bytes ⟨&⟩ words ⟫ report ⟫ inp (♯ encode) 38 | 39 | main : Command 40 | main = run wc 41 | -------------------------------------------------------------------------------- /src/System/IO/Examples/Transducers.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♯_ ) 2 | open import Data.Maybe using ( Maybe ; just ; nothing ; maybe ) 3 | open import Data.Nat using ( ℕ ; _+_ ) 4 | open import Data.Integer using ( ℤ ; +_ ; _⊖_ ) 5 | open import System.IO.Transducers using ( inp ; out ; done ; _⇒_ ; Inp_⇒_ ; C⟦_⟧ ; _⟨¿⟩_ ) 6 | open import System.IO.Transducers.Trace using ( [] ; _∷_ ) 7 | open import System.IO.Transducers.Session using ( ⟨_⟩ ; _&_ ; ¡ ; ¿ ) 8 | open import System.IO.Transducers.Stateful using ( loop ) 9 | 10 | module System.IO.Examples.Transducers where 11 | 12 | add : ⟨ ℕ ⟩ & ⟨ ℕ ⟩ ⇒ ⟨ ℕ ⟩ 13 | add = inp (♯ λ x → inp (♯ λ y → out (x + y) done)) 14 | 15 | -- runAdd == 8 ∷ [] 16 | runAdd = C⟦ add ⟧ ( 3 ∷ 5 ∷ [] ) 17 | 18 | nat? : ¡ ⟨ ℤ ⟩ ⇒ ¿ ⟨ ℕ ⟩ & ¡ ⟨ ℤ ⟩ 19 | nat? = inp (♯ rest) where 20 | rest : Inp ¡ ⟨ ℤ ⟩ ⇒ ¿ ⟨ ℕ ⟩ & ¡ ⟨ ℤ ⟩ 21 | rest nothing = out nothing (out nothing done) 22 | rest (just (+ n)) = out (just n) done 23 | rest (just x) = out nothing (out (just x) done) 24 | 25 | -- runNat? == ( just 5 ∷ just (+ 7) ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ []) 26 | runNat? = C⟦ nat? ⟧ ( just (+ 5) ∷ just (+ 7) ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ []) 27 | 28 | nat! : ¡ ⟨ ℤ ⟩ ⇒ ¡ ⟨ ℕ ⟩ & ¡ ⟨ ℤ ⟩ 29 | nat! = loop {⟨ ℕ ⟩} nat? 30 | 31 | -- runNat! == ( just 5 ∷ just 7 ∷ nothing ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ []) 32 | runNat! = C⟦ nat! ⟧ ( just (+ 5) ∷ just (+ 7) ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ []) 33 | -------------------------------------------------------------------------------- /src/Data/ByteString/UTF8.agda: -------------------------------------------------------------------------------- 1 | open import Data.ByteString using ( ByteString ; Style ; strict ; lazy ) 2 | open import Data.ByteString.Primitive using ( strict₁ ; strict₂ ; lazy₁ ; lazy₂ ) 3 | open import Data.Bool using ( Bool ) 4 | open import Data.Char using ( Char ) 5 | open import Data.Nat using ( ℕ ) 6 | open import Data.Natural using ( Natural ; % ) 7 | open import Data.Product using ( _×_ ; _,_ ) 8 | open import Data.String using ( String ) 9 | 10 | open import Data.ByteString.UTF8.Primitive 11 | 12 | module Data.ByteString.UTF8 where 13 | 14 | toString : {s : Style} → (ByteString s) → String 15 | toString {lazy} = toStringLazy 16 | toString {strict} = toStringStrict 17 | 18 | fromString : {s : Style} → String → (ByteString s) 19 | fromString {lazy} = fromStringLazy 20 | fromString {strict} = fromStringStrict 21 | 22 | length : {s : Style} → (ByteString s) → Natural 23 | length {lazy} = lengthLazy 24 | length {strict} = lengthStrict 25 | 26 | size : {s : Style} → (ByteString s) → ℕ 27 | size bs = % (length bs) 28 | 29 | span : {s : Style} → (Char → Bool) → (ByteString s) → (ByteString s × ByteString s) 30 | span {lazy} φ bs with spanLazy φ bs 31 | span {lazy} φ bs | bs² = (lazy₁ bs² , lazy₂ bs²) 32 | span {strict} φ bs with spanStrict φ bs 33 | span {strict} φ bs | bs² = (strict₁ bs² , strict₂ bs²) 34 | 35 | break : {s : Style} → (Char → Bool) → (ByteString s) → (ByteString s × ByteString s) 36 | break {lazy} φ bs with breakLazy φ bs 37 | break {lazy} φ bs | bs² = (lazy₁ bs² , lazy₂ bs²) 38 | break {strict} φ bs with breakStrict φ bs 39 | break {strict} φ bs | bs² = (strict₁ bs² , strict₂ bs²) 40 | 41 | -------------------------------------------------------------------------------- /src/Data/ByteString/UTF8/Primitive.agda: -------------------------------------------------------------------------------- 1 | open import Data.ByteString.Primitive using ( ByteStringStrict ; ByteStringStrict² ; ByteStringLazy ; ByteStringLazy² ) 2 | open import Data.Bool using ( Bool ) 3 | open import Data.Char using ( Char ) 4 | open import Data.Natural using ( Natural ) 5 | open import Data.String using ( String ) 6 | 7 | module Data.ByteString.UTF8.Primitive where 8 | 9 | postulate 10 | fromStringStrict : String → ByteStringStrict 11 | toStringStrict : ByteStringStrict → String 12 | lengthStrict : ByteStringStrict → Natural 13 | spanStrict : (Char → Bool) → ByteStringStrict → ByteStringStrict² 14 | breakStrict : (Char → Bool) → ByteStringStrict → ByteStringStrict² 15 | 16 | {-# IMPORT Data.ByteString.UTF8 #-} 17 | {-# COMPILED fromStringStrict Data.ByteString.UTF8.fromString #-} 18 | {-# COMPILED toStringStrict Data.ByteString.UTF8.toString #-} 19 | {-# COMPILED lengthStrict fromIntegral . Data.ByteString.UTF8.length #-} 20 | {-# COMPILED spanStrict Data.ByteString.UTF8.span #-} 21 | {-# COMPILED breakStrict Data.ByteString.UTF8.break #-} 22 | 23 | postulate 24 | fromStringLazy : String → ByteStringLazy 25 | toStringLazy : ByteStringLazy → String 26 | lengthLazy : ByteStringLazy → Natural 27 | spanLazy : (Char → Bool) → ByteStringLazy → ByteStringLazy² 28 | breakLazy : (Char → Bool) → ByteStringLazy → ByteStringLazy² 29 | 30 | {-# IMPORT Data.ByteString.Lazy.UTF8 #-} 31 | {-# COMPILED fromStringLazy Data.ByteString.Lazy.UTF8.fromString #-} 32 | {-# COMPILED toStringLazy Data.ByteString.Lazy.UTF8.toString #-} 33 | {-# COMPILED lengthLazy fromIntegral . Data.ByteString.Lazy.UTF8.length #-} 34 | {-# COMPILED spanLazy Data.ByteString.Lazy.UTF8.span #-} 35 | {-# COMPILED breakLazy Data.ByteString.Lazy.UTF8.break #-} 36 | 37 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/IO.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-termination-check #-} 2 | -- TODO: switch the termination checker back on. 3 | 4 | open import Coinduction using ( ∞ ; ♭ ; ♯_ ) 5 | open import Data.Bool using ( Bool ; true ; false ) 6 | open import Data.Maybe using ( Maybe ; just ; nothing ) 7 | open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ ) 8 | open import Data.Product using ( ∃ ; _,_ ) 9 | open import Data.ByteString using ( ByteString ; strict ; null ) 10 | open import System.IO using ( IO ; Command ; return ; _>>_ ; _>>=_ ; skip ; getBytes ; putBytes ; commit ) 11 | open import System.IO.Transducers.Lazy using ( _⇒_ ; _⤇_ ; inp ; out ; done ; ι⁻¹ ) 12 | open import System.IO.Transducers.Session using ( I ; Σ ; Bytes ) 13 | open import System.IO.Transducers.Strict using ( _⇛_ ) 14 | 15 | module System.IO.Transducers.IO where 16 | 17 | infixl 5 _$_ 18 | 19 | postulate 20 | IOError : Set 21 | _catch_ : ∀ {A} → (IO A) → (IOError → (IO A)) → (IO A) 22 | {-# COMPILED_TYPE IOError IOError #-} 23 | {-# COMPILED _catch_ (\ _ -> catch) #-} 24 | 25 | _$_ : ∀ {A V F T} → (Σ {A} V F ⤇ T) → (a : A) → (♭ F a ⤇ T) 26 | inp P $ a = ♭ P a 27 | out b P $ a = out b (P $ a) 28 | 29 | getBytes? : IO (Maybe (ByteString strict)) 30 | getBytes? = (getBytes >>= λ x → return (just x)) catch (λ e → return nothing) 31 | 32 | runI : (I ⤇ Bytes) → Command 33 | runI (out true (out x P)) = putBytes x >> commit >> runI P 34 | runI (out false P) = skip 35 | 36 | mutual 37 | 38 | run? : (Bytes ⤇ Bytes) → (Maybe (ByteString strict)) → Command 39 | run? P (just b) = run' (P $ true $ b) 40 | run? P nothing = runI (P $ false) 41 | 42 | run' : (Bytes ⤇ Bytes) → Command 43 | run' (out true (out b P)) = putBytes b >> commit >> run' P 44 | run' (out false P) = skip 45 | run' P = getBytes? >>= run? P 46 | 47 | run : (Bytes ⇒ Bytes) → Command 48 | run P = run' (ι⁻¹ P) 49 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/List.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♯_ ; ♭ ) 2 | open import Data.Strict using ( Strict ; ! ) 3 | open import Data.Natural using ( Natural ; # ; _+_ ) 4 | open import Data.Bool using ( Bool ; true ; false ) 5 | open import System.IO.Transducers.Session using ( I ; Σ ; ⟨_⟩ ; * ; _&*_ ; ¿ ) 6 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ) 7 | open import System.IO.Transducers.Strict using ( _⇛_ ) 8 | 9 | module System.IO.Transducers.List where 10 | 11 | -- Length of a list 12 | 13 | length' : ∀ {T S} → (Strict Natural) → (T &* S) ⇛ ⟨ Natural ⟩ 14 | length' {I} {S} (! n) true = inp (♯ length' {S} {S} (! (n + # 1))) 15 | length' {I} {S} (! n) false = out n done 16 | length' {Σ V G} {S} (! n) b = inp (♯ length' {♭ G b} {S} (! n)) 17 | 18 | length : ∀ {S} → (* S) ⇛ ⟨ Natural ⟩ 19 | length {S} = length' {I} {S} (! (# 0)) 20 | 21 | -- Flatten a list of lists 22 | 23 | mutual 24 | 25 | concat' : ∀ {T S} → ((T &* S) &* * S) ⇛ (T &* S) 26 | concat' {I} {S} true = out true (inp (♯ concat' {S} {S})) 27 | concat' {I} {S} false = inp (♯ concat {S}) 28 | concat' {Σ W G} {S} a = out a (inp (♯ concat' {♭ G a} {S})) 29 | 30 | concat : ∀ {S} → (* (* S)) ⇛ (* S) 31 | concat {S} true = inp (♯ concat' {I} {S}) 32 | concat {S} false = out false done 33 | 34 | -- Some inclusions, which coerce traces from one session to another. 35 | 36 | -- TODO: Add more inclusions. 37 | -- TODO: Prove that these are monomorphisms. 38 | -- TODO: It would be nice if inclusions like this could be handled by subtyping. 39 | 40 | S⊆S&*T : ∀ {S T} → S ⇒ S &* T 41 | S⊆S&*T {I} = out false done 42 | S⊆S&*T {Σ V F} = inp (♯ λ a → out a S⊆S&*T) 43 | 44 | S⊆*S : ∀ {S} → S ⇒ * S 45 | S⊆*S = out true S⊆S&*T 46 | 47 | ¿S⊆*S : ∀ {S} → ¿ S ⇛ * S 48 | ¿S⊆*S {S} true = out true (S⊆S&*T {S} {S}) 49 | ¿S⊆*S {S} false = out false done 50 | 51 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Trace.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ∞ ; ♭ ; ♯_ ) 2 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; _≢_ ; refl ) 3 | open import Relation.Nullary using ( Dec ; yes ; no ) 4 | open import System.IO.Transducers.Session using ( Session ; I ; Σ ; Γ ; _/_ ; IsI ) 5 | 6 | module System.IO.Transducers.Trace where 7 | 8 | infixr 4 _≤_ _⊑_ _⊨_⊑_ _⊨_✓ _✓ 9 | infixr 5 _∷_ _++_ 10 | 11 | -- The semantics of a session is its set of traces. 12 | -- The name "trace" comes from process algebra, 13 | -- it's called a play in games semantics, or a word of an automaton. 14 | 15 | data Trace (S : Session) : Set where 16 | [] : Trace S 17 | _∷_ : (a : Γ S) (as : Trace (S / a)) → (Trace S) 18 | 19 | -- Traces ending in [] at type I are completed traces 20 | 21 | data _⊨_✓ : ∀ S → (Trace S) → Set₁ where 22 | [] : I ⊨ [] ✓ 23 | _∷_ : ∀ {S} a {as} → (S / a ⊨ as ✓) → (S ⊨ a ∷ as ✓) 24 | 25 | _✓ : ∀ {S} → (Trace S) → Set₁ 26 | _✓ {S} as = S ⊨ as ✓ 27 | 28 | -- Prefix order on traces 29 | 30 | data _⊨_⊑_ : ∀ S → (Trace S) → (Trace S) → Set₁ where 31 | [] : ∀ {S as} → (S ⊨ [] ⊑ as) 32 | _∷_ : ∀ {S} a {as bs} → (S / a ⊨ as ⊑ bs) → (S ⊨ a ∷ as ⊑ a ∷ bs) 33 | 34 | _⊑_ : ∀ {S} → (Trace S) → (Trace S) → Set₁ 35 | _⊑_ {S} as bs = S ⊨ as ⊑ bs 36 | 37 | -- For building buffers, it is useful to provide 38 | -- snoc traces as well as cons traces. 39 | 40 | data _≤_ : Session → Session → Set₁ where 41 | [] : ∀ {S} → (S ≤ S) 42 | _∷_ : ∀ {S T} a (as : S ≤ T) → (S / a ≤ T) 43 | 44 | -- Snoc traces form categories, where composition is concatenation. 45 | 46 | _++_ : ∀ {S T U} → (S ≤ T) → (T ≤ U) → (S ≤ U) 47 | [] ++ bs = bs 48 | (a ∷ as) ++ bs = a ∷ (as ++ bs) 49 | 50 | -- snoc traces can be reversed to form cons traces 51 | 52 | revApp : ∀ {S T} → (S ≤ T) → (Trace S) → (Trace T) 53 | revApp [] bs = bs 54 | revApp (a ∷ as) bs = revApp as (a ∷ bs) 55 | 56 | reverse : ∀ {S T} → (S ≤ T) → (Trace T) 57 | reverse as = revApp as [] 58 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Bytes.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♯_ ) 2 | open import Data.Bool using ( Bool ; true ; false ; not ) 3 | open import Data.ByteString using ( null ) renaming ( span to #span ) 4 | open import Data.Natural using ( Natural ) 5 | open import Data.Product using ( _×_ ; _,_ ) 6 | open import Data.Word using ( Byte ) 7 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; _⟫_ ; π₁ ; π₂ ; _[&]_ ) 8 | open import System.IO.Transducers.Weight using ( weight ) 9 | open import System.IO.Transducers.Stateful using ( loop ) 10 | open import System.IO.Transducers.Session using ( ⟨_⟩ ; _&_ ; ¿ ; * ; _&*_ ) 11 | open import System.IO.Transducers.Strict using ( _⇛_ ) 12 | 13 | module System.IO.Transducers.Bytes where 14 | 15 | open System.IO.Transducers.Session public using ( Bytes ; Bytes' ) 16 | 17 | mutual 18 | 19 | span' : (Byte → Bool) → Bytes' ⇛ (Bytes & Bytes) 20 | span' φ x with #span φ x 21 | span' φ x | (x₁ , x₂) with null x₁ | null x₂ 22 | span' φ x | (x₁ , x₂) | true | true = inp (♯ span φ) 23 | span' φ x | (x₁ , x₂) | true | false = out false (out true (out x₂ done)) 24 | span' φ x | (x₁ , x₂) | false | true = out true (out x₁ (inp (♯ span φ))) 25 | span' φ x | (x₁ , x₂) | false | false = out true (out x₁ (out false (out true (out x₂ done)))) 26 | 27 | span : (Byte → Bool) → Bytes ⇛ (Bytes & Bytes) 28 | span φ false = out false (out false done) 29 | span φ true = inp (♯ span' φ) 30 | 31 | break : (Byte → Bool) → Bytes ⇛ (Bytes & Bytes) 32 | break φ = span (λ x → not (φ x)) 33 | 34 | mutual 35 | 36 | nonempty' : Bytes' & Bytes ⇛ ¿ Bytes & Bytes 37 | nonempty' x with null x 38 | nonempty' x | true = inp (♯ nonempty) 39 | nonempty' x | false = out true (out true (out x done)) 40 | 41 | nonempty : Bytes & Bytes ⇛ ¿ Bytes & Bytes 42 | nonempty true = inp (♯ nonempty') 43 | nonempty false = out false done 44 | 45 | split? : (Byte → Bool) → Bytes ⇒ (¿ Bytes & Bytes) 46 | split? φ = inp (♯ span φ) ⟫ π₂ {Bytes} ⟫ inp (♯ break φ) ⟫ inp (♯ nonempty) 47 | 48 | split : (Byte → Bool) → Bytes ⇒ * Bytes 49 | split φ = loop {Bytes} (split? φ) ⟫ π₁ 50 | 51 | bytes : Bytes ⇒ ⟨ Natural ⟩ 52 | bytes = weight 53 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Function.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♭ ; ♯_ ) 2 | open import Data.Unit using ( ⊤ ; tt ) 3 | open import System.IO.Transducers.Syntax 4 | using ( lazy ; strict ; _⇒_is_ ; inp ; out ; done ) 5 | renaming ( _⟫_ to _⟫'_ ; _[&]_ to _[&]'_ ; _⟨&⟩_ to _⟨&⟩'_ ; 6 | discard to discard' ; π₁ to π₁' ; π₂ to π₂' ; 7 | ⟦_⟧ to ⟦_⟧' ) 8 | open import System.IO.Transducers.Session using ( Session ; I ; Σ ; _&_ ) 9 | open import System.IO.Transducers.Trace using ( Trace ) 10 | 11 | module System.IO.Transducers.Function where 12 | 13 | -- We can regard strict transducers as functions. 14 | -- Note that in the case of S ⇒ T where S is a Σ session, 15 | -- this agrees with the type of inp, so we can regard 16 | -- inp as a function of type ∞ (S ⇒ T) → (S to T is s). 17 | 18 | LHS : Session → Set 19 | LHS I = ⊤ 20 | LHS (Σ {A} V F) = A 21 | 22 | RHS : (S T : Session) → (LHS S) → Set₁ 23 | RHS I T a = I ⇒ T is strict 24 | RHS (Σ V F) T a = ♭ F a ⇒ T is lazy 25 | 26 | _⇛_ : Session → Session → Set₁ 27 | S ⇛ T = (a : LHS S) → (RHS S T a) 28 | 29 | -- Map from functions to syntax and back. 30 | 31 | φ : ∀ {S T} → (S ⇒ T is strict) → (S ⇛ T) 32 | φ {I} done a = done 33 | φ {Σ W F} (inp P) a = ♭ P a 34 | φ {Σ W F} done a = out a done 35 | 36 | φ' : ∀ {S T} → (S ⇛ T) → (S ⇒ T is strict) 37 | φ' {I} P = P tt 38 | φ' {Σ W F} P = inp (♯ P) 39 | 40 | -- Semantics of functions is inherited from semantics on syntax 41 | 42 | ⟦_⟧ : ∀ {S T} → (S ⇛ T) → (Trace S) → (Trace T) 43 | ⟦ P ⟧ = ⟦ φ' P ⟧' 44 | 45 | -- Structure on functions is inherited from structure on syntax 46 | 47 | id : ∀ {S} → (S ⇛ S) 48 | id {S} = φ (done {S}) 49 | 50 | _⟫_ : ∀ {S T U} → (S ⇛ T) → (T ⇛ U) → (S ⇛ U) 51 | _⟫_ {S} P Q = φ (φ' {S} P ⟫' φ' Q) 52 | 53 | _[&]_ : ∀ {S T U V} → (S ⇛ T) → (U ⇛ V) → ((S & U) ⇛ (T & V)) 54 | _[&]_ {S} P Q = φ (φ' {S} P [&]' φ' Q) 55 | 56 | _⟨&⟩_ : ∀ {S T U} → (S ⇛ T) → (S ⇛ U) → (S ⇛ (T & U)) 57 | _⟨&⟩_ {S} P Q = φ (φ' {S} P ⟨&⟩' φ' Q) 58 | 59 | discard : ∀ {S} → (S ⇛ I) 60 | discard {S} = φ (discard' {S}) 61 | 62 | π₁ : ∀ {S T} → ((S & T) ⇛ S) 63 | π₁ {S} = φ (π₁' {S}) 64 | 65 | π₂ : ∀ {S T} → ((S & T) ⇛ T) 66 | π₂ {S} = φ (π₂' {S}) 67 | -------------------------------------------------------------------------------- /src/Data/ByteString.agda: -------------------------------------------------------------------------------- 1 | -- ByteStrings where we track statically if they're lazy or strict 2 | -- Note that lazy and strict bytestrings have the same semantics 3 | -- in Agda, as all computation is guaranteed to terminate. 4 | -- They may, however, have quite different performance characteristics. 5 | 6 | open import Data.Bool using ( Bool ) 7 | open import Data.Nat using ( ℕ ) 8 | open import Data.Natural using ( Natural ; % ) 9 | open import Data.Product using ( _×_ ; _,_ ) 10 | open import Data.Word using ( Byte ) 11 | open import Data.String using ( String ) 12 | open import Data.ByteString.Primitive 13 | 14 | module Data.ByteString where 15 | 16 | open Data.ByteString.Primitive public using ( mkStrict ; mkLazy ) 17 | 18 | data Style : Set where 19 | lazy strict : Style 20 | 21 | ByteString : Style → Set 22 | ByteString strict = ByteStringStrict 23 | ByteString lazy = ByteStringLazy 24 | 25 | ε : {s : Style} → (ByteString s) 26 | ε {lazy} = emptyLazy 27 | ε {strict} = emptyStrict 28 | 29 | _∙_ : {s : Style} → (ByteString s) → (ByteString s) → (ByteString s) 30 | _∙_ {lazy} = appendLazy 31 | _∙_ {strict} = appendStrict 32 | 33 | _◁_ : {s : Style} → Byte → (ByteString s) → (ByteString s) 34 | _◁_ {lazy} = consLazy 35 | _◁_ {strict} = consStrict 36 | 37 | _▷_ : {s : Style} → (ByteString s) → Byte → (ByteString s) 38 | _▷_ {lazy} = snocLazy 39 | _▷_ {strict} = snocStrict 40 | 41 | length : {s : Style} → (ByteString s) → Natural 42 | length {lazy} = lengthLazy 43 | length {strict} = lengthStrict 44 | 45 | size : {s : Style} → (ByteString s) → ℕ 46 | size bs = %(length bs) 47 | 48 | null : {s : Style} → (ByteString s) → Bool 49 | null {lazy} = nullLazy 50 | null {strict} = nullStrict 51 | 52 | span : {s : Style} → (Byte → Bool) → (ByteString s) → (ByteString s × ByteString s) 53 | span {lazy} φ bs with spanLazy φ bs 54 | span {lazy} φ bs | bs² = (lazy₁ bs² , lazy₂ bs²) 55 | span {strict} φ bs with spanStrict φ bs 56 | span {strict} φ bs | bs² = (strict₁ bs² , strict₂ bs²) 57 | 58 | break : {s : Style} → (Byte → Bool) → (ByteString s) → (ByteString s × ByteString s) 59 | break {lazy} φ bs with breakLazy φ bs 60 | break {lazy} φ bs | bs² = (lazy₁ bs² , lazy₂ bs²) 61 | break {strict} φ bs with breakStrict φ bs 62 | break {strict} φ bs | bs² = (strict₁ bs² , strict₂ bs²) 63 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/UTF8.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♯_ ) 2 | open import Data.Bool using ( Bool ; true ; false ; not ) 3 | open import Data.ByteString using ( null ) 4 | open import Data.ByteString.UTF8 using ( fromString ) renaming ( span to #span ) 5 | open import Data.Natural using ( Natural ) 6 | open import Data.Product using ( _×_ ; _,_ ) 7 | open import Data.Char using ( Char ) 8 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; _⟫_ ; π₁ ; π₂ ; _[&]_ ) 9 | open import System.IO.Transducers.Weight using ( weight ) 10 | open import System.IO.Transducers.Stateful using ( loop ) 11 | open import System.IO.Transducers.Session using ( ⟨_⟩ ; _&_ ; ¿ ; * ; _&*_ ; Bytes ; Bytes' ; Strings ) 12 | open import System.IO.Transducers.Strict using ( _⇛_ ) 13 | 14 | module System.IO.Transducers.UTF8 where 15 | 16 | mutual 17 | 18 | -- TODO: span isn't doing the right thing when char boundaries fail to line up with bytestring boundaries 19 | 20 | span+ : (Char → Bool) → Bytes' ⇛ (Bytes & Bytes) 21 | span+ φ x with #span φ x 22 | span+ φ x | (x₁ , x₂) with null x₁ | null x₂ 23 | span+ φ x | (x₁ , x₂) | true | true = inp (♯ span φ) 24 | span+ φ x | (x₁ , x₂) | true | false = out false (out true (out x₂ done)) 25 | span+ φ x | (x₁ , x₂) | false | true = out true (out x₁ (inp (♯ span φ))) 26 | span+ φ x | (x₁ , x₂) | false | false = out true (out x₁ (out false (out true (out x₂ done)))) 27 | 28 | span : (Char → Bool) → Bytes ⇛ (Bytes & Bytes) 29 | span φ false = out false (out false done) 30 | span φ true = inp (♯ span+ φ) 31 | 32 | break : (Char → Bool) → Bytes ⇛ (Bytes & Bytes) 33 | break φ = span (λ x → not (φ x)) 34 | 35 | mutual 36 | 37 | nonempty+ : Bytes' & Bytes ⇛ ¿ Bytes & Bytes 38 | nonempty+ x with null x 39 | nonempty+ x | true = inp (♯ nonempty) 40 | nonempty+ x | false = out true (out true (out x done)) 41 | 42 | nonempty : Bytes & Bytes ⇛ ¿ Bytes & Bytes 43 | nonempty true = inp (♯ nonempty+) 44 | nonempty false = out false done 45 | 46 | split? : (Char → Bool) → Bytes ⇒ (¿ Bytes & Bytes) 47 | split? φ = inp (♯ span φ) ⟫ π₂ {Bytes} ⟫ inp (♯ break φ) ⟫ inp (♯ nonempty) 48 | 49 | split : (Char → Bool) → Bytes ⇒ * Bytes 50 | split φ = loop {Bytes} (split? φ) ⟫ π₁ 51 | 52 | -- TODO: decode 53 | 54 | encode : Strings ⇛ Bytes 55 | encode true = out true (inp (♯ λ s → out (fromString s) (inp (♯ encode)))) 56 | encode false = out false done 57 | 58 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Strict.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ∞ ; ♭ ; ♯_ ) 2 | open import Data.Bool using ( Bool ; true ; false ) 3 | open import Data.Empty using ( ⊥ ; ⊥-elim ) 4 | open import Data.Unit using ( ⊤ ; tt ) 5 | open import System.IO.Transducers.Lazy using 6 | ( _⇒_ ; inp ; out ; done ; choice ) renaming 7 | ( ⟦_⟧ to ⟦_⟧' ; _⟫_ to _⟫'_ 8 | ; _[&]_ to _[&]'_ ; _⟨&⟩_ to _⟨&⟩'_ ; assoc to assoc' ) 9 | open import System.IO.Transducers.Session using ( Session ; I ; Σ ; Γ ; _/_ ; IsΣ ; ⟨_⟩ ; _&_ ; ¿ ; _⊕_ ) 10 | open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ ) 11 | 12 | module System.IO.Transducers.Strict where 13 | 14 | infixr 4 _⇛_ 15 | infixr 6 _⟫_ 16 | infixr 8 _[&]_ _⟨&⟩_ 17 | 18 | -- Strict tranducers are ones which perform input before any output 19 | 20 | data Strict : ∀ {S T} → (S ⇒ T) → Set₁ where 21 | inp : ∀ {A V F T} P → (Strict (inp {A} {V} {F} {T} P)) 22 | done : ∀ {S} → (Strict (done {S})) 23 | 24 | -- Slightly annoyingly, _≡_ has different cardinalities 25 | -- in different versions of the standard library. 26 | -- Until 1.4 of agda-stdlib is more widely distributed, 27 | -- we define a specialized version of _≡_ here. 28 | 29 | data _≡_ (S : Session) : Session → Set₁ where 30 | refl : S ≡ S 31 | 32 | -- S ⇛ T is the type of strict transducers regarded as functions 33 | 34 | _⇛_ : Session → Session → Set₁ 35 | I ⇛ T = I ≡ T 36 | Σ V F ⇛ T = ∀ a → (♭ F a) ⇒ T 37 | 38 | -- Identity transducer 39 | 40 | id : ∀ {S} → S ⇛ S 41 | id {I} = refl 42 | id {Σ V F} = λ a → out a done 43 | 44 | -- Inclusion of strict in lazy transducers 45 | 46 | ι : ∀ {S T} → (S ⇛ T) → (S ⇒ T) 47 | ι {I} refl = done 48 | ι {Σ V F} P = inp (♯ P) 49 | 50 | -- Composition 51 | 52 | _⟫_ : ∀ {S T U} → (S ⇛ T) → (T ⇛ U) → (S ⇛ U) 53 | _⟫_ {I} refl refl = refl 54 | _⟫_ {Σ V F} {I} P refl = P 55 | _⟫_ {Σ V F} {Σ W G} P Q = λ a → (P a ⟫' ι Q) 56 | 57 | -- & on transducers 58 | 59 | _[&]_ : ∀ {S T U V} → (S ⇛ T) → (U ⇛ V) → ((S & U) ⇛ (T & V)) 60 | _[&]_ {I} refl Q = Q 61 | _[&]_ {Σ V F} P Q = λ a → (P a [&]' ι Q) 62 | 63 | -- Associativity of & 64 | 65 | assoc : ∀ {S T U} → ((S & (T & U)) ⇛ ((S & T) & U)) 66 | assoc {I} {T} {U} = id {T & U} 67 | assoc {Σ V F} {T} {U} = λ a → out a (assoc' {♭ F a}) 68 | 69 | -- Mediating morphism for & 70 | 71 | _⟨&⟩_ : ∀ {S T U} → (S ⇛ T) → (S ⇛ U) → (S ⇛ T & U) 72 | _⟨&⟩_ {I} refl refl = refl 73 | _⟨&⟩_ {Σ V F} P Q = λ a → (P a ⟨&⟩' Q a) 74 | -------------------------------------------------------------------------------- /src/Data/Natural/AgdaFFI.hs: -------------------------------------------------------------------------------- 1 | module Data.Natural.AgdaFFI ( Natural, nfoldl, nfoldl', nfoldr, convert ) where 2 | 3 | import Unsafe.Coerce ( unsafeCoerce ) 4 | 5 | newtype Natural = Natural Integer 6 | deriving Eq 7 | 8 | -- Begin yuk. 9 | 10 | {-# INLINE [1] coerce #-} 11 | {-# RULES "coerce-id" forall (x :: a) . coerce x = x #-} 12 | 13 | coerce :: a -> b 14 | coerce = unsafeCoerce 15 | 16 | -- The function f will always really be of type b -> Integer, 17 | -- but it's tricky to get Agda to tell us that. 18 | 19 | convert :: (a -> Integer) -> b -> Natural 20 | convert f x = Natural (f (coerce x)) 21 | 22 | -- End yuk. 23 | 24 | nfoldl :: (a -> a) -> a -> Natural -> a 25 | nfoldl f x (Natural (n+1)) = nfoldl f (f x) (Natural n) 26 | nfoldl f x (Natural n) = x 27 | 28 | nfoldl' :: (a -> a) -> a -> Natural -> a 29 | nfoldl' f x (Natural (n+1)) = seq x (nfoldl' f (f x) (Natural n)) 30 | nfoldl' f x (Natural n) = x 31 | 32 | nfoldr :: (a -> a) -> a -> Natural -> a 33 | nfoldr f x (Natural (n+1)) = f (nfoldr f x (Natural n)) 34 | nfoldr f x (Natural n) = x 35 | 36 | instance Show Natural where 37 | show (Natural n) = show n 38 | 39 | instance Read Natural where 40 | readsPrec p s = [ (Natural n, t) | (n,t) <- readsPrec p s ] 41 | 42 | instance Ord Natural where 43 | compare (Natural m) (Natural n) = compare m n 44 | 45 | instance Enum Natural where 46 | succ (Natural n) = Natural (succ n) 47 | pred (Natural (n+1)) = Natural n 48 | pred (Natural n) = Natural 0 49 | toEnum = fromInteger . toEnum 50 | fromEnum = fromEnum . toInteger 51 | 52 | instance Num Natural where 53 | (Natural n) + (Natural m) = Natural (n + m) 54 | (Natural n) - (Natural m) | n < m = Natural 0 55 | (Natural n) - (Natural m) = Natural (n - m) 56 | (Natural n) * (Natural m) = Natural (n * m) 57 | negate n = Natural 0 58 | signum (Natural 0) = Natural 0 59 | signum (Natural n) = Natural 1 60 | abs = id 61 | fromInteger n | n < 0 = Natural n 62 | fromInteger n = Natural n 63 | 64 | instance Integral Natural where 65 | div (Natural m) (Natural n) = Natural (div m n) 66 | mod (Natural m) (Natural n) = Natural (mod m n) 67 | quotRem (Natural m) (Natural n) = (Natural (m'), Natural (n')) where (m',n') = quotRem m n 68 | toInteger (Natural n) = n 69 | 70 | instance Real Natural where 71 | toRational (Natural n) = toRational n 72 | -------------------------------------------------------------------------------- /src/System/IO/Primitive.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ∞ ) 2 | open import Data.ByteString using ( ByteString ; strict ; lazy ) 3 | open import Data.String using ( String ) 4 | 5 | module System.IO.Primitive where 6 | 7 | infixl 1 _>>=_ 8 | 9 | -- The Unit type and its sole inhabitant 10 | 11 | postulate 12 | Unit : Set 13 | unit : Unit 14 | 15 | {-# COMPILED_TYPE Unit () #-} 16 | {-# COMPILED unit () #-} 17 | 18 | -- The IO type and its primitives 19 | -- TODO: Make these universe-polymorphic once the compiler supports it 20 | 21 | postulate 22 | IO : Set → Set 23 | return : {A : Set} → A → (IO A) 24 | _>>=_ : {A B : Set} → (IO A) → (A → (IO B)) → (IO B) 25 | inf : {A : Set} → ∞(IO A) → (IO A) 26 | 27 | {-# COMPILED_TYPE IO IO #-} 28 | {-# COMPILED return (\ _ a -> return a) #-} 29 | {-# COMPILED _>>=_ (\ _ _ a f -> a >>= f) #-} 30 | -- {-# COMPILED inf (\ _ a -> a) #-} 31 | 32 | -- The commitment primitives 33 | postulate 34 | commit : IO Unit 35 | onCommit : (IO Unit) → (IO Unit) 36 | 37 | {-# IMPORT System.IO.AgdaFFI #-} 38 | {-# COMPILED commit System.IO.AgdaFFI.commit #-} 39 | {-# COMPILED onCommit System.IO.AgdaFFI.onCommit #-} 40 | 41 | -- The low-level binary handle primitives. 42 | -- TODO: Should the string etc. functions be built on top of 43 | -- the binary functions, or should we link directly to the Haskll 44 | -- string functions? 45 | -- TODO: Think about append and read-write modes. 46 | 47 | postulate 48 | HandleR : Set 49 | stdin : HandleR 50 | hOpenR : String → (IO HandleR) 51 | hGetLazy : HandleR → (IO (ByteString lazy)) 52 | hGetStrict : HandleR → (IO (ByteString strict)) 53 | hCloseR : HandleR → (IO Unit) 54 | 55 | {-# IMPORT System.IO #-} 56 | {-# COMPILED_TYPE HandleR System.IO.Handle #-} 57 | {-# COMPILED stdin System.IO.stdin #-} 58 | {-# COMPILED hOpenR System.IO.AgdaFFI.hOpen System.IO.ReadMode #-} 59 | {-# COMPILED hGetStrict System.IO.AgdaFFI.hGetStrict #-} 60 | {-# COMPILED hGetLazy System.IO.AgdaFFI.hGetLazy #-} 61 | {-# COMPILED hCloseR System.IO.AgdaFFI.hClose #-} 62 | 63 | postulate 64 | HandleW : Set 65 | stdout : HandleW 66 | stderr : HandleW 67 | hOpenW : String → (IO HandleW) 68 | hPutLazy : HandleW → (ByteString lazy) → (IO Unit) 69 | hPutStrict : HandleW → (ByteString strict) → (IO Unit) 70 | hCloseW : HandleW → (IO Unit) 71 | 72 | {-# COMPILED_TYPE HandleW System.IO.Handle #-} 73 | {-# COMPILED stdout System.IO.stdout #-} 74 | {-# COMPILED stderr System.IO.stderr #-} 75 | {-# COMPILED hOpenW System.IO.AgdaFFI.hOpen System.IO.WriteMode #-} 76 | {-# COMPILED hPutStrict System.IO.AgdaFFI.hPutStrict #-} 77 | {-# COMPILED hPutLazy System.IO.AgdaFFI.hPutLazy #-} 78 | {-# COMPILED hCloseW System.IO.AgdaFFI.hClose #-} 79 | -------------------------------------------------------------------------------- /src/System/IO.agda: -------------------------------------------------------------------------------- 1 | open import Data.String using ( String ) 2 | open import Data.ByteString using ( ByteString ; Style ; lazy ; strict ) 3 | open import Data.ByteString.UTF8 using ( toString ; fromString ) 4 | open import System.IO.Primitive using ( HandleR ; HandleW ; hOpenR ; hOpenW ; hCloseR ; hCloseW ; hGetStrict ; hGetLazy ; hPutStrict ; hPutLazy ) 5 | 6 | -- A proposed binding for the Haskell IO library. 7 | 8 | -- The semantics is strict IO, there is no visibility for semi-closed handles. 9 | 10 | module System.IO where 11 | 12 | open System.IO.Primitive public using ( Unit ; IO ; unit ; return ; _>>=_ ; commit ; onCommit ; stdin ; stdout ; stderr ) 13 | 14 | -- Command is a synonym for IO Unit 15 | 16 | Command : Set 17 | Command = IO Unit 18 | 19 | skip : Command 20 | skip = return unit 21 | 22 | -- Other operations are defined in terms of _>>=_ 23 | 24 | infixl 1 _>>_ 25 | infixl 4 _<$>_ _<*>_ 26 | 27 | _>>_ : {A B : Set} → (IO A) → (IO B) → (IO B) 28 | a >> b = a >>= (λ x → b) 29 | 30 | _<$>_ : {A B : Set} → (A → B) → (IO A) → (IO B) 31 | _<$>_ f a = a >>= (λ x → return (f x)) 32 | 33 | _<*>_ : {A B : Set} → (IO (A → B)) → (IO A) → (IO B) 34 | _<*>_ f a = f >>= (λ x → x <$> a) 35 | 36 | -- TODO: Use the new "syntax" construct to define do-like notation? 37 | 38 | -- TODO: RW and Append mode? 39 | 40 | data IOMode : Set where 41 | read write : IOMode 42 | 43 | Handle : IOMode → Set 44 | Handle read = HandleR 45 | Handle write = HandleW 46 | 47 | -- TODO: There should really be a separate type for file paths, 48 | -- and some sanity-checking to support protection against 49 | -- injection attacks. 50 | 51 | hOpen : {m : IOMode} → String → IO (Handle m) 52 | hOpen {read} = hOpenR 53 | hOpen {write} = hOpenW 54 | 55 | hGetBytes : {s : Style} → (Handle read) → IO (ByteString s) 56 | hGetBytes {lazy} = hGetLazy 57 | hGetBytes {strict} = hGetStrict 58 | 59 | getBytes : {s : Style} → IO (ByteString s) 60 | getBytes = hGetBytes stdin 61 | 62 | hPutBytes : {s : Style} → (Handle write) → (ByteString s) → Command 63 | hPutBytes {lazy} = hPutLazy 64 | hPutBytes {strict} = hPutStrict 65 | 66 | putBytes : {s : Style} → (ByteString s) → Command 67 | putBytes = hPutBytes stdout 68 | 69 | hClose : {m : IOMode} → (Handle m) → Command 70 | hClose {read} = hCloseR 71 | hClose {write} = hCloseW 72 | 73 | -- TODO: Better handling of codecs, don't just hard-wire UTF-8! 74 | -- TODO: Lazy vs strict strings? 75 | -- Default arguments would help a lot here. 76 | 77 | hGetStr : (Handle read) → (IO String) 78 | hGetStr hdl = toString <$> hGetBytes {lazy} hdl 79 | 80 | getStr : (IO String) 81 | getStr = hGetStr stdin 82 | 83 | hPutStr : (Handle write) → String → Command 84 | hPutStr hdl s = hPutBytes {lazy} hdl (fromString s) 85 | 86 | putStr : String → Command 87 | putStr = hPutStr stdout 88 | 89 | -------------------------------------------------------------------------------- /src/Data/ByteString/Primitive.agda: -------------------------------------------------------------------------------- 1 | open import Data.Bool using ( Bool ) 2 | open import Data.String using ( String ) 3 | open import Data.Word using ( Byte ) 4 | open import Data.Natural using ( Natural ) 5 | 6 | module Data.ByteString.Primitive where 7 | 8 | postulate 9 | ByteStringLazy : Set 10 | ByteStringLazy² : Set 11 | emptyLazy : ByteStringLazy 12 | consLazy : Byte → ByteStringLazy → ByteStringLazy 13 | snocLazy : ByteStringLazy → Byte → ByteStringLazy 14 | appendLazy : ByteStringLazy → ByteStringLazy → ByteStringLazy 15 | lengthLazy : ByteStringLazy → Natural 16 | nullLazy : ByteStringLazy → Bool 17 | spanLazy : (Byte → Bool) → ByteStringLazy → ByteStringLazy² 18 | breakLazy : (Byte → Bool) → ByteStringLazy → ByteStringLazy² 19 | lazy₁ : ByteStringLazy² → ByteStringLazy 20 | lazy₂ : ByteStringLazy² → ByteStringLazy 21 | 22 | {-# IMPORT Data.ByteString.Lazy #-} 23 | {-# COMPILED_TYPE ByteStringLazy Data.ByteString.Lazy.ByteString #-} 24 | {-# COMPILED_TYPE ByteStringLazy² (Data.ByteString.Lazy.ByteString,Data.ByteString.Lazy.ByteString) #-} 25 | {-# COMPILED emptyLazy Data.ByteString.Lazy.empty #-} 26 | {-# COMPILED consLazy Data.ByteString.Lazy.cons #-} 27 | {-# COMPILED snocLazy Data.ByteString.Lazy.snoc #-} 28 | {-# COMPILED appendLazy Data.ByteString.Lazy.append #-} 29 | {-# COMPILED lengthLazy fromIntegral . Data.ByteString.Lazy.length #-} 30 | {-# COMPILED nullLazy Data.ByteString.Lazy.null #-} 31 | {-# COMPILED spanLazy Data.ByteString.Lazy.span #-} 32 | {-# COMPILED breakLazy Data.ByteString.Lazy.break #-} 33 | {-# COMPILED lazy₁ \ ( x , y ) -> x #-} 34 | {-# COMPILED lazy₂ \ ( x , y ) -> y #-} 35 | 36 | postulate 37 | ByteStringStrict : Set 38 | ByteStringStrict² : Set 39 | emptyStrict : ByteStringStrict 40 | consStrict : Byte → ByteStringStrict → ByteStringStrict 41 | snocStrict : ByteStringStrict → Byte → ByteStringStrict 42 | appendStrict : ByteStringStrict → ByteStringStrict → ByteStringStrict 43 | lengthStrict : ByteStringStrict → Natural 44 | nullStrict : ByteStringStrict → Bool 45 | spanStrict : (Byte → Bool) → ByteStringStrict → ByteStringStrict² 46 | breakStrict : (Byte → Bool) → ByteStringStrict → ByteStringStrict² 47 | strict₁ : ByteStringStrict² → ByteStringStrict 48 | strict₂ : ByteStringStrict² → ByteStringStrict 49 | 50 | {-# IMPORT Data.ByteString #-} 51 | {-# COMPILED_TYPE ByteStringStrict Data.ByteString.ByteString #-} 52 | {-# COMPILED_TYPE ByteStringStrict² (Data.ByteString.ByteString,Data.ByteString.ByteString) #-} 53 | {-# COMPILED emptyStrict Data.ByteString.empty #-} 54 | {-# COMPILED consStrict Data.ByteString.cons #-} 55 | {-# COMPILED snocStrict Data.ByteString.snoc #-} 56 | {-# COMPILED appendStrict Data.ByteString.append #-} 57 | {-# COMPILED lengthStrict fromIntegral . Data.ByteString.length #-} 58 | {-# COMPILED nullStrict Data.ByteString.null #-} 59 | {-# COMPILED spanStrict Data.ByteString.span #-} 60 | {-# COMPILED breakStrict Data.ByteString.break #-} 61 | {-# COMPILED strict₁ \ ( x , y ) -> x #-} 62 | {-# COMPILED strict₂ \ ( x , y ) -> y #-} 63 | 64 | postulate 65 | mkLazy : ByteStringStrict → ByteStringLazy 66 | mkStrict : ByteStringLazy → ByteStringStrict 67 | 68 | {-# COMPILED mkStrict (Data.ByteString.concat . Data.ByteString.Lazy.toChunks) #-} 69 | {-# COMPILED mkLazy (\ bs -> Data.ByteString.Lazy.fromChunks [ bs ]) #-} 70 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties/LaxProduct.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♭ ) 2 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; cong₂ ) 3 | open import System.IO.Transducers using ( _⇒_ ; inp ; out ; done ; out*' ; _⟫_ ; _⟨&⟩_ ; _⟨&⟩[_]_ ; discard ; π₁ ; π₂ ; ⟦_⟧ ; _≃_ ) 4 | open import System.IO.Transducers.Session using ( [] ; _∷_ ; _&_ ) 5 | open import System.IO.Transducers.Trace using ( _≤_ ; Trace ; [] ; _∷_ ) 6 | open import System.IO.Transducers.Properties.Lemmas using ( cong₃ ; revApp ; out*'-semantics ) 7 | open import System.IO.Transducers.Properties.BraidedMonoidal using ( _++_ ) 8 | open import System.IO.Transducers.Properties.Category using ( _⟦⟫⟧_ ; ⟫-semantics ) 9 | 10 | module System.IO.Transducers.Properties.LaxProduct where 11 | 12 | open Relation.Binary.PropositionalEquality.≡-Reasoning 13 | 14 | _⟦⟨&⟩⟧_ : ∀ {S T U} → 15 | (f : Trace S → Trace T) → (g : Trace S → Trace U) → 16 | (Trace S) → (Trace (T & U)) 17 | (f ⟦⟨&⟩⟧ g) as = f as ++ g as 18 | 19 | _⟦⟨&⟩[_]⟧_ : ∀ {S T U V} → 20 | (Trace S → Trace T) → (U ≤ V) → (Trace S → Trace U) → 21 | (Trace S → Trace (T & V)) 22 | (f ⟦⟨&⟩[ cs ]⟧ g) as = f as ++ (revApp cs (g as)) 23 | 24 | ⟨&⟩[]-semantics : ∀ {S T U V} → 25 | (P : S ⇒ T) → (cs : U ≤ V) → (Q : S ⇒ U) → 26 | (⟦ P ⟨&⟩[ cs ] Q ⟧ ≃ ⟦ P ⟧ ⟦⟨&⟩[ cs ]⟧ ⟦ Q ⟧) 27 | ⟨&⟩[]-semantics (inp {T = []} F) cs Q as with ⟦ inp F ⟧ as 28 | ⟨&⟩[]-semantics (inp {T = []} F) cs Q as | [] = out*'-semantics cs Q as 29 | ⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs (inp G) [] = refl 30 | ⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs (inp G) (a ∷ as) = ⟨&⟩[]-semantics (♭ F a) cs (♭ G a) as 31 | ⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs (out c Q) as = ⟨&⟩[]-semantics (inp F) (c ∷ cs) Q as 32 | ⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs done [] = refl 33 | ⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs done (a ∷ as) = ⟨&⟩[]-semantics (♭ F a) (a ∷ cs) done as 34 | ⟨&⟩[]-semantics (out b P) cs Q as = cong (_∷_ b) (⟨&⟩[]-semantics P cs Q as) 35 | ⟨&⟩[]-semantics (done {[]}) cs Q [] = out*'-semantics cs Q [] 36 | ⟨&⟩[]-semantics (done {W ∷ Ts}) cs (inp F) [] = refl 37 | ⟨&⟩[]-semantics (done {W ∷ Ts}) cs (inp F) (a ∷ as) = cong (_∷_ a) (⟨&⟩[]-semantics done cs (♭ F a) as) 38 | ⟨&⟩[]-semantics (done {W ∷ Ts}) cs (out c Q) as = ⟨&⟩[]-semantics done (c ∷ cs) Q as 39 | ⟨&⟩[]-semantics (done {W ∷ Ts}) cs done [] = refl 40 | ⟨&⟩[]-semantics (done {W ∷ Ts}) cs done (a ∷ as) = cong (_∷_ a) (⟨&⟩[]-semantics done (a ∷ cs) done as) 41 | 42 | ⟨&⟩-semantics : ∀ {S T U} → 43 | (P : S ⇒ T) → (Q : S ⇒ U) → 44 | (⟦ P ⟨&⟩ Q ⟧ ≃ ⟦ P ⟧ ⟦⟨&⟩⟧ ⟦ Q ⟧) 45 | ⟨&⟩-semantics P Q = ⟨&⟩[]-semantics P [] Q 46 | 47 | ⟫-dist-⟨&⟩ : ∀ {S T U V} → 48 | (P : T ⇒ U) → (Q : T ⇒ V) → (R : S ⇒ T) → 49 | (⟦ R ⟫ (P ⟨&⟩ Q) ⟧ ≃ ⟦ (R ⟫ P) ⟨&⟩ (R ⟫ Q) ⟧) 50 | ⟫-dist-⟨&⟩ P Q R as = 51 | begin 52 | ⟦ R ⟫ P ⟨&⟩ Q ⟧ as 53 | ≡⟨ ⟫-semantics R (P ⟨&⟩ Q) as ⟩ 54 | ⟦ P ⟨&⟩ Q ⟧ (⟦ R ⟧ as) 55 | ≡⟨ ⟨&⟩-semantics P Q (⟦ R ⟧ as) ⟩ 56 | ⟦ P ⟧ (⟦ R ⟧ as) ++ ⟦ Q ⟧ (⟦ R ⟧ as) 57 | ≡⟨ cong₂ _++_ (sym (⟫-semantics R P as)) (sym (⟫-semantics R Q as)) ⟩ 58 | ⟦ R ⟫ P ⟧ as ++ ⟦ R ⟫ Q ⟧ as 59 | ≡⟨ sym (⟨&⟩-semantics (R ⟫ P) (R ⟫ Q) as) ⟩ 60 | ⟦ (R ⟫ P) ⟨&⟩ (R ⟫ Q) ⟧ as 61 | ∎ 62 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Overview 2 | ======== 3 | 4 | Minimal I/O binding 5 | ------------------- 6 | 7 | This library is intended to provide a minimal binding to Haskell IO, 8 | which respects Agda's semantics while still providing the performance 9 | benefits of lazy IO. 10 | 11 | The problem with directly binding to Haskell's IO monad is that lazy 12 | IO does not respect Agda's semantics. For example, given two 13 | programs: 14 | 15 | ```haskell 16 | hello1 : List Char -> IO String 17 | hello1 [] = putStr "Hello" 18 | hello1 (x :: xs) = putStr "Hello" 19 | ``` 20 | 21 | and: 22 | 23 | ```haskell 24 | hello2 : List Char -> IO String 25 | hello2 xs = putStr "Hello" 26 | ``` 27 | 28 | It is routine to prove that hello1 and hello2 are extensionally equal, 29 | and so we would expect that: 30 | 31 | ```haskell 32 | mainX = getContents >>= helloX 33 | ``` 34 | 35 | would have the same behaviour, no matter which helloX function is 36 | plugged in. 37 | 38 | Unfortunately, Haskell program equality does not include 39 | eta-equivalence on lists, and so main1 will block waiting for input, 40 | where main2 prints "Hello". 41 | 42 | This library provides an implementation of a simple transactional model 43 | of IO. In this model, all IO has strict semantics, but the programmer 44 | has control over the order of evaluation, via use of the commit command. 45 | All IO is buffered until a commit operation takes place, so the program: 46 | 47 | ```haskell 48 | putStr "Hello, World\n" 49 | ``` 50 | 51 | prints nothing, whereas the program: 52 | 53 | ```haskell 54 | putStr "Hello, World\n" >> commit 55 | ``` 56 | 57 | prints the expected greeting. If data is read lazily, then it is not 58 | made strict until the commit operation. For example, the program 59 | System.IO.Examples.DevNull reads and discards its input: 60 | 61 | ```agda 62 | getBytes {lazy} >>= λ bs → 63 | putStr "Done.\n" >> 64 | commit 65 | ``` 66 | 67 | runs in constant space, for example when fed a 500M file: 68 | 69 | 559,216,832 bytes allocated in the heap 70 | 91,624 bytes copied during GC 71 | 20,392 bytes maximum residency (1 sample(s)) 72 | 33,296 bytes maximum slop 73 | 2 MB total memory in use (0 MB lost due to fragmentation) 74 | 75 | Its strict equivalent reads the whole file into memory. 76 | 77 | Transducers 78 | ----------- 79 | 80 | There is also a more experimental library which is intended to provide 81 | the benefit of iteratees to Agda IO. It is based on transducers 82 | (that is automata that can read input and produce output), and is 83 | typed using a variant on session types. Since automata are explicit 84 | about when they perform input, they are not subject to eta-equivalence, 85 | so can be used without worrying about breaking Agda's semantics. 86 | 87 | Currently the transducer library is provided without any bindings 88 | to the I/O library -- this will be fixed soon. 89 | 90 | Some simple examples are in System.IO.Examples.Transducers. 91 | 92 | Requirements 93 | ============ 94 | 95 | Agda 2.2.6 or 2.2.8, and the Agda standard library 0.3 or 0.4. 96 | 97 | Haskell libraries bytestring and utf8-string. 98 | 99 | Compiling 100 | ========= 101 | 102 | ``` 103 | $ agda -i src -i -c src/System/IO/Examples/HelloWorld.agda 104 | ``` 105 | 106 | Testing 107 | ======= 108 | 109 | ``` 110 | $ ./HelloWorld 111 | ``` 112 | -------------------------------------------------------------------------------- /src/System/IO/AgdaFFI.hs: -------------------------------------------------------------------------------- 1 | module System.IO.AgdaFFI ( 2 | commit, onCommit, 3 | hOpen, hClose, 4 | hGetLazy, hGetStrict, 5 | hPutLazy, hPutStrict 6 | ) where 7 | 8 | import qualified Data.ByteString as S 9 | import qualified Data.ByteString.Lazy as L 10 | import Data.IORef ( IORef, newIORef, readIORef, writeIORef, atomicModifyIORef ) 11 | import System.IO ( IOMode, Handle, openBinaryFile, hFlush ) 12 | import qualified System.IO ( hClose ) 13 | import System.IO.Unsafe ( unsafePerformIO ) 14 | import Control.Applicative ( (<$>), (<*>) ) 15 | import Control.Monad ( join ) 16 | 17 | -- A library for simple IO transactions. Currently not handling 18 | -- exceptions, rollback or per-thread transactions. 19 | 20 | -- A global variable containing the on-commit actions. 21 | -- Ah, unsafePerformIO you are my very bestest friend. 22 | {-# NOINLINE delayed #-} 23 | delayed :: IORef (IO ()) 24 | delayed = unsafePerformIO (newIORef (return ())) 25 | 26 | -- Commit executes the delayed actions. 27 | -- TODO: Should this be called "flush" rather than "commit"? 28 | -- TODO: What if this raises an exception? 29 | commit :: IO() 30 | commit = join (atomicModifyIORef delayed (\ io -> (return (), io))) 31 | 32 | -- onCommit delays execution until the next commit. 33 | onCommit :: IO() -> IO() 34 | onCommit later = atomicModifyIORef delayed (\ io -> (io >> later, ())) 35 | 36 | -- The following could use the Strategy or DeepSeq mechanism 37 | -- to generalize away from just lists and bytestrings, 38 | -- but for the moment we stick to the simple case. 39 | 40 | -- force xs evaluates the list structure of xs (not its contents!) 41 | -- Pretty please Dr Haskell, don't do clever loop-hoisting 42 | -- and just always return without touching xs. 43 | forceList :: [a] -> IO () 44 | forceList [] = return () 45 | forceList (x : xs) = forceList xs 46 | 47 | -- strictList xs returns a list equivalent to xs, 48 | -- which will be forced on the next commit. There 49 | -- is quite a bit of unsafe hoop-jumping here to avoid keeping 50 | -- xs live, which would rather defeat the point of lazy IO. 51 | strictList :: [a] -> IO [a] 52 | strictList xs = do 53 | r <- newIORef (xs) 54 | onCommit (readIORef r >>= forceList) 55 | return (f r xs) where 56 | {-# NOINLINE f #-} 57 | f r [] = [] 58 | f r (x : xs) = unsafePerformIO (writeIORef r ys >> return (x : ys)) where 59 | ys = f r xs 60 | 61 | -- strictByteString is just a wrapper round strictList. 62 | strictByteString :: L.ByteString -> IO L.ByteString 63 | strictByteString bs = L.fromChunks <$> (strictList (L.toChunks bs)) 64 | 65 | -- Handles are opened immediately 66 | -- TODO: This may have a visible side-effect of creating a file? 67 | -- TODO: What if this raises an exception? 68 | hOpen :: IOMode -> String -> IO Handle 69 | hOpen m s = openBinaryFile s m 70 | 71 | -- Input can happen immediately. 72 | -- TODO: Currently, exception-generation is very different 73 | -- between the strict and lazy case, we may wish to revisit this. 74 | hGetLazy :: Handle -> IO L.ByteString 75 | hGetLazy hdl = L.hGetContents hdl >>= strictByteString 76 | 77 | hGetStrict :: Handle -> IO S.ByteString 78 | hGetStrict hdl = S.hGetContents hdl 79 | 80 | -- Output is buffered to be performed on a commit action. 81 | -- TODO: Better treatment of flushing? 82 | hPutLazy :: Handle -> L.ByteString -> IO () 83 | hPutLazy hdl bs = onCommit (L.hPut hdl bs >> hFlush hdl) 84 | 85 | hPutStrict :: Handle -> S.ByteString -> IO () 86 | hPutStrict hdl bs = seq bs (onCommit (S.hPut hdl bs >> hFlush hdl)) 87 | 88 | -- Handles are closed on commit 89 | hClose :: Handle -> IO () 90 | hClose hdl = onCommit (System.IO.hClose hdl) 91 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties/TwoCategory.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♭ ) 2 | open import Data.Product using ( _,_ ) 3 | open import Relation.Binary using ( Poset ) 4 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; trans ; cong ; subst₂ ) renaming ( setoid to ≡-setoid ) 5 | open import System.IO.Transducers using ( _⇒_ ; inp ; out ; done ; ⟦_⟧ ; _≃_ ; _≲_ ; _⟫_ ) 6 | open import System.IO.Transducers.Session using ( Session ) 7 | open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ ; _⊑_ ) 8 | open import System.IO.Transducers.Properties.Category using ( ⟫-semantics ) 9 | 10 | import Relation.Binary.PartialOrderReasoning 11 | 12 | module System.IO.Transducers.Properties.TwoCategory where 13 | 14 | -- The category is poset-enriched, with order inherited from prefix order on traces. 15 | 16 | -- Reflexivity 17 | 18 | ⊑-refl : ∀ {S} (as : Trace S) → (as ⊑ as) 19 | ⊑-refl [] = [] 20 | ⊑-refl (a ∷ as) = (a ∷ ⊑-refl as) 21 | 22 | ≡-impl-⊑ : ∀ {S} {as bs : Trace S} → (as ≡ bs) → (as ⊑ bs) 23 | ≡-impl-⊑ refl = ⊑-refl _ 24 | 25 | ≲-refl : ∀ {S T} (f : Trace S → Trace T) → (f ≲ f) 26 | ≲-refl f as = ⊑-refl (f as) 27 | 28 | ≃-impl-≲ : ∀ {S T} {f g : Trace S → Trace T} → (f ≃ g) → (f ≲ g) 29 | ≃-impl-≲ f≃g as = ≡-impl-⊑ (f≃g as) 30 | 31 | -- Transitivity 32 | 33 | ⊑-trans : ∀ {S} {as bs cs : Trace S} → (as ⊑ bs) → (bs ⊑ cs) → (as ⊑ cs) 34 | ⊑-trans [] bs = [] 35 | ⊑-trans (a ∷ as) (.a ∷ bs) = (a ∷ ⊑-trans as bs) 36 | 37 | ≲-trans : ∀ {S T} {f g h : Trace S → Trace T} → (f ≲ g) → (g ≲ h) → (f ≲ h) 38 | ≲-trans f≲g g≲h as = ⊑-trans (f≲g as) (g≲h as) 39 | 40 | -- Antisymmetry 41 | 42 | ⊑-antisym : ∀ {S} {as bs : Trace S} → (as ⊑ bs) → (bs ⊑ as) → (as ≡ bs) 43 | ⊑-antisym [] [] = refl 44 | ⊑-antisym (a ∷ as) (.a ∷ bs) = cong (_∷_ a) (⊑-antisym as bs) 45 | 46 | ≲-antisym : ∀ {S T} {f g : Trace S → Trace T} → (f ≲ g) → (g ≲ f) → (f ≃ g) 47 | ≲-antisym f≲g g≲f as = ⊑-antisym (f≲g as) (g≲f as) 48 | 49 | -- ⊑ and ≲ form posets 50 | 51 | ⊑-poset : Session → Poset _ _ _ 52 | ⊑-poset S = record 53 | { Carrier = Trace S 54 | ; _≈_ = _≡_ 55 | ; _≤_ = _⊑_ 56 | ; isPartialOrder = record 57 | { antisym = ⊑-antisym 58 | ; isPreorder = record 59 | { reflexive = ≡-impl-⊑ 60 | ; trans = ⊑-trans 61 | ; ∼-resp-≈ = ((λ bs≡cs → subst₂ _⊑_ refl bs≡cs) , (λ as≡bs → subst₂ _⊑_ as≡bs refl)) 62 | ; isEquivalence = Relation.Binary.Setoid.isEquivalence (≡-setoid (Trace S)) 63 | } 64 | } 65 | } 66 | 67 | ≲-poset : Session → Session → Poset _ _ _ 68 | ≲-poset S T = record 69 | { Carrier = (Trace S → Trace T) 70 | ; _≈_ = _≃_ 71 | ; _≤_ = _≲_ 72 | ; isPartialOrder = record 73 | { antisym = ≲-antisym 74 | ; isPreorder = record 75 | { reflexive = ≃-impl-≲ 76 | ; trans = ≲-trans 77 | ; ∼-resp-≈ = (λ P≃Q P≲R as → subst₂ _⊑_ refl (P≃Q as) (P≲R as)) , λ Q≃R Q≲P as → subst₂ _⊑_ (Q≃R as) refl (Q≲P as) 78 | ; isEquivalence = record 79 | { refl = λ as → refl 80 | ; sym = λ P≃Q as → sym (P≃Q as) 81 | ; trans = λ P≃Q Q≃R as → trans (P≃Q as) (Q≃R as) 82 | } 83 | } 84 | } 85 | } 86 | 87 | -- Inequational reasoning 88 | 89 | module ⊑-Reasoning {S} where 90 | open Relation.Binary.PartialOrderReasoning (⊑-poset S) public renaming ( _≤⟨_⟩_ to _⊑⟨_⟩_ ; _≈⟨_⟩_ to _≡⟨_⟩_ ) 91 | 92 | module ≲-Reasoning {S T} where 93 | open Relation.Binary.PartialOrderReasoning (≲-poset S T) public renaming ( _≤⟨_⟩_ to _≲⟨_⟩_ ; _≈⟨_⟩_ to _≃⟨_⟩_ ) 94 | 95 | open ⊑-Reasoning 96 | 97 | -- Processes are ⊑-monotone 98 | 99 | P-monotone : ∀ {S T as bs} → (P : S ⇒ T) → (as ⊑ bs) → (⟦ P ⟧ as ⊑ ⟦ P ⟧ bs) 100 | P-monotone (inp F) [] = [] 101 | P-monotone (inp F) (a ∷ as⊑bs) = P-monotone (♭ F a) as⊑bs 102 | P-monotone (out b P) as⊑bs = b ∷ P-monotone P as⊑bs 103 | P-monotone done as⊑bs = as⊑bs 104 | 105 | -- Composition is ≲-monotone 106 | 107 | ⟫-monotone : ∀ {S T U} (P₁ P₂ : S ⇒ T) (Q₁ Q₂ : T ⇒ U) → 108 | (⟦ P₁ ⟧ ≲ ⟦ P₂ ⟧) → (⟦ Q₁ ⟧ ≲ ⟦ Q₂ ⟧) → 109 | (⟦ P₁ ⟫ Q₁ ⟧ ≲ ⟦ P₂ ⟫ Q₂ ⟧) 110 | ⟫-monotone P₁ P₂ Q₁ Q₂ P₁≲P₂ Q₁≲Q₂ as = 111 | begin 112 | ⟦ P₁ ⟫ Q₁ ⟧ as 113 | ≡⟨ ⟫-semantics P₁ Q₁ as ⟩ 114 | ⟦ Q₁ ⟧ (⟦ P₁ ⟧ as) 115 | ⊑⟨ P-monotone Q₁ (P₁≲P₂ as) ⟩ 116 | ⟦ Q₁ ⟧ (⟦ P₂ ⟧ as) 117 | ⊑⟨ Q₁≲Q₂ (⟦ P₂ ⟧ as) ⟩ 118 | ⟦ Q₂ ⟧ (⟦ P₂ ⟧ as) 119 | ≡⟨ sym (⟫-semantics P₂ Q₂ as) ⟩ 120 | ⟦ P₂ ⟫ Q₂ ⟧ as 121 | ∎ -------------------------------------------------------------------------------- /src/System/IO/Transducers/Session.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ∞ ; ♯_ ; ♭ ) 2 | open import Data.Bool using ( Bool ; true ; false ; if_then_else_ ) 3 | open import Data.Empty using ( ⊥ ) 4 | open import Data.Maybe using ( Maybe ; just ; nothing ) 5 | open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ ) 6 | open import Data.Unit using ( ⊤ ; tt ) 7 | open import Data.Natural using ( Natural ; # ) 8 | open import Data.String using ( String ) 9 | open import Data.ByteString using ( ByteString ; strict ; length ) 10 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ) 11 | 12 | module System.IO.Transducers.Session where 13 | 14 | -- Unidirectional sessions. These can be viewed as trees, 15 | -- where each node is labelled by a set A, and has a child 16 | -- for each element of A. 17 | 18 | -- These are a lot like session types, but are unidirectional, 19 | -- not bidirectional, and are not designed to support session 20 | -- mobility. 21 | 22 | -- They are also a lot like arenas in game semantics, but again 23 | -- are unidirectional. 24 | 25 | -- They're a lot like the container types from Ghani, Hancock 26 | -- and Pattison's "Continuous functions on final coalgebras". 27 | -- Note that we are supporting weighted sets, similar to theirs, 28 | -- in order to support induction over weights of input, 29 | -- e.g. on bytestring input we can do induction over the length 30 | -- of the bytestring. 31 | 32 | -- Finally, they are a lot like automata: states are sessions, 33 | -- acceptors are leaves, transitions correspond to children. 34 | 35 | infixr 4 _∼_ 36 | infixr 6 _⊕_ 37 | infixr 7 _&_ _&*_ 38 | 39 | -- Weighting for a set 40 | 41 | Weighted : Set → Set 42 | Weighted A = A → Natural 43 | 44 | -- Discrete weighting function 45 | 46 | δ : ∀ {A} → (Weighted A) 47 | δ a = # 1 48 | 49 | -- Sessions are trees of weighted sets 50 | 51 | data Session : Set₁ where 52 | I : Session 53 | Σ : {A : Set} → (W : Weighted A) → (F : ∞ (A → Session)) → Session 54 | 55 | -- Equivalence of sessions 56 | 57 | data _∼_ : Session → Session → Set₁ where 58 | I : I ∼ I 59 | Σ : {A : Set} → (W : Weighted A) → {F₁ F₂ : ∞ (A → Session)} → 60 | ∞ (∀ a → ♭ F₁ a ∼ ♭ F₂ a) → (Σ W F₁ ∼ Σ W F₂) 61 | 62 | ∼-refl : ∀ {S} → (S ∼ S) 63 | ∼-refl {I} = I 64 | ∼-refl {Σ V F} = Σ V (♯ λ a → ∼-refl {♭ F a}) 65 | 66 | ∼-sym : ∀ {S T} → (S ∼ T) → (T ∼ S) 67 | ∼-sym I = I 68 | ∼-sym (Σ V F) = Σ V (♯ λ a → ∼-sym (♭ F a)) 69 | 70 | ∼-trans : ∀ {S T U} → (S ∼ T) → (T ∼ U) → (S ∼ U) 71 | ∼-trans I I = I 72 | ∼-trans (Σ V F) (Σ .V G) = Σ V (♯ λ a → ∼-trans (♭ F a) (♭ G a)) 73 | 74 | -- Inital alphabet 75 | 76 | Γ : Session → Set 77 | Γ I = ⊥ 78 | Γ (Σ {A} W F) = A 79 | 80 | Δ : ∀ S → (Weighted (Γ S)) 81 | Δ I () 82 | Δ (Σ W F) a = W a 83 | 84 | _/_ : ∀ S → (Γ S) → Session 85 | I / () 86 | (Σ W F) / a = ♭ F a 87 | 88 | -- IsI S is inhabited whenever S ≡ I 89 | 90 | IsI : Session → Set 91 | IsI I = ⊤ 92 | IsI (Σ V F) = ⊥ 93 | 94 | -- IsΣ S is inhabited whenever S is of the form Σ V F 95 | 96 | IsΣ : Session → Set 97 | IsΣ I = ⊥ 98 | IsΣ (Σ V F) = ⊤ 99 | 100 | -- IsΣ respects ≡. 101 | 102 | IsΣ-≡ : ∀ {S} {isΣ : IsΣ S} {T} → (S ≡ T) → (IsΣ T) 103 | IsΣ-≡ {Σ V F} refl = tt 104 | IsΣ-≡ {I} {} refl 105 | 106 | -- Singletons 107 | 108 | ⟨_w/_⟩ : (A : Set) → (Weighted A) → Session 109 | ⟨ A w/ W ⟩ = Σ W (♯ λ a → I) 110 | 111 | ⟨_⟩ : Set → Session 112 | ⟨ A ⟩ = ⟨ A w/ δ ⟩ 113 | 114 | -- Sequencing 115 | 116 | _&_ : Session → Session → Session 117 | I & T = T 118 | (Σ V F) & T = Σ V (♯ λ a → ♭ F a & T) 119 | 120 | -- Units and associativity 121 | 122 | unit₁ : ∀ {S} → (I & S ∼ S) 123 | unit₁ = ∼-refl 124 | 125 | unit₂ : ∀ {S} → (S & I ∼ S) 126 | unit₂ {I} = I 127 | unit₂ {Σ V F} = Σ V (♯ λ a → unit₂ {♭ F a}) 128 | 129 | assoc : ∀ {S T U} → (S & (T & U) ∼ (S & T) & U) 130 | assoc {I} = ∼-refl 131 | assoc {Σ V F} = Σ V (♯ λ a → assoc {♭ F a}) 132 | 133 | -- Lazy choice 134 | 135 | _+_ : Session → Session → Session 136 | S + T = Σ δ (♯ λ b → if b then S else T) 137 | 138 | -- Strict choice 139 | 140 | _⊕_ : Session → Session → Session 141 | I ⊕ T = I 142 | S ⊕ I = I 143 | S ⊕ T = S + T 144 | 145 | -- Lazy option 146 | 147 | ¿ : Session → Session 148 | ¿ S = S + I 149 | 150 | -- Lazy Kleene star 151 | 152 | -- It would be nice if I could just define * S = ¿ (S & * S), 153 | -- but that doesn't pass the termination checker, so I have 154 | -- to expand out the definition. 155 | 156 | hd : Session → Set 157 | hd I = Bool 158 | hd (Σ {A} W F) = A 159 | 160 | wt : ∀ S → (Weighted (hd S)) 161 | wt I = δ 162 | wt (Σ W F) = W 163 | 164 | mutual 165 | 166 | tl : ∀ S T → (hd S) → Session 167 | tl I T true = T &* T 168 | tl I T false = I 169 | tl (Σ W F) T a = (♭ F a) &* T 170 | 171 | _&*_ : Session → Session → Session 172 | S &* T = Σ (wt S) (♯ tl S T) 173 | 174 | * : Session → Session 175 | * S = I &* S 176 | 177 | + : Session → Session 178 | + S = S &* S 179 | 180 | -- Bytes 181 | 182 | Bytes' : Session 183 | Bytes' = + ⟨ ByteString strict w/ length ⟩ 184 | 185 | Bytes : Session 186 | Bytes = * ⟨ ByteString strict w/ length ⟩ 187 | 188 | -- TODO: weight strings by their length? 189 | 190 | Strings' : Session 191 | Strings' = + ⟨ String ⟩ 192 | 193 | Strings : Session 194 | Strings = * ⟨ String ⟩ 195 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties/Equivalences.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♯_ ) 2 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; subst ) 3 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; ⟦_⟧ ; _≃_ ) 4 | open import System.IO.Transducers.Strict using ( Strict ) 5 | open import System.IO.Transducers.Session using ( Session ; I ; Σ ; _/_ ) 6 | open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ ; _✓ ; _⊑_ ) 7 | open import System.IO.Transducers.Properties.Lemmas using ( I-η ; ⟦⟧-mono ; ⟦⟧-resp-✓ ; ⟦⟧-resp-[] ) 8 | open import System.IO.Transducers.Properties.Category using ( _≣_ ; ⟦⟧-refl-≣ ) 9 | 10 | module System.IO.Transducers.Properties.Equivalences where 11 | 12 | open Relation.Binary.PropositionalEquality.≡-Reasoning 13 | 14 | _//_ : ∀ S → (Trace S) → Session 15 | S // [] = S 16 | S // (a ∷ as) = (S / a) // as 17 | 18 | suffix : ∀ {S} {as bs : Trace S} → (as ⊑ bs) → (Trace (S // as)) 19 | suffix {bs = bs} [] = bs 20 | suffix (a ∷ as⊑bs) = suffix as⊑bs 21 | 22 | _+++_ : ∀ {S} (as : Trace S) (bs : Trace (S // as)) → (Trace S) 23 | [] +++ bs = bs 24 | (a ∷ as) +++ bs = a ∷ (as +++ bs) 25 | 26 | suffix-+++ : ∀ {S} {as : Trace S} {bs} (as⊑bs : as ⊑ bs) → 27 | as +++ suffix as⊑bs ≡ bs 28 | suffix-+++ [] = refl 29 | suffix-+++ (a ∷ as⊑bs) = cong (_∷_ a) (suffix-+++ as⊑bs) 30 | 31 | suffix-mono : ∀ {S} {as : Trace S} {bs cs} (as⊑bs : as ⊑ bs) (as⊑cs : as ⊑ cs) → 32 | (bs ⊑ cs) → (suffix as⊑bs ⊑ suffix as⊑cs) 33 | suffix-mono [] [] bs⊑cs = bs⊑cs 34 | suffix-mono (.a ∷ as⊑bs) (.a ∷ as⊑cs) (a ∷ bs⊑cs) = suffix-mono as⊑bs as⊑cs bs⊑cs 35 | 36 | suffix-resp-✓ : ∀ {S} {as : Trace S} {bs} (as⊑bs : as ⊑ bs) → 37 | (bs ✓) → (suffix as⊑bs ✓) 38 | suffix-resp-✓ [] bs✓ = bs✓ 39 | suffix-resp-✓ (.a ∷ as⊑bs) (a ∷ bs✓) = suffix-resp-✓ as⊑bs bs✓ 40 | 41 | suffix-[] : ∀ {S} {as : Trace S} (as⊑as : as ⊑ as) → 42 | (suffix as⊑as ≡ []) 43 | suffix-[] [] = refl 44 | suffix-[] (a ∷ as⊑as) = suffix-[] as⊑as 45 | 46 | strictify : ∀ {S T} (f : Trace S → Trace T) → 47 | (∀ as bs → as ⊑ bs → f as ⊑ f bs) → 48 | (Trace S → Trace (T // f [])) 49 | strictify f f-mono as = suffix (f-mono [] as []) 50 | 51 | lazify : ∀ {S T} (f : Trace S → Trace T) a → 52 | (Trace (S / a) → Trace T) 53 | lazify f a as = f (a ∷ as) 54 | 55 | strictify-mono : ∀ {S T} (f : Trace S → Trace T) f-mono → 56 | (∀ as bs → as ⊑ bs → strictify f f-mono as ⊑ strictify f f-mono bs) 57 | strictify-mono f f-mono as bs as⊑bs = suffix-mono (f-mono [] as []) (f-mono [] bs []) (f-mono as bs as⊑bs) 58 | 59 | strictify-resp-✓ : ∀ {S T} (f : Trace S → Trace T) f-mono → 60 | (∀ as → as ✓ → f as ✓) → 61 | (∀ as → as ✓ → strictify f f-mono as ✓) 62 | strictify-resp-✓ f f-mono f-resp-✓ as as✓ = suffix-resp-✓ (f-mono [] as []) (f-resp-✓ as as✓) 63 | 64 | strictify-strict : ∀ {S T} (f : Trace S → Trace T) f-mono → 65 | (strictify f f-mono [] ≡ []) 66 | strictify-strict f f-mono = suffix-[] (f-mono [] [] []) 67 | 68 | lazify-mono : ∀ {S T} (f : Trace S → Trace T) a → 69 | (∀ as bs → as ⊑ bs → f as ⊑ f bs) → 70 | (∀ as bs → as ⊑ bs → lazify f a as ⊑ lazify f a bs) 71 | lazify-mono f a f-mono as bs as⊑bs = f-mono (a ∷ as) (a ∷ bs) (a ∷ as⊑bs) 72 | 73 | lazify-resp-✓ : ∀ {S T} (f : Trace S → Trace T) a → 74 | (∀ as → as ✓ → f as ✓) → 75 | (∀ as → as ✓ → lazify f a as ✓) 76 | lazify-resp-✓ f a f-resp-✓ as as✓ = f-resp-✓ (a ∷ as) (a ∷ as✓) 77 | 78 | mutual 79 | 80 | lazy' : ∀ {T S} bs (f : Trace S → Trace (T // bs)) → 81 | (∀ as bs → as ⊑ bs → f as ⊑ f bs) → 82 | (∀ as → as ✓ → f as ✓) → (f [] ≡ []) → 83 | (S ⇒ T) 84 | lazy' [] f f-mono f-resp-✓ f-strict = strict f f-mono f-resp-✓ f-strict 85 | lazy' {Σ V F} (b ∷ bs) f f-mono f-resp-✓ f-strict = out b (lazy' bs f f-mono f-resp-✓ f-strict) 86 | lazy' {I} (() ∷ bs) f f-mono f-resp-✓ f-strict 87 | 88 | lazy : ∀ {T S} (f : Trace S → Trace T) → 89 | (∀ as bs → as ⊑ bs → f as ⊑ f bs) → 90 | (∀ as → as ✓ → f as ✓) → 91 | (S ⇒ T) 92 | lazy f f-mono f-resp-✓ = lazy' (f []) (strictify f f-mono) (strictify-mono f f-mono) (strictify-resp-✓ f f-mono f-resp-✓) (strictify-strict f f-mono) 93 | 94 | strict : ∀ {S T} (f : Trace S → Trace T) → 95 | (∀ as bs → as ⊑ bs → f as ⊑ f bs) → 96 | (∀ as → as ✓ → f as ✓) → (f [] ≡ []) → 97 | (S ⇒ T) 98 | strict {I} {I} f f-mono f-resp-✓ f-strict = done 99 | strict {Σ V F} f f-mono f-resp-✓ f-strict = inp (♯ λ a → lazy (lazify f a) (lazify-mono f a f-mono) (lazify-resp-✓ f a f-resp-✓)) 100 | strict {I} {Σ W G} f f-mono f-resp-✓ f-strict with subst _✓ f-strict (f-resp-✓ [] []) 101 | strict {I} {Σ W G} f f-mono f-resp-✓ f-strict | () 102 | 103 | mutual 104 | 105 | lazy'-⟦⟧ : ∀ {T S} bs (f : Trace S → Trace (T // bs)) f-mono f-resp-✓ f-strict → 106 | ∀ as → ⟦ lazy' bs f f-mono f-resp-✓ f-strict ⟧ as ≡ bs +++ f as 107 | lazy'-⟦⟧ [] f f-mono f-resp-✓ f-strict as = strict-⟦⟧ f f-mono f-resp-✓ f-strict as 108 | lazy'-⟦⟧ {Σ W G} (b ∷ bs) f f-mono f-resp-✓ f-strict as = cong (_∷_ b) (lazy'-⟦⟧ bs f f-mono f-resp-✓ f-strict as) 109 | lazy'-⟦⟧ {I} (() ∷ bs) f f-mono f-resp-✓ f-strict as 110 | 111 | lazy-⟦⟧ : ∀ {S T} (f : Trace S → Trace T) f-mono f-resp-✓ → 112 | ⟦ lazy f f-mono f-resp-✓ ⟧ ≃ f 113 | lazy-⟦⟧ f f-mono f-resp-✓ as = 114 | begin 115 | ⟦ lazy f f-mono f-resp-✓ ⟧ as 116 | ≡⟨ lazy'-⟦⟧ (f []) (strictify f f-mono) (strictify-mono f f-mono) (strictify-resp-✓ f f-mono f-resp-✓) (strictify-strict f f-mono) as ⟩ 117 | f [] +++ strictify f f-mono as 118 | ≡⟨ suffix-+++ (f-mono [] as []) ⟩ 119 | f as 120 | ∎ 121 | 122 | strict-⟦⟧ : ∀ {S T} (f : Trace S → Trace T) f-mono f-resp-✓ f-strict → 123 | ⟦ strict f f-mono f-resp-✓ f-strict ⟧ ≃ f 124 | strict-⟦⟧ {I} {I} f f-mono f-resp-✓ f-strict [] = sym (I-η (f [])) 125 | strict-⟦⟧ {Σ V F} f f-mono f-resp-✓ f-strict [] = sym f-strict 126 | strict-⟦⟧ {Σ V F} f f-mono f-resp-✓ f-strict (a ∷ as) = lazy-⟦⟧ (lazify f a) (lazify-mono f a f-mono) (lazify-resp-✓ f a f-resp-✓) as 127 | strict-⟦⟧ {I} {Σ W G} f f-mono f-resp-✓ f-strict as with subst _✓ f-strict (f-resp-✓ [] []) 128 | strict-⟦⟧ {I} {Σ W G} f f-mono f-resp-✓ f-strict as | () 129 | strict-⟦⟧ {I} f f-mono f-resp-✓ f-strict (() ∷ as) 130 | 131 | ⟦⟧-lazy : ∀ {S T} (P : S ⇒ T) → 132 | lazy ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) ≣ P 133 | ⟦⟧-lazy P = ⟦⟧-refl-≣ (lazy ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P)) P (lazy-⟦⟧ ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P)) 134 | 135 | ⟦⟧-strict : ∀ {S T} (P : S ⇒ T) (#P : Strict P) → 136 | strict ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P) ≣ P 137 | ⟦⟧-strict P #P = ⟦⟧-refl-≣ (strict ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P)) P (strict-⟦⟧ ⟦ P ⟧ (⟦⟧-mono P) (⟦⟧-resp-✓ P) (⟦⟧-resp-[] #P)) 138 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties/Lemmas.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♭ ; ♯_ ) 2 | open import Data.Empty using ( ⊥-elim ) 3 | open import System.IO.Transducers.Session using ( Session ; I ; Σ ; IsΣ ; Γ ; _/_ ; _∼_ ) 4 | open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ ; _⊨_✓ ; _✓ ; _⊑_ ) 5 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; ⟦_⟧ ; _≃_ ; equiv ) 6 | open import System.IO.Transducers.Reflective using ( Reflective ; inp ; out ; done ) 7 | open import System.IO.Transducers.Strict using ( Strict ; inp ; done ) 8 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; trans ; cong ) 9 | open import Relation.Nullary using ( Dec ; ¬_ ; yes ; no ) 10 | 11 | module System.IO.Transducers.Properties.Lemmas where 12 | 13 | open Relation.Binary.PropositionalEquality.≡-Reasoning 14 | 15 | -- ≃ is an equivalence 16 | 17 | ≃-refl : ∀ {S T} {f : Trace S → Trace T} → (f ≃ f) 18 | ≃-refl as = refl 19 | 20 | ≃-sym : ∀ {S T} {f g : Trace S → Trace T} → 21 | (f ≃ g) → (g ≃ f) 22 | ≃-sym f≃g as = sym (f≃g as) 23 | 24 | ≃-trans : ∀ {S T} {f g h : Trace S → Trace T} → 25 | (f ≃ g) → (g ≃ h) → (f ≃ h) 26 | ≃-trans f≃g g≃h as = trans (f≃g as) (g≃h as) 27 | 28 | -- Completion is decidable 29 | 30 | ✓-tl : ∀ {S a as} → (S ⊨ a ∷ as ✓) → (S / a ⊨ as ✓) 31 | ✓-tl (a ∷ as✓) = as✓ 32 | 33 | ✓? : ∀ {S} as → (Dec (S ⊨ as ✓)) 34 | ✓? {I} [] = yes [] 35 | ✓? {Σ V F} [] = no (λ ()) 36 | ✓? (a ∷ as) with ✓? as 37 | ✓? (a ∷ as) | yes as✓ = yes (a ∷ as✓) 38 | ✓? (a ∷ as) | no ¬as✓ = no (λ a∷as✓ → ¬as✓ (✓-tl a∷as✓)) 39 | 40 | -- Eta conversion for traces of type I 41 | 42 | I-η : ∀ (as : Trace I) → (as ≡ []) 43 | I-η [] = refl 44 | I-η (() ∷ as) 45 | 46 | -- All traces at type I are complete 47 | 48 | I-✓ : ∀ (as : Trace I) → (as ✓) 49 | I-✓ [] = [] 50 | I-✓ (() ∷ as) 51 | 52 | -- Cons is invertable 53 | 54 | ∷-refl-≡₁ : ∀ {S a b} {as bs : Trace S} {cs ds} → 55 | (as ≡ a ∷ cs) → (bs ≡ b ∷ ds) → (as ≡ bs) → (a ≡ b) 56 | ∷-refl-≡₁ refl refl refl = refl 57 | 58 | ∷-refl-≡₂ : ∀ {S a} {as bs : Trace S} {cs ds} → 59 | (as ≡ a ∷ cs) → (bs ≡ a ∷ ds) → (as ≡ bs) → (cs ≡ ds) 60 | ∷-refl-≡₂ refl refl refl = refl 61 | 62 | -- Make a function reflective 63 | 64 | liat : ∀ {S} → (Trace S) → (Trace S) 65 | liat [] = [] 66 | liat (a ∷ []) = [] 67 | liat (a ∷ b ∷ bs) = a ∷ liat (b ∷ bs) 68 | 69 | incomplete : ∀ {S} → (Trace S) → (Trace S) 70 | incomplete as with ✓? as 71 | incomplete as | yes ✓as = liat as 72 | incomplete as | no ¬✓as = as 73 | 74 | reflective : ∀ {S T} → (Trace S → Trace T) → (Trace S → Trace T) 75 | reflective f as with ✓? as 76 | reflective f as | yes ✓as = f as 77 | reflective f as | no ¬✓as = incomplete (f as) 78 | 79 | liat-¬✓ : ∀ {S} a as → ¬ (S ⊨ liat (a ∷ as) ✓) 80 | liat-¬✓ a (b ∷ bs) (.a ∷ ✓cs) = liat-¬✓ b bs ✓cs 81 | liat-¬✓ {I} () [] []✓ 82 | liat-¬✓ {Σ V F} a [] () 83 | 84 | incomplete-¬✓ : ∀ {S} {isΣ : IsΣ S} (as : Trace S) → ¬ (incomplete as ✓) 85 | incomplete-¬✓ as with ✓? as 86 | incomplete-¬✓ {I} {} [] | yes [] 87 | incomplete-¬✓ {Σ V F} [] | yes () 88 | incomplete-¬✓ (a ∷ as) | yes ✓a∷as = liat-¬✓ a as 89 | incomplete-¬✓ as | no ¬✓as = ¬✓as 90 | 91 | reflective-refl-✓ : ∀ {S T} {isΣ : IsΣ T} (f : Trace S → Trace T) as → (reflective f as ✓) → (as ✓) 92 | reflective-refl-✓ f as ✓bs with ✓? as 93 | reflective-refl-✓ f as ✓bs | yes ✓as = ✓as 94 | reflective-refl-✓ {S} {Σ V F} f as ✓bs | no ¬✓as = ⊥-elim (incomplete-¬✓ (f as) ✓bs) 95 | reflective-refl-✓ {S} {I} {} f as ✓bs | no ¬✓as 96 | 97 | reflective-≡-✓ : ∀ {S T} (f : Trace S → Trace T) {as} → (as ✓) → (reflective f as ≡ f as) 98 | reflective-≡-✓ f {as} ✓as with ✓? as 99 | reflective-≡-✓ f {as} ✓as | yes _ = refl 100 | reflective-≡-✓ f {as} ✓as | no ¬✓as = ⊥-elim (¬✓as ✓as) 101 | 102 | -- All transducers are monotone 103 | 104 | ⟦⟧-mono : ∀ {S T} (P : S ⇒ T) as bs → (as ⊑ bs) → (⟦ P ⟧ as ⊑ ⟦ P ⟧ bs) 105 | ⟦⟧-mono (inp P) .[] bs [] = [] 106 | ⟦⟧-mono (inp P) (.a ∷ as) (.a ∷ bs) (a ∷ as⊑bs) = ⟦⟧-mono (♭ P a) as bs as⊑bs 107 | ⟦⟧-mono (out b P) as bs as⊑bs = b ∷ (⟦⟧-mono P as bs as⊑bs) 108 | ⟦⟧-mono done as bs as⊑bs = as⊑bs 109 | 110 | -- All transducers respect completion 111 | 112 | ⟦⟧-resp-✓ : ∀ {S T} (P : S ⇒ T) as → (as ✓) → (⟦ P ⟧ as ✓) 113 | ⟦⟧-resp-✓ (inp P) (a ∷ as) (.a ∷ ✓as) = ⟦⟧-resp-✓ (♭ P a) as ✓as 114 | ⟦⟧-resp-✓ (out b P) as ✓as = b ∷ ⟦⟧-resp-✓ P as ✓as 115 | ⟦⟧-resp-✓ done as ✓as = ✓as 116 | ⟦⟧-resp-✓ (inp P) [] () 117 | 118 | -- Reflective transducers reflect completion 119 | 120 | ⟦⟧-refl-✓ : ∀ {S T} {P : S ⇒ T} → (Reflective P) → ∀ as → (⟦ P ⟧ as ✓) → (as ✓) 121 | ⟦⟧-refl-✓ (inp ⟳P) (a ∷ as) bs✓ = a ∷ ⟦⟧-refl-✓ (♭ ⟳P a) as bs✓ 122 | ⟦⟧-refl-✓ (out b ⟳P) as bs✓ = ⟦⟧-refl-✓ ⟳P as (✓-tl bs✓) 123 | ⟦⟧-refl-✓ done as bs✓ = bs✓ 124 | ⟦⟧-refl-✓ (inp ⟳P) [] () 125 | 126 | -- Any transducer which reflects completion is reflective 127 | 128 | ⟦⟧-refl-✓⁻¹ : ∀ {S T} (P : S ⇒ T) → (∀ as → (⟦ P ⟧ as ✓) → (as ✓)) → (Reflective P) 129 | ⟦⟧-refl-✓⁻¹ {Σ V F} {Σ W G} (inp P) H = inp (♯ λ a → ⟦⟧-refl-✓⁻¹ (♭ P a) (λ as → λ bs✓ → ✓-tl (H (a ∷ as) bs✓))) 130 | ⟦⟧-refl-✓⁻¹ (out b P) H = out b (⟦⟧-refl-✓⁻¹ P (λ as bs✓ → H as (b ∷ bs✓))) 131 | ⟦⟧-refl-✓⁻¹ done H = done 132 | ⟦⟧-refl-✓⁻¹ {Σ V F} {I} (inp P) H with H [] [] 133 | ⟦⟧-refl-✓⁻¹ {Σ V F} {I} (inp P) H | () 134 | 135 | -- Strict transducers respect emptiness. 136 | 137 | ⟦⟧-resp-[] : ∀ {S T} {P : S ⇒ T} → (Strict P) → (⟦ P ⟧ [] ≡ []) 138 | ⟦⟧-resp-[] (inp P) = refl 139 | ⟦⟧-resp-[] done = refl 140 | 141 | -- Any transducer which respects emptiness is strict. 142 | 143 | ⟦⟧-resp-[]⁻¹ : ∀ {S T} (P : S ⇒ T) → (∀ {as} → (as ≡ []) → (⟦ P ⟧ as ≡ [])) → (Strict P) 144 | ⟦⟧-resp-[]⁻¹ (inp P) H = inp P 145 | ⟦⟧-resp-[]⁻¹ (out b P) H with H refl 146 | ⟦⟧-resp-[]⁻¹ (out b P) H | () 147 | ⟦⟧-resp-[]⁻¹ done H = done 148 | 149 | -- Coherence wrt ∼ 150 | 151 | ⟦⟧-resp-∼ : ∀ {S T} (eq₁ eq₂ : S ∼ T) → ⟦ equiv eq₁ ⟧ ≃ ⟦ equiv eq₂ ⟧ 152 | ⟦⟧-resp-∼ I I as = refl 153 | ⟦⟧-resp-∼ (Σ V F) (Σ .V G) [] = refl 154 | ⟦⟧-resp-∼ (Σ V F) (Σ .V G) (a ∷ as) = cong (_∷_ a) (⟦⟧-resp-∼ (♭ F a) (♭ G a) as) 155 | 156 | -- IsEquiv P is inhabited whenever P is equivalent to an equivalence 157 | 158 | data IsEquiv {S T : Session} (P : S ⇒ T) : Set₁ where 159 | isEquiv : (S∼T : S ∼ T) → (⟦ P ⟧ ≃ ⟦ equiv S∼T ⟧) → (IsEquiv P) 160 | 161 | -- Equivalences are equivalent 162 | 163 | ≃-equiv : ∀ {S T} {P Q : S ⇒ T} → (IsEquiv P) → (IsEquiv Q) → (⟦ P ⟧ ≃ ⟦ Q ⟧) 164 | ≃-equiv {S} {T} {P} {Q} (isEquiv eq₁ P≃eq₁) (isEquiv eq₂ Q≃eq₂) as = 165 | begin 166 | ⟦ P ⟧ as 167 | ≡⟨ P≃eq₁ as ⟩ 168 | ⟦ equiv eq₁ ⟧ as 169 | ≡⟨ ⟦⟧-resp-∼ eq₁ eq₂ as ⟩ 170 | ⟦ equiv eq₂ ⟧ as 171 | ≡⟨ sym (Q≃eq₂ as) ⟩ 172 | ⟦ Q ⟧ as 173 | ∎ 174 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties/Category.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ∞ ; ♯_ ; ♭ ) 2 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ) 3 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; _⟫_ ; ⟦_⟧ ; _≃_ ; equiv ) 4 | open import System.IO.Transducers.Session using ( Session ; I ; Σ ; _∼_ ; ∼-refl ; ∼-trans ) 5 | open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ ) 6 | open import System.IO.Transducers.Properties.Lemmas using ( ⟦⟧-resp-∼ ; ≃-refl ; ≃-sym ; IsEquiv ; isEquiv ; ≃-equiv ; ∷-refl-≡₁ ; ∷-refl-≡₂ ) 7 | 8 | module System.IO.Transducers.Properties.Category where 9 | 10 | open Relation.Binary.PropositionalEquality.≡-Reasoning 11 | 12 | infixr 6 _⟦⟫⟧_ 13 | 14 | -- Coinductive equivalence of programs, note that in the 15 | -- case where done has type I ⇒ I, this is syntactic 16 | -- identity. 17 | 18 | data _⇒_⊨_≣_ : ∀ S T (P Q : S ⇒ T) → Set₁ where 19 | inp : ∀ {A V F T P Q} → ∞ (∀ a → ♭ F a ⇒ T ⊨ ♭ P a ≣ ♭ Q a) → 20 | (Σ {A} V F ⇒ T ⊨ inp P ≣ inp Q) 21 | out : ∀ {B W G S} b {P Q} → (S ⇒ ♭ G b ⊨ P ≣ Q) → 22 | (S ⇒ Σ {B} W G ⊨ out b P ≣ out b Q) 23 | done : ∀ {S} → 24 | (S ⇒ S ⊨ done ≣ done) 25 | inp-done : ∀ {A V F P} → ∞ (∀ a → ♭ F a ⇒ Σ V F ⊨ ♭ P a ≣ out a done) → 26 | (Σ {A} V F ⇒ Σ V F ⊨ inp P ≣ done) 27 | done-inp : ∀ {A V F P} → ∞ (∀ a → ♭ F a ⇒ Σ V F ⊨ out a done ≣ ♭ P a) → 28 | (Σ {A} V F ⇒ Σ V F ⊨ done ≣ inp P) 29 | 30 | _≣_ : ∀ {S T} (P Q : S ⇒ T) → Set₁ 31 | P ≣ Q = _ ⇒ _ ⊨ P ≣ Q 32 | 33 | -- Coinductive equivalence implies semantic equivalence 34 | 35 | ⟦⟧-resp-≣ : ∀ {S T} {P Q : S ⇒ T} → (P ≣ Q) → (⟦ P ⟧ ≃ ⟦ Q ⟧) 36 | ⟦⟧-resp-≣ (inp P≣Q) [] = refl 37 | ⟦⟧-resp-≣ (inp P≣Q) (a ∷ as) = ⟦⟧-resp-≣ (♭ P≣Q a) as 38 | ⟦⟧-resp-≣ (out b P≣Q) as = cong (_∷_ b) (⟦⟧-resp-≣ P≣Q as) 39 | ⟦⟧-resp-≣ done as = refl 40 | ⟦⟧-resp-≣ (inp-done P≣outadone) [] = refl 41 | ⟦⟧-resp-≣ (inp-done P≣outadone) (a ∷ as) = ⟦⟧-resp-≣ (♭ P≣outadone a) as 42 | ⟦⟧-resp-≣ (done-inp outadone≣P) [] = refl 43 | ⟦⟧-resp-≣ (done-inp outadone≣P) (a ∷ as) = ⟦⟧-resp-≣ (♭ outadone≣P a) as 44 | 45 | -- Semantic equivalence implies coinductive equivalence 46 | 47 | ⟦⟧-refl-≣ : ∀ {S T} (P Q : S ⇒ T) → (⟦ P ⟧ ≃ ⟦ Q ⟧) → (P ≣ Q) 48 | ⟦⟧-refl-≣ (inp P) (inp Q) P≃Q = inp (♯ λ a → ⟦⟧-refl-≣ (♭ P a) (♭ Q a) (λ as → P≃Q (a ∷ as))) 49 | ⟦⟧-refl-≣ (inp P) done P≃Q = inp-done (♯ λ a → ⟦⟧-refl-≣ (♭ P a) (out a done) (λ as → P≃Q (a ∷ as))) 50 | ⟦⟧-refl-≣ (out b P) (out c Q) P≃Q with ∷-refl-≡₁ refl refl (P≃Q []) 51 | ⟦⟧-refl-≣ (out b P) (out .b Q) P≃Q | refl = out b (⟦⟧-refl-≣ P Q (λ as → ∷-refl-≡₂ refl refl (P≃Q as))) 52 | ⟦⟧-refl-≣ done (inp Q) P≃Q = done-inp (♯ λ a → ⟦⟧-refl-≣ (out a done) (♭ Q a) (λ as → P≃Q (a ∷ as))) 53 | ⟦⟧-refl-≣ done done P≃Q = done 54 | ⟦⟧-refl-≣ (inp P) (out b Q) P≃Q with P≃Q [] 55 | ⟦⟧-refl-≣ (inp P) (out b Q) P≃Q | () 56 | ⟦⟧-refl-≣ (out b P) (inp Q) P≃Q with P≃Q [] 57 | ⟦⟧-refl-≣ (out b P) (inp Q) P≃Q | () 58 | ⟦⟧-refl-≣ (out b P) done P≃Q with P≃Q [] 59 | ⟦⟧-refl-≣ (out b P) done P≃Q | () 60 | ⟦⟧-refl-≣ done (out b Q) P≃Q with P≃Q [] 61 | ⟦⟧-refl-≣ done (out b Q) P≃Q | () 62 | 63 | -- Trace semantics of identity 64 | 65 | ⟦done⟧ : ∀ {S} → (Trace S) → (Trace S) 66 | ⟦done⟧ as = as 67 | 68 | done-semantics : ∀ {S} → ⟦ done {S} ⟧ ≃ ⟦done⟧ 69 | done-semantics as = refl 70 | 71 | -- Trace semantics of composition 72 | 73 | _⟦⟫⟧_ : ∀ {S T U} → 74 | (f : Trace S → Trace T) → (g : Trace T → Trace U) → 75 | (Trace S) → (Trace U) 76 | (f ⟦⟫⟧ g) as = g (f as) 77 | 78 | ⟫-semantics : ∀ {S T U} (P : S ⇒ T) (Q : T ⇒ U) → 79 | (⟦ P ⟫ Q ⟧ ≃ ⟦ P ⟧ ⟦⟫⟧ ⟦ Q ⟧) 80 | ⟫-semantics (inp P) (inp Q) [] = refl 81 | ⟫-semantics (inp P) (inp Q) (a ∷ as) = ⟫-semantics (♭ P a) (inp Q) as 82 | ⟫-semantics (inp P) (out c Q) as = cong (_∷_ c) (⟫-semantics (inp P) Q as) 83 | ⟫-semantics (inp P) done as = refl 84 | ⟫-semantics (out b P) (inp Q) as = ⟫-semantics P (♭ Q b) as 85 | ⟫-semantics (out b P) (out c Q) as = cong (_∷_ c) (⟫-semantics (out b P) Q as) 86 | ⟫-semantics (out b P) done as = refl 87 | ⟫-semantics done Q as = refl 88 | 89 | ⟫-≃-⟦⟫⟧ : ∀ {S T U} 90 | {P : S ⇒ T} {f : Trace S → Trace T} {Q : T ⇒ U} {g : Trace T → Trace U} → 91 | (⟦ P ⟧ ≃ f) → (⟦ Q ⟧ ≃ g) → (⟦ P ⟫ Q ⟧ ≃ f ⟦⟫⟧ g) 92 | ⟫-≃-⟦⟫⟧ {S} {T} {U} {P} {f} {Q} {g} P≃f Q≃g as = 93 | begin 94 | ⟦ P ⟫ Q ⟧ as 95 | ≡⟨ ⟫-semantics P Q as ⟩ 96 | ⟦ Q ⟧ (⟦ P ⟧ as) 97 | ≡⟨ cong ⟦ Q ⟧ (P≃f as) ⟩ 98 | ⟦ Q ⟧ (f as) 99 | ≡⟨ Q≃g (f as) ⟩ 100 | g (f as) 101 | ∎ 102 | 103 | -- Composition respects ≃ 104 | 105 | ⟫-resp-≃ : ∀ {S T U} {P₁ P₂ : S ⇒ T} {Q₁ Q₂ : T ⇒ U} → 106 | (⟦ P₁ ⟧ ≃ ⟦ P₂ ⟧) → (⟦ Q₁ ⟧ ≃ ⟦ Q₂ ⟧) → 107 | (⟦ P₁ ⟫ Q₁ ⟧ ≃ ⟦ P₂ ⟫ Q₂ ⟧) 108 | ⟫-resp-≃ {S} {T} {U} {P₁} {P₂} {Q₁} {Q₂} P₁≃P₂ Q₁≃Q₂ as = 109 | begin 110 | ⟦ P₁ ⟫ Q₁ ⟧ as 111 | ≡⟨ ⟫-≃-⟦⟫⟧ P₁≃P₂ Q₁≃Q₂ as ⟩ 112 | (⟦ P₂ ⟧ ⟦⟫⟧ ⟦ Q₂ ⟧) as 113 | ≡⟨ sym (⟫-semantics P₂ Q₂ as) ⟩ 114 | ⟦ P₂ ⟫ Q₂ ⟧ as 115 | ∎ 116 | 117 | -- Left identity of composition 118 | 119 | ⟫-identity₁ : ∀ {S T} (P : S ⇒ T) → ⟦ done ⟫ P ⟧ ≃ ⟦ P ⟧ 120 | ⟫-identity₁ P = ⟫-semantics done P 121 | 122 | -- Right identity of composition 123 | 124 | ⟫-identity₂ : ∀ {S T} (P : S ⇒ T) → ⟦ P ⟫ done ⟧ ≃ ⟦ P ⟧ 125 | ⟫-identity₂ P = ⟫-semantics P done 126 | 127 | -- Associativity of composition 128 | 129 | ⟫-assoc : ∀ {S T U V} (P : S ⇒ T) (Q : T ⇒ U) (R : U ⇒ V) → 130 | ⟦ (P ⟫ Q) ⟫ R ⟧ ≃ ⟦ P ⟫ (Q ⟫ R) ⟧ 131 | ⟫-assoc P Q R as = 132 | begin 133 | ⟦ (P ⟫ Q) ⟫ R ⟧ as 134 | ≡⟨ ⟫-≃-⟦⟫⟧ (⟫-semantics P Q) ≃-refl as ⟩ 135 | (⟦ P ⟧ ⟦⟫⟧ ⟦ Q ⟧ ⟦⟫⟧ ⟦ R ⟧) as 136 | ≡⟨ sym (⟫-≃-⟦⟫⟧ ≃-refl (⟫-semantics Q R) as) ⟩ 137 | ⟦ P ⟫ (Q ⟫ R) ⟧ as 138 | ∎ 139 | 140 | -- Identity is an equivalence 141 | 142 | equiv-resp-done : ∀ {S} → ⟦ done ⟧ ≃ ⟦ equiv (∼-refl {S}) ⟧ 143 | equiv-resp-done {I} as = refl 144 | equiv-resp-done {Σ V F} [] = refl 145 | equiv-resp-done {Σ V F} (a ∷ as) = cong (_∷_ a) (equiv-resp-done as) 146 | 147 | done-isEquiv : ∀ {S} → IsEquiv (done {S}) 148 | done-isEquiv = isEquiv {P = done} ∼-refl equiv-resp-done 149 | 150 | -- Composition respects being an equivalence 151 | 152 | equiv-resp-⟦⟫⟧ : ∀ {S T U} (S∼T : S ∼ T) (T∼U : T ∼ U) → 153 | ⟦ equiv S∼T ⟧ ⟦⟫⟧ ⟦ equiv T∼U ⟧ ≃ ⟦ equiv (∼-trans S∼T T∼U) ⟧ 154 | equiv-resp-⟦⟫⟧ I I as = refl 155 | equiv-resp-⟦⟫⟧ (Σ W F) (Σ .W G) [] = refl 156 | equiv-resp-⟦⟫⟧ (Σ W F) (Σ .W G) (a ∷ as) = cong (_∷_ a) (equiv-resp-⟦⟫⟧ (♭ F a) (♭ G a) as) 157 | 158 | equiv-resp-⟫ : ∀ {S T U} (S∼T : S ∼ T) (T∼U : T ∼ U) → 159 | ⟦ equiv S∼T ⟫ equiv T∼U ⟧ ≃ ⟦ equiv (∼-trans S∼T T∼U) ⟧ 160 | equiv-resp-⟫ S∼T T∼U as = 161 | begin 162 | ⟦ equiv S∼T ⟫ equiv T∼U ⟧ as 163 | ≡⟨ ⟫-semantics (equiv S∼T) (equiv T∼U) as ⟩ 164 | (⟦ equiv S∼T ⟧ ⟦⟫⟧ ⟦ equiv T∼U ⟧) as 165 | ≡⟨ equiv-resp-⟦⟫⟧ S∼T T∼U as ⟩ 166 | ⟦ equiv (∼-trans S∼T T∼U) ⟧ as 167 | ∎ 168 | 169 | ⟫-isEquiv : ∀ {S T U} {P : S ⇒ T} {Q : T ⇒ U} → 170 | (IsEquiv P) → (IsEquiv Q) → (IsEquiv (P ⟫ Q)) 171 | ⟫-isEquiv {S} {T} {U} {P} {Q} (isEquiv S∼T P≃S∼T) (isEquiv (T∼U) (Q≃T∼U)) = 172 | isEquiv (∼-trans S∼T T∼U) λ as → 173 | begin 174 | ⟦ P ⟫ Q ⟧ as 175 | ≡⟨ ⟫-resp-≃ P≃S∼T Q≃T∼U as ⟩ 176 | ⟦ equiv S∼T ⟫ equiv T∼U ⟧ as 177 | ≡⟨ equiv-resp-⟫ S∼T T∼U as ⟩ 178 | ⟦ equiv (∼-trans S∼T T∼U) ⟧ as 179 | ∎ 180 | 181 | -- Equivalences form isos 182 | 183 | equiv-is-iso : ∀ {S T} {P : S ⇒ T} {Q : T ⇒ S} → 184 | (IsEquiv P) → (IsEquiv Q) → ⟦ P ⟫ Q ⟧ ≃ ⟦ done ⟧ 185 | equiv-is-iso PisEq QisEq = 186 | ≃-equiv (⟫-isEquiv PisEq QisEq) done-isEquiv -------------------------------------------------------------------------------- /src/System/IO/Transducers/Stateful.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ∞ ; ♭ ; ♯_ ) 2 | open import Data.Bool using ( Bool ; true ; false ) 3 | open import Data.Nat using ( ℕ ; zero ; suc ) 4 | open import Data.Natural using ( Natural ; # ; % ; _+_ ) 5 | open import Data.Strict using ( Strict ; ! ) 6 | open import System.IO.Transducers.List using ( S⊆S&*T ) 7 | open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; out* ; _[&]_ ; _⟫_ ) 8 | open import System.IO.Transducers.Session using ( I ; Σ ; ⟨_⟩ ; _&_ ; ¿ ; * ; _&*_ ) 9 | open import System.IO.Transducers.Trace using ( [] ; _∷_ ; _≤_ ) 10 | 11 | module System.IO.Transducers.Stateful where 12 | 13 | -- We apply the usual state transformer construction 14 | -- for a premonoial category: morphisms 15 | -- from T to U with state S are just regular morphisms 16 | -- from T & S to U & S. 17 | 18 | -- We are particularly interested in the case where T is I 19 | -- and S is Bytes, since this collapses to Bytes ⇒ U & Bytes, 20 | -- that is, the type for a parser over a byte stream. 21 | 22 | -- The type Bytes ⇒ U & Bytes (or more generally * ⟨ B ⟩ ⇒ U & * ⟨ B ⟩) 23 | -- is the type of an iteratee returning U. 24 | 25 | -- Lookahead. 26 | 27 | -- Lookahead buffers up all input until some output is produced. 28 | -- If the output is (just x), then we discard the buffer, and 29 | -- continue with the process. If the output is nothing, then we 30 | -- return the buffer to the output stream and discard the process. 31 | 32 | lookahead¿' : ∀ {T S S'} → (S' ≤ S) → (S' ⇒ ¿ T & S) → (S' ⇒ ¿ T & S) 33 | lookahead¿' {T} as (inp F) = inp (♯ λ a → lookahead¿' {T} (a ∷ as) (♭ F a)) 34 | lookahead¿' {T} as (out true P) = out true P 35 | lookahead¿' {T} as (out false P) = out false (out* as done) 36 | lookahead¿' {T} as (done) = inp (♯ λ a → lookahead¿' {T} (a ∷ as) (out a done)) 37 | 38 | lookahead¿ : ∀ {T S} → (S ⇒ ¿ T & S) → (S ⇒ ¿ T & S) 39 | lookahead¿ {T} = lookahead¿' {T} [] 40 | 41 | lookahead*' : ∀ {T S S'} → (S' ≤ S) → (S' ⇒ * T & S) → (S' ⇒ * T & S) 42 | lookahead*' {T} as (inp F) = inp (♯ λ a → lookahead*' {T} (a ∷ as) (♭ F a)) 43 | lookahead*' {T} as (out true P) = out true P 44 | lookahead*' {T} as (out false P) = out false (out* as done) 45 | lookahead*' {T} as (done) = inp (♯ λ a → lookahead*' {T} (a ∷ as) (out a done)) 46 | 47 | lookahead* : ∀ {T S} → (S ⇒ * T & S) → (S ⇒ * T & S) 48 | lookahead* {T} = lookahead*' {T} [] 49 | 50 | -- Iteration structure. 51 | 52 | -- Deep breath. 53 | 54 | -- This is the trickiest bit of building a stateful transducer 55 | -- library. The idea is to turn a stateful transducer generating 56 | -- an optional U into a stateful transducer generating many Us. 57 | -- We transform the transducer P into one which runs P, then 58 | -- if P returns nothing, then loop P returns nothing and terminates, and 59 | -- if P returns (just x), then loop P finishes running P, then runs loop P again. 60 | 61 | -- For example, given a function nat? : ℤ → (Maybe ℕ) which 62 | -- such that nat? n = nothing if n < 0 and just n otherwise, 63 | -- we can define: 64 | 65 | -- loop (lookahead (inp (♯ λ n → out (nat? n) done))) : 66 | -- * ⟨ ℤ ⟩ ⇒ * ⟨ ℕ ⟩ & * ⟨ ℤ ⟩ 67 | 68 | -- This transducer will return the longest non-negative prefix 69 | -- of its input, for example on input just 2 ∷ just 5 ∷ just -3 ∷ ... 70 | -- it will produce output just 2 ∷ just 5 ∷ nothing ∷ just -3 ∷ ... 71 | 72 | mutual 73 | 74 | -- This is a remarkably obscure piece of code, given that all its doing is wiring... 75 | 76 | -- The n : ℕ parameter is the induction scheme that gets it all to pass the 77 | -- termination checker. When loop P is used properly, it is with a contracting 78 | -- P, that is one which produces stricly fewer S tokens than it consumes. 79 | -- Without the n parameter, loop P could produce infinite output if P isn't 80 | -- contracting. For example loop (out (just x) done) would just produce the stream 81 | -- (just x) ∷ (just x) ∷ ... without ever consuming any input. With the n parameter 82 | -- we keep track of how many tokens have been consumed. If we ever hit 83 | -- a loop where n==0, we just run P one last time, then terminate. 84 | -- For example, loop (out (just x) done) just produces the trace (just x) ∷ []. 85 | 86 | -- For efficiency, we also pass n around as a Natural, not just an ℕ. When we 87 | -- read input a, we add the weight of a onto n, strictly (in order to 88 | -- avoid potentially keeping a live), discard the previous ℕ and build a new ℕ. 89 | -- It would be nice to have an induction scheme for Natural. 90 | 91 | -- It would be a bit nicer to track statically which processes are contractions, 92 | -- and only allow loop P on contraction maps. 93 | 94 | -- Note that contractions come up in many contexts with treatments of recursion, 95 | -- for example in Plotkin uniformity, they're called strict maps. They're 96 | -- closely related to the notion of guarded recursion which is used in checking 97 | -- productivity of coinductive functions in Agda. 98 | 99 | -- TODO: Find a way to statically enforce contraction and non-expansion maps. 100 | -- Or alternatively, give in and allow coinductive output, 101 | -- and hence lose termination for transducers. 102 | 103 | -- TODO: Present this as a trace structure? Show that 104 | -- it has the expected properties on contracting morphisms. 105 | 106 | -- loop''' 0 P Q R is equivant to P ⟫ Q ⟫ (done ⟨&⟩ loop R) 107 | 108 | loop'''' : ∀ {T T' U S S'} → (Strict Natural) → (U ⇒ S) → (S ⇒ T' & S') → (S' ⇒ ¿ T & S') → (U ⇒ (T' &* T) & S') 109 | loop'''' {T} {T'} (! n) P Q R = loop''' {T} {T'} (% n) n P Q R 110 | 111 | loop''' : ∀ {T T' U S S'} → ℕ → Natural → (U ⇒ S) → (S ⇒ T' & S') → (S' ⇒ ¿ T & S') → (U ⇒ (T' &* T) & S') 112 | loop''' {T} {I} m n P Q R = loop' {T} m n (P ⟫ Q) R R 113 | loop''' {T} {Σ V F} {Σ W G} m n (inp P) (inp Q) R = inp (♯ λ a → loop'''' {T} {Σ V F} (! (n + W a)) (♭ P a) (inp Q) R) 114 | loop''' {T} {Σ V F} m n (out a P) (inp Q) R = loop''' {T} {Σ V F} m n P (♭ Q a) R 115 | loop''' {T} {Σ V F} {Σ W G} m n done (inp P) R = inp (♯ λ a → loop'''' {T} {Σ V F} (! (n + W a)) done (♭ P a) R) 116 | loop''' {T} {Σ V F} m n P (out b Q) R = out b (loop''' {T} {♭ F b} m n P Q R) 117 | loop''' {T} {Σ V F} {Σ W G} m n (inp P) done R = inp (♯ λ a → loop'''' {T} {Σ V F} (! (n + W a)) (♭ P a) done R) 118 | loop''' {T} {Σ V F} m n (out a P) done R = out a (loop''' {T} {♭ F a} m n P done R) 119 | loop''' {T} {Σ V F} m n done done R = inp (♯ λ a → out a (loop'''' {T} {♭ F a} (! (n + (V a))) done done R)) 120 | 121 | -- loop' 0 P Q R is equivalent to P ⟫ Q ⟫ loop R ⟨¿⟩ done 122 | 123 | loop'' : ∀ {T U S S'} → (Strict Natural) → (U ⇒ S) → (S ⇒ ¿ T & S') → (S' ⇒ ¿ T & S') → (U ⇒ * T & S') 124 | loop'' {T} (! n) P Q R = loop' {T} (% n) n P Q R 125 | 126 | loop' : ∀ {T U S S'} → ℕ → Natural → (U ⇒ S) → (S ⇒ ¿ T & S') → (S' ⇒ ¿ T & S') → (U ⇒ * T & S') 127 | loop' {T} {Σ V F} m n (inp P) (inp Q) R = inp (♯ λ a → loop'' {T} (! (n + V a)) (♭ P a) (inp Q) R) 128 | loop' {T} m n (out a P) (inp Q) R = loop' {T} m n P (♭ Q a) R 129 | loop' {T} {Σ V F} m n done (inp Q) R = inp (♯ λ a → loop'' {T} (! (n + V a)) done (♭ Q a) R) 130 | loop' {T} zero n P (out true Q) R = out true (P ⟫ Q ⟫ S⊆S&*T {T} [&] done) 131 | loop' {T} (suc m) n P (out true Q) R = out true (loop''' {T} {T} m n P Q R) 132 | loop' {T} m n P (out false Q) R = out false (P ⟫ Q) 133 | loop' {T} {Σ V F} m n (inp P) done R = inp (♯ λ a → loop'' {T} (! (n + V a)) (♭ P a) done R) 134 | loop' {T} m n (out a P) done R = loop' {T} m n P (out a done) R 135 | loop' {T} m n done done R = inp (♯ λ a → loop'' {T} (! (n + # 1)) done (out a done) R) 136 | 137 | loop : ∀ {T S} → (S ⇒ ¿ T & S) → (S ⇒ * T & S) 138 | loop {T} P = loop' {T} zero (# 0) done P P -------------------------------------------------------------------------------- /src/System/IO/Transducers/Lazy.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ∞ ; ♭ ; ♯_ ) 2 | open import Data.Empty using ( ⊥ ) 3 | open import Data.Bool using ( Bool ; true ; false ; if_then_else_ ) 4 | open import Data.Product using ( ∃ ; _×_ ; _,_ ; ,_ ) 5 | open import Data.Strict using ( Strict ; ! ) 6 | open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ ) 7 | open import Data.Unit using ( ⊤ ; tt ) 8 | open import System.IO.Transducers.Session 9 | using ( Session ; I ; Σ ; _∼_ ; ∼-sym ; Γ ; _/_ ; IsΣ ; IsΣ-≡ ; ⟨_⟩ ; _&_ ; ¿ ; _+_ ) 10 | renaming ( unit₁ to ∼-unit₁ ; unit₂ to ∼-unit₂ ; assoc to ∼-assoc ) 11 | open import System.IO.Transducers.Trace using ( _≤_ ; _⊑_ ; Trace ; [] ; _∷_ ) 12 | open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ) 13 | open import Relation.Nullary using ( Dec ; yes ; no ) 14 | 15 | module System.IO.Transducers.Lazy where 16 | 17 | -- S ⇛ T is the type of transducers whose inputs 18 | -- are traces through S, and whose output are traces through T. 19 | 20 | -- Note that input is coinductive, but output is inductive, 21 | -- which guarantees that transducers will map finite traces 22 | -- to finite traces. 23 | 24 | -- The name transducer comes from automata theory -- these 25 | -- are essentially I/O automata, or strategies in a two-player 26 | -- game without the move alternation restriction. 27 | 28 | -- In this module, we give definitions for lazy transducers, 29 | -- there is a separate module for stict transducers. 30 | 31 | infixr 4 _⇒_ _≃_ _≲_ 32 | infixr 6 _⟫_ 33 | infixr 8 _[&]_ _⟨&⟩_ _⟨+⟩_ _⟨¿⟩_ 34 | 35 | -- Lazy transducers, which may perform output before input. 36 | 37 | data _⇒_ : (S T : Session) → Set₁ where 38 | inp : ∀ {T A V F} → ∞ ((a : A) → (♭ F a ⇒ T)) → (Σ V F ⇒ T) 39 | out : ∀ {S B W G} → (b : B) → (S ⇒ ♭ G b) → (S ⇒ Σ W G) 40 | done : ∀ {S} → (S ⇒ S) 41 | 42 | -- Semantically, we only need done at type I, 43 | -- we have it at all types just for efficiency. 44 | 45 | data _⤇_ : (S T : Session) → Set₁ where 46 | inp : ∀ {T A V F} → ∞ ((a : A) → (♭ F a ⤇ T)) → (Σ V F ⤇ T) 47 | out : ∀ {S B W G} → (b : B) → (S ⤇ ♭ G b) → (S ⤇ Σ W G) 48 | done : (I ⤇ I) 49 | 50 | ι : ∀ {S T} → (S ⤇ T) → (S ⇒ T) 51 | ι (inp P) = inp (♯ λ a → ι (♭ P a)) 52 | ι (out b P) = out b (ι P) 53 | ι done = done 54 | 55 | ι⁻¹ : ∀ {S T} → (S ⇒ T) → (S ⤇ T) 56 | ι⁻¹ (inp P) = inp (♯ λ a → ι⁻¹ (♭ P a)) 57 | ι⁻¹ (out b P) = out b (ι⁻¹ P) 58 | ι⁻¹ (done {I}) = done 59 | ι⁻¹ (done {Σ V F}) = inp (♯ λ a → out a (ι⁻¹ done)) 60 | 61 | -- Helper functions to build transducers in terms of Γ and _/_ 62 | 63 | out' : ∀ {S T} b → (S ⇒ T / b) → (S ⇒ T) 64 | out' {S} {I} () P 65 | out' {S} {Σ W G} b P = out b P 66 | 67 | -- Helper function to output a whole trace. 68 | 69 | out* : ∀ {S T U} → (T ≤ U) → (S ⇒ T) → (S ⇒ U) 70 | out* [] P = P 71 | out* (b ∷ bs) P = out* bs (out' b P) 72 | 73 | -- Semantics as a function from partial traces to partial traces 74 | 75 | ⟦_⟧ : ∀ {S T} → (S ⇒ T) → (Trace S) → (Trace T) 76 | ⟦ inp P ⟧ [] = [] 77 | ⟦ inp P ⟧ (a ∷ as) = ⟦ ♭ P a ⟧ as 78 | ⟦ out b P ⟧ as = b ∷ ⟦ P ⟧ as 79 | ⟦ done ⟧ as = as 80 | 81 | -- Extensional equivalence on trace functions 82 | 83 | _≃_ : ∀ {S T} → (f g : Trace S → Trace T) → Set 84 | f ≃ g = ∀ as → f as ≡ g as 85 | 86 | -- Improvement order on trace functions 87 | 88 | _≲_ : ∀ {S T} → (f g : Trace S → Trace T) → Set₁ 89 | f ≲ g = ∀ as → f as ⊑ g as 90 | 91 | -- Equivalent sessions give rise to a transducer 92 | 93 | equiv : ∀ {S T} → (S ∼ T) → (S ⇒ T) 94 | equiv I = done 95 | equiv (Σ V F) = inp (♯ λ a → out a (equiv (♭ F a))) 96 | 97 | -- Transducers form a category with composition given by 98 | -- parallel (data flow) composition. This is defined by the 99 | -- usual expansion laws for parallel composition, together with 100 | -- the unit law for done. Since composition is deterministic, 101 | -- we prioritize output over input. 102 | 103 | _⟫_ : ∀ {S T U} → (S ⇒ T) → (T ⇒ U) → (S ⇒ U) 104 | done ⟫ Q = Q 105 | P ⟫ done = P 106 | P ⟫ out b Q = out b (P ⟫ Q) 107 | out b P ⟫ inp Q = P ⟫ ♭ Q b 108 | inp P ⟫ Q = inp (♯ λ a → ♭ P a ⟫ Q) 109 | 110 | -- The category has monoidal structure given by &, with 111 | -- action on morphisms: 112 | 113 | _[&]_ : ∀ {S T U V} → (S ⇒ T) → (U ⇒ V) → ((S & U) ⇒ (T & V)) 114 | inp {I} P [&] out c Q = out c (inp P [&] Q) 115 | inp P [&] Q = inp (♯ λ a → ♭ P a [&] Q) 116 | out b P [&] Q = out b (P [&] Q) 117 | done {I} [&] Q = Q 118 | done {Σ V F} [&] Q = inp (♯ λ a → out a (done {♭ F a} [&] Q)) 119 | 120 | -- Units for & 121 | 122 | unit₁ : ∀ {S} → (I & S) ⇒ S 123 | unit₁ = equiv ∼-unit₁ 124 | 125 | unit₁⁻¹ : ∀ {S} → S ⇒ (I & S) 126 | unit₁⁻¹ = equiv (∼-sym ∼-unit₁) 127 | 128 | unit₂ : ∀ {S} → (S & I) ⇒ S 129 | unit₂ = equiv ∼-unit₂ 130 | 131 | unit₂⁻¹ : ∀ {S} → S ⇒ (S & I) 132 | unit₂⁻¹ = equiv (∼-sym ∼-unit₂) 133 | 134 | -- Associativity of & 135 | 136 | assoc : ∀ {S T U} → (S & (T & U)) ⇒ ((S & T) & U) 137 | assoc {S} = equiv (∼-assoc {S}) 138 | 139 | assoc⁻¹ : ∀ {S T U} → ((S & T) & U) ⇒ (S & (T & U)) 140 | assoc⁻¹ {S} = equiv (∼-sym (∼-assoc {S})) 141 | 142 | -- Projections 143 | 144 | discard : ∀ {S} → (S ⇒ I) 145 | discard {I} = done 146 | discard {Σ V F} = inp (♯ λ a → discard) 147 | 148 | π₁ : ∀ {S T} → (S & T ⇒ S) 149 | π₁ {I} = discard 150 | π₁ {Σ V F} = inp (♯ λ a → out a π₁) 151 | 152 | π₂ : ∀ {S T} → (S & T ⇒ T) 153 | π₂ {I} = done 154 | π₂ {Σ V F} = inp (♯ λ a → π₂ {♭ F a}) 155 | 156 | -- The category is almost cartesian, at the cost of 157 | -- buffering. WARNING. BUFFERING. This is bad. Do not do this. 158 | 159 | -- The "almost" is due to a failure of the projection properties: 160 | -- P ⟨&⟩ Q ⟫ π₂ is not equivalent to Q, since Q may do output immediately, 161 | -- and P ⟨&⟩ Q ⟫ π₂ can only output after it has consumed all its input. 162 | -- Similarly π₁ ⟨&⟩ π₂ is not equivalent to done, as π₂'s output will 163 | -- be bufferred. 164 | 165 | -- This implementation uses output buffering, hopefully output 166 | -- is usually smaller than input. 167 | 168 | buffer : ∀ {S T U V} → (S ⇒ T) → (S ⇒ U) → (U ≤ V) → (S ⇒ T & V) 169 | buffer (inp P) (inp Q) cs = inp (♯ λ a → buffer (♭ P a) (♭ Q a) cs) 170 | buffer (inp P) (out c Q) cs = buffer (inp P) Q (c ∷ cs) 171 | buffer (inp P) done cs = inp (♯ λ c → buffer (♭ P c) done (c ∷ cs)) 172 | buffer (out b P) Q cs = out b (buffer P Q cs) 173 | buffer (done {I}) Q cs = out* cs Q 174 | buffer (done {Σ V F}) (inp Q) cs = inp (♯ λ a → out a (buffer done (♭ Q a) cs)) 175 | buffer (done {Σ V F}) (out c Q) cs = buffer done Q (c ∷ cs) 176 | buffer (done {Σ V F}) done cs = inp (♯ λ c → out c (buffer done done (c ∷ cs))) 177 | 178 | _⟨&⟩_ : ∀ {S T U} → (S ⇒ T) → (S ⇒ U) → (S ⇒ T & U) 179 | P ⟨&⟩ Q = buffer P Q [] 180 | 181 | -- If you want input buffering, you can implement it using copy and _[&]_. 182 | 183 | copy : ∀ {S} → (S ⇒ (S & S)) 184 | copy = done ⟨&⟩ done 185 | 186 | -- Braiding structure 187 | 188 | swap'' : ∀ {T U} → (I ≤ U) → T ⇒ (T & U) 189 | swap'' {I} cs = out* cs done 190 | swap'' {Σ W G} cs = inp (♯ λ b → out b (swap'' cs)) 191 | 192 | swap' : ∀ {S T} {isΣ : IsΣ T} {U} → (S ≤ U) → (S & T) ⇒ (T & U) 193 | swap' {I} cs = swap'' cs 194 | swap' {Σ V F} {Σ W G} cs = inp (♯ λ c → swap' (c ∷ cs)) 195 | swap' {Σ V F} {I} {} cs 196 | 197 | swap : ∀ {S T} → ((S & T) ⇒ (T & S)) 198 | swap {I} {T} = unit₂⁻¹ 199 | swap {Σ V F} {I} = unit₂ 200 | swap {Σ V F} {Σ W G} = swap' {Σ V F} [] 201 | 202 | -- Choice 203 | 204 | ι₁ : ∀ {S T} → (S ⇒ S + T) 205 | ι₁ = out true done 206 | 207 | ι₂ : ∀ {S T} → (T ⇒ S + T) 208 | ι₂ = out false done 209 | 210 | choice : ∀ {S T U} → (S ⇒ U) → (T ⇒ U) → ∀ b → ((if b then S else T) ⇒ U) 211 | choice P Q true = P 212 | choice P Q false = Q 213 | 214 | _[+]_ : ∀ {S T U V} → (S ⇒ U) → (T ⇒ V) → ((S + T) ⇒ (U + V)) 215 | P [+] Q = inp (♯ choice (out true P) (out false Q)) 216 | 217 | _⟨+⟩_ : ∀ {S T U} {isΣ : IsΣ U} → (S ⇒ U) → (T ⇒ U) → ((S + T) ⇒ U) 218 | _⟨+⟩_ {S} {T} {Σ X H} P Q = inp (♯ choice P Q) 219 | _⟨+⟩_ {S} {T} {I} {} P Q 220 | 221 | -- Options. 222 | 223 | some : ∀ {S} → (S ⇒ ¿ S) 224 | some = ι₁ 225 | 226 | none : ∀ {S} → (I ⇒ ¿ S) 227 | none = ι₂ 228 | 229 | [¿] : ∀ {S T} → (S ⇒ T) → (¿ S ⇒ ¿ T) 230 | [¿] P = P [+] done 231 | 232 | _⟨¿⟩_ : ∀ {S T} {isΣ : IsΣ T} → (S ⇒ T) → (I ⇒ T) → (¿ S ⇒ T) 233 | _⟨¿⟩_ {S} {T} {isΣ} = _⟨+⟩_ {S} {I} {T} {isΣ} 234 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties/LaxBraided.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♭ ) 2 | open import Data.Empty using ( ⊥-elim ) 3 | open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ ) 4 | open import System.IO.Transducers.Lazy 5 | using ( _⇒_ ; inp ; out ; done ; ⟦_⟧ ; _≃_ ; out' ; out* ; 6 | _⟫_ ;_[&]_ ; unit₁ ; unit₂ ; assoc ; assoc⁻¹ ; swap'' ; swap' ; swap ) 7 | open import System.IO.Transducers.Reflective using ( Reflective ) 8 | open import System.IO.Transducers.Strict using ( Strict ) 9 | open import System.IO.Transducers.Session using ( I ; Σ ; IsΣ ; _&_ ) 10 | open import System.IO.Transducers.Trace 11 | using ( Trace ; _✓ ; _≤_ ; [] ; _∷_ ; revApp ) 12 | open import System.IO.Transducers.Properties.Lemmas 13 | using ( ✓? ; I-✓ ; I-η ; ⟦⟧-resp-✓ ; ⟦⟧-refl-✓ ; ⟦⟧-resp-[] ) 14 | open import System.IO.Transducers.Properties.Category 15 | using ( ⟦done⟧ ; _⟦⟫⟧_ ; ⟫-≃-⟦⟫⟧ ; done-semantics ) 16 | open import System.IO.Transducers.Properties.Monoidal 17 | using ( _++_ ; front ; back ; _⟦[&]⟧_ ; ⟦unit₁⟧ ; ⟦unit₂⟧ ; ⟦assoc⟧ ; ⟦assoc⁻¹⟧ ; 18 | ++-cong ; ++-β₁ ; ++-β₂ ; ++-β₂-[] ; ++-η ; back≡[] ; back-resp-[] ; ++-resp-[] ; 19 | ++-refl-✓₁ ; ++-refl-✓₂ ; front-refl-✓ ; back-refl-✓ ; ++-resp-✓ ; front-resp-✓ ; 20 | ⟦[&]⟧-++ ; ⟦assoc⟧-++ ; ⟦assoc⁻¹⟧-++ ; 21 | [&]-≃-⟦[&]⟧ ; [&]-semantics ; 22 | assoc-semantics ; assoc⁻¹-semantics ; 23 | unit₁-semantics ; unit₂-semantics ; unit₂⁻¹-semantics ) 24 | open import Relation.Binary.PropositionalEquality 25 | using ( _≡_ ; sym ; refl ; trans ; cong ; cong₂ ) 26 | open import Relation.Nullary using ( Dec ; yes ; no ) 27 | 28 | module System.IO.Transducers.Properties.LaxBraided where 29 | 30 | open Relation.Binary.PropositionalEquality.≡-Reasoning 31 | 32 | -- Semantics of out* 33 | 34 | ⟦out*⟧ : ∀ {S T U} → (T ≤ U) → (Trace S → Trace T) → (Trace S → Trace U) 35 | ⟦out*⟧ cs f as = revApp cs (f as) 36 | 37 | out*-semantics : ∀ {S T U} (cs : T ≤ U) (P : S ⇒ T) → 38 | ⟦ out* cs P ⟧ ≃ ⟦out*⟧ cs ⟦ P ⟧ 39 | out*-semantics [] P as = refl 40 | out*-semantics (_∷_ {Σ V F} c cs) P as = out*-semantics cs (out c P) as 41 | out*-semantics (_∷_ {I} () cs) P as 42 | 43 | -- Semantics of swap 44 | 45 | ⟦swap''⟧ : ∀ {T U} → (I ≤ U) → (Trace T) → (Trace (T & U)) 46 | ⟦swap''⟧ cs as = as ++ revApp cs [] 47 | 48 | ⟦swap'⟧ : ∀ {S T U} → (S ≤ U) → (Trace (S & T)) → (Trace (T & U)) 49 | ⟦swap'⟧ {S} cs as = back {S} as ++ revApp cs (front {S} as) 50 | 51 | ⟦swap⟧ : ∀ {S T} → (Trace (S & T) → Trace (T & S)) 52 | ⟦swap⟧ {S} as = back {S} as ++ front {S} as 53 | 54 | swap''-semantics : ∀ {T U} cs → ⟦ swap'' {T} {U} cs ⟧ ≃ ⟦swap''⟧ cs 55 | swap''-semantics {I} cs [] = out*-semantics cs done [] 56 | swap''-semantics {Σ W G} cs [] = refl 57 | swap''-semantics {Σ W G} cs (a ∷ as) = cong (_∷_ a) (swap''-semantics cs as) 58 | swap''-semantics {I} cs (() ∷ as) 59 | 60 | swap'-semantics : ∀ {S T isΣ U} cs → ⟦ swap' {S} {T} {isΣ} {U} cs ⟧ ≃ ⟦swap'⟧ cs 61 | swap'-semantics {I} cs as = swap''-semantics cs as 62 | swap'-semantics {Σ V F} {Σ W G} cs [] = refl 63 | swap'-semantics {Σ V F} {Σ W G} cs (a ∷ as) = swap'-semantics (a ∷ cs) as 64 | swap'-semantics {Σ V F} {I} {} cs as 65 | 66 | swap-semantics : ∀ {S T} → ⟦ swap {S} {T} ⟧ ≃ ⟦swap⟧ {S} {T} 67 | swap-semantics {I} as = unit₂⁻¹-semantics as 68 | swap-semantics {Σ V F} {I} as = cong₂ _++_ (sym (I-η (back {Σ V F} as))) (unit₂-semantics as) 69 | swap-semantics {Σ V F} {Σ W G} as = swap'-semantics {Σ V F} [] as 70 | 71 | -- Swap reflects completion 72 | 73 | ⟦swap⟧-refl-✓ : ∀ {S T} as → (⟦swap⟧ {S} {T} as ✓) → (as ✓) 74 | ⟦swap⟧-refl-✓ {S} {I} as ✓bs = front-refl-✓ {S} as (++-refl-✓₂ {I} {S} {back {S} as} ✓bs) 75 | ⟦swap⟧-refl-✓ {S} {Σ W G} as ✓bs = back-refl-✓ {S} as (++-refl-✓₁ {Σ W G} ✓bs) 76 | 77 | -- Swap plays nicely with concatenation 78 | 79 | ⟦swap⟧-++ : ∀ {S T} (as : Trace S) (bs : Trace T) → (as ✓ ⊎ bs ≡ []) → 80 | ⟦swap⟧ {S} {T} (as ++ bs) ≡ bs ++ as 81 | ⟦swap⟧-++ as bs ✓as/bs≡[] with ✓? as 82 | ⟦swap⟧-++ as bs ✓as/bs≡[] | yes ✓as = cong₂ _++_ (++-β₂ ✓as bs) (++-β₁ as bs) 83 | ⟦swap⟧-++ as bs (inj₁ ✓as) | no ¬✓as = cong₂ _++_ (++-β₂ ✓as bs) (++-β₁ as bs) 84 | ⟦swap⟧-++ as bs (inj₂ bs≡[]) | no ¬✓as = cong₂ _++_ (trans (++-β₂-[] ¬✓as bs) (sym bs≡[])) (++-β₁ as bs) 85 | 86 | -- Swap is natural when f respects completion, and g reflects completion and is strict 87 | 88 | ⟦swap⟧-natural : ∀ {S T U V} → (f : Trace S → Trace T) → (g : Trace U → Trace V) → 89 | (∀ as → (as ✓) → (f as ✓)) → 90 | (∀ as → ((g as ✓)) → (as ✓)) → (g [] ≡ []) → 91 | (f ⟦[&]⟧ g ⟦⟫⟧ ⟦swap⟧ {T} {V}) ≃ (⟦swap⟧ {S} {U} ⟦⟫⟧ g ⟦[&]⟧ f) 92 | ⟦swap⟧-natural {S} {T} {U} {V} f g f-resp-✓ g-refl-✓ g-resp-[] as = 93 | begin 94 | ⟦swap⟧ {T} {V} (f as₁ ++ g as₂) 95 | ≡⟨ ⟦swap⟧-++ (f as₁) (g as₂) ✓fas₁/gas₂≡[] ⟩ 96 | g as₂ ++ f as₁ 97 | ≡⟨ sym (⟦[&]⟧-++ g f g-refl-✓ as₂ as₁) ⟩ 98 | (g ⟦[&]⟧ f) (as₂ ++ as₁) 99 | ∎ where 100 | as₁ = front {S} as 101 | as₂ = back {S} as 102 | ✓fas₁/gas₂≡[] : f as₁ ✓ ⊎ g as₂ ≡ [] 103 | ✓fas₁/gas₂≡[] with ✓? as₁ 104 | ✓fas₁/gas₂≡[] | yes ✓as₁ = inj₁ (f-resp-✓ as₁ ✓as₁) 105 | ✓fas₁/gas₂≡[] | no ¬✓as₁ = inj₂ (trans (cong g (back≡[] ¬✓as₁)) g-resp-[]) 106 | 107 | swap-natural : ∀ {S T U V} (P : S ⇒ T) {Q : U ⇒ V} → 108 | (Reflective Q) → (Strict Q) → 109 | ⟦ P [&] Q ⟫ swap {T} {V} ⟧ ≃ ⟦ swap {S} {U} ⟫ Q [&] P ⟧ 110 | swap-natural {S} {T} {U} {V} P {Q} ⟳Q #Q as = 111 | begin 112 | ⟦ P [&] Q ⟫ swap {T} {V} ⟧ as 113 | ≡⟨ ⟫-≃-⟦⟫⟧ ([&]-semantics P Q) (swap-semantics {T} {V}) as ⟩ 114 | (⟦ P ⟧ ⟦[&]⟧ ⟦ Q ⟧ ⟦⟫⟧ ⟦swap⟧ {T} {V}) as 115 | ≡⟨ ⟦swap⟧-natural ⟦ P ⟧ ⟦ Q ⟧ (⟦⟧-resp-✓ P) (⟦⟧-refl-✓ ⟳Q) (⟦⟧-resp-[] #Q) as ⟩ 116 | (⟦swap⟧ {S} {U} ⟦⟫⟧ ⟦ Q ⟧ ⟦[&]⟧ ⟦ P ⟧) as 117 | ≡⟨ sym (⟫-≃-⟦⟫⟧ (swap-semantics {S} {U}) ([&]-semantics Q P) as) ⟩ 118 | ⟦ swap {S} {U} ⟫ Q [&] P ⟧ as 119 | ∎ 120 | 121 | -- Coherence of swap with units 122 | 123 | ⟦swap⟧-⟦unit₁⟧ : ∀ {S} → 124 | ⟦swap⟧ {S} {I} ⟦⟫⟧ ⟦unit₁⟧ ≃ ⟦unit₂⟧ 125 | ⟦swap⟧-⟦unit₁⟧ {S} as = cong₂ _++_ (I-η (back {S} as)) refl 126 | 127 | swap-unit₁ : ∀ {S} → 128 | ⟦ swap {S} {I} ⟫ unit₁ ⟧ ≃ ⟦ unit₂ ⟧ 129 | swap-unit₁ {S} as = 130 | begin 131 | ⟦ swap {S} {I} ⟫ unit₁ ⟧ as 132 | ≡⟨ ⟫-≃-⟦⟫⟧ (swap-semantics {S}) unit₁-semantics as ⟩ 133 | (⟦swap⟧ {S} {I} ⟦⟫⟧ ⟦unit₁⟧) as 134 | ≡⟨ ⟦swap⟧-⟦unit₁⟧ as ⟩ 135 | ⟦unit₂⟧ as 136 | ≡⟨ sym (unit₂-semantics as) ⟩ 137 | ⟦ unit₂ ⟧ as 138 | ∎ 139 | 140 | ⟦swap⟧-⟦unit₂⟧ : ∀ {S} → 141 | ⟦swap⟧ {I} {S} ⟦⟫⟧ ⟦unit₂⟧ ≃ ⟦unit₁⟧ 142 | ⟦swap⟧-⟦unit₂⟧ as = ++-β₁ as [] 143 | 144 | swap-unit₂ : ∀ {S} → 145 | ⟦ swap {I} {S} ⟫ unit₂ ⟧ ≃ ⟦ unit₁ ⟧ 146 | swap-unit₂ {S} as = 147 | begin 148 | ⟦ swap {I} {S} ⟫ unit₂ ⟧ as 149 | ≡⟨ ⟫-≃-⟦⟫⟧ (swap-semantics {I}) (unit₂-semantics {S}) as ⟩ 150 | (⟦swap⟧ {I} {S} ⟦⟫⟧ ⟦unit₂⟧) as 151 | ≡⟨ ⟦swap⟧-⟦unit₂⟧ as ⟩ 152 | ⟦unit₁⟧ as 153 | ≡⟨ sym (unit₁-semantics as) ⟩ 154 | ⟦ unit₁ ⟧ as 155 | ∎ 156 | 157 | -- Coherence of swap with associators 158 | 159 | ⟦swap⟧-⟦assoc⟧ : ∀ {S T U} → 160 | ⟦assoc⟧ {S} {T} {U} ⟦⟫⟧ ⟦swap⟧ {S & T} {U} ⟦⟫⟧ ⟦assoc⟧ {U} {S} {T} 161 | ≃ ⟦done⟧ {S} ⟦[&]⟧ ⟦swap⟧ {T} {U} ⟦⟫⟧ 162 | ⟦assoc⟧ {S} {U} {T} ⟦⟫⟧ ⟦swap⟧ {S} {U} ⟦[&]⟧ ⟦done⟧ {T} 163 | ⟦swap⟧-⟦assoc⟧ {S} {T} {U} as = 164 | begin 165 | ⟦assoc⟧ {U} {S} {T} (⟦swap⟧ {S & T} {U} ((as₁ ++ as₂) ++ as₃)) 166 | ≡⟨ cong (⟦assoc⟧ {U} {S} {T}) (⟦swap⟧-++ (as₁ ++ as₂) as₃ ✓as₁₂/as₃≡[]) ⟩ 167 | ⟦assoc⟧ {U} {S} {T} (as₃ ++ as₁ ++ as₂) 168 | ≡⟨ ⟦assoc⟧-++ as₃ as₁ as₂ ⟩ 169 | (as₃ ++ as₁) ++ as₂ 170 | ≡⟨ cong₂ _++_ (sym (⟦swap⟧-++ as₁ as₃ ✓as₁/as₃≡[])) refl ⟩ 171 | ⟦swap⟧ {S} {U} (as₁ ++ as₃) ++ as₂ 172 | ≡⟨ (sym (⟦[&]⟧-++ (⟦swap⟧ {S} {U}) ⟦done⟧ (⟦swap⟧-refl-✓ {S} {U}) (as₁ ++ as₃) as₂)) ⟩ 173 | (⟦swap⟧ {S} {U} ⟦[&]⟧ ⟦done⟧ {T}) ((as₁ ++ as₃) ++ as₂) 174 | ≡⟨ cong (⟦swap⟧ {S} {U} ⟦[&]⟧ ⟦done⟧ {T}) (sym (⟦assoc⟧-++ as₁ as₃ as₂)) ⟩ 175 | (⟦swap⟧ {S} {U} ⟦[&]⟧ ⟦done⟧ {T}) (⟦assoc⟧ {S} {U} {T} (as₁ ++ as₃ ++ as₂)) 176 | ∎ where 177 | as₁ = front {S} as 178 | as₂ = front {T} (back {S} as) 179 | as₃ = back {T} (back {S} as) 180 | ✓as₁₂/as₃≡[] : as₁ ++ as₂ ✓ ⊎ as₃ ≡ [] 181 | ✓as₁₂/as₃≡[] with ✓? as₁ | ✓? as₂ 182 | ✓as₁₂/as₃≡[] | yes ✓as₁ | yes ✓as₂ = inj₁ (++-resp-✓ ✓as₁ ✓as₂) 183 | ✓as₁₂/as₃≡[] | _ | no ¬✓as₂ = inj₂ (back≡[] ¬✓as₂) 184 | ✓as₁₂/as₃≡[] | no ¬✓as₁ | _ = inj₂ (back-resp-[] {T} (back≡[] ¬✓as₁)) 185 | ✓as₁/as₃≡[] : as₁ ✓ ⊎ as₃ ≡ [] 186 | ✓as₁/as₃≡[] with ✓? as₁ 187 | ✓as₁/as₃≡[] | yes ✓as₁ = inj₁ ✓as₁ 188 | ✓as₁/as₃≡[] | no ¬✓as₁ = inj₂ (back-resp-[] {T} (back≡[] ¬✓as₁)) 189 | 190 | 191 | swap-assoc : ∀ {S T U} → 192 | ⟦ assoc {S} {T} {U} ⟫ swap {S & T} {U} ⟫ assoc {U} {S} {T} ⟧ 193 | ≃ ⟦ done {S} [&] swap {T} {U} ⟫ assoc {S} {U} {T} ⟫ swap {S} {U} [&] done {T} ⟧ 194 | swap-assoc {S} {T} {U} as = 195 | begin 196 | ⟦ assoc {S} {T} {U} ⟫ swap {S & T} {U} ⟫ assoc {U} {S} {T} ⟧ as 197 | ≡⟨ ⟫-≃-⟦⟫⟧ (assoc-semantics {S} {T} {U}) 198 | (⟫-≃-⟦⟫⟧ (swap-semantics {S & T} {U}) (assoc-semantics {U} {S} {T})) as ⟩ 199 | (⟦assoc⟧ {S} {T} {U} ⟦⟫⟧ ⟦swap⟧ {S & T} {U} ⟦⟫⟧ ⟦assoc⟧ {U} {S} {T}) as 200 | ≡⟨ ⟦swap⟧-⟦assoc⟧ {S} {T} {U} as ⟩ 201 | (⟦done⟧ {S} ⟦[&]⟧ ⟦swap⟧ {T} {U} ⟦⟫⟧ 202 | ⟦assoc⟧ {S} {U} {T} ⟦⟫⟧ ⟦swap⟧ {S} {U} ⟦[&]⟧ ⟦done⟧ {T}) as 203 | ≡⟨ sym (⟫-≃-⟦⟫⟧ ([&]-≃-⟦[&]⟧ {P = done} (done-semantics {S}) (swap-semantics {T} {U})) 204 | (⟫-≃-⟦⟫⟧ (assoc-semantics {S} {U} {T}) 205 | ([&]-≃-⟦[&]⟧ {Q = done} (swap-semantics {S} {U}) (done-semantics {T}))) as) ⟩ 206 | ⟦ done {S} [&] swap {T} {U} ⟫ assoc {S} {U} {T} ⟫ swap {S} {U} [&] done {T} ⟧ as 207 | ∎ 208 | 209 | ⟦swap⟧-⟦assoc⁻¹⟧ : ∀ {S T U} → 210 | ⟦assoc⁻¹⟧ {S} {T} {U} ⟦⟫⟧ ⟦swap⟧ {S} {T & U} ⟦⟫⟧ ⟦assoc⁻¹⟧ {T} {U} {S} 211 | ≃ ⟦swap⟧ {S} {T} ⟦[&]⟧ ⟦done⟧ {U} ⟦⟫⟧ 212 | ⟦assoc⁻¹⟧ {T} {S} {U} ⟦⟫⟧ ⟦done⟧ {T} ⟦[&]⟧ ⟦swap⟧ {S} {U} 213 | ⟦swap⟧-⟦assoc⁻¹⟧ {S} {T} {U} as = 214 | begin 215 | ⟦assoc⁻¹⟧ {T} {U} {S} (⟦swap⟧ {S} {T & U} (as₁ ++ as₂ ++ as₃)) 216 | ≡⟨ cong (⟦assoc⁻¹⟧ {T} {U} {S}) (⟦swap⟧-++ as₁ (as₂ ++ as₃) ✓as₁/as₂₃≡[]) ⟩ 217 | ⟦assoc⁻¹⟧ {T} {U} {S} ((as₂ ++ as₃) ++ as₁) 218 | ≡⟨ ⟦assoc⁻¹⟧-++ as₂ as₃ as₁ ⟩ 219 | as₂ ++ as₃ ++ as₁ 220 | ≡⟨ cong (_++_ as₂) (sym (⟦swap⟧-++ as₁ as₃ ✓as₁/as₃≡[])) ⟩ 221 | as₂ ++ ⟦swap⟧ {S} {U} (as₁ ++ as₃) 222 | ≡⟨ sym (⟦[&]⟧-++ (⟦done⟧ {T}) (⟦swap⟧ {S} {U}) (λ cs → λ ✓cs → ✓cs) as₂ (as₁ ++ as₃)) ⟩ 223 | (⟦done⟧ {T} ⟦[&]⟧ ⟦swap⟧ {S} {U}) (as₂ ++ as₁ ++ as₃) 224 | ≡⟨ cong (⟦done⟧ {T} ⟦[&]⟧ ⟦swap⟧ {S} {U}) (sym (⟦assoc⁻¹⟧-++ as₂ as₁ as₃)) ⟩ 225 | (⟦done⟧ {T} ⟦[&]⟧ ⟦swap⟧ {S} {U}) (⟦assoc⁻¹⟧ {T} {S} {U} ((as₂ ++ as₁) ++ as₃)) 226 | ∎ where 227 | as₁ = front {S} (front {S & T} as) 228 | as₂ = back {S} (front {S & T} as) 229 | as₃ = back {S & T} as 230 | ✓as₁/as₂₃≡[] : as₁ ✓ ⊎ as₂ ++ as₃ ≡ [] 231 | ✓as₁/as₂₃≡[] with ✓? as₁ 232 | ✓as₁/as₂₃≡[] | yes ✓as₁ = inj₁ ✓as₁ 233 | ✓as₁/as₂₃≡[] | no ¬✓as₁ = inj₂ (++-resp-[] (back≡[] ¬✓as₁) (back≡[] (λ ✓as₁₂ → ¬✓as₁ (front-resp-✓ ✓as₁₂)))) 234 | ✓as₁/as₃≡[] : as₁ ✓ ⊎ as₃ ≡ [] 235 | ✓as₁/as₃≡[] with ✓? as₁ 236 | ✓as₁/as₃≡[] | yes ✓as₁ = inj₁ ✓as₁ 237 | ✓as₁/as₃≡[] | no ¬✓as₁ = inj₂ (back≡[] (λ ✓as₁₂ → ¬✓as₁ (front-resp-✓ ✓as₁₂))) 238 | 239 | swap-assoc⁻¹ : ∀ {S T U} → 240 | ⟦ assoc⁻¹ {S} {T} {U} ⟫ swap {S} {T & U} ⟫ assoc⁻¹ {T} {U} {S} ⟧ 241 | ≃ ⟦ swap {S} {T} [&] done {U} ⟫ assoc⁻¹ {T} {S} {U} ⟫ done {T} [&] swap {S} {U} ⟧ 242 | swap-assoc⁻¹ {S} {T} {U} as = 243 | begin 244 | ⟦ assoc⁻¹ {S} {T} {U} ⟫ swap {S} {T & U} ⟫ assoc⁻¹ {T} {U} {S} ⟧ as 245 | ≡⟨ ⟫-≃-⟦⟫⟧ (assoc⁻¹-semantics {S} {T} {U}) 246 | (⟫-≃-⟦⟫⟧ (swap-semantics {S} {T & U}) (assoc⁻¹-semantics {T} {U} {S})) as ⟩ 247 | (⟦assoc⁻¹⟧ {S} {T} {U} ⟦⟫⟧ ⟦swap⟧ {S} {T & U} ⟦⟫⟧ ⟦assoc⁻¹⟧ {T} {U} {S}) as 248 | ≡⟨ ⟦swap⟧-⟦assoc⁻¹⟧ {S} {T} {U} as ⟩ 249 | (⟦swap⟧ {S} {T} ⟦[&]⟧ ⟦done⟧ {U} ⟦⟫⟧ 250 | ⟦assoc⁻¹⟧ {T} {S} {U} ⟦⟫⟧ ⟦done⟧ {T} ⟦[&]⟧ ⟦swap⟧ {S} {U}) as 251 | ≡⟨ sym (⟫-≃-⟦⟫⟧ ([&]-≃-⟦[&]⟧ {Q = done} (swap-semantics {S} {T}) (done-semantics {U})) 252 | (⟫-≃-⟦⟫⟧ (assoc⁻¹-semantics {T} {S} {U}) 253 | ([&]-≃-⟦[&]⟧ {P = done} (done-semantics {T}) (swap-semantics {S} {U}))) as) ⟩ 254 | ⟦ swap {S} {T} [&] done {U} ⟫ assoc⁻¹ {T} {S} {U} ⟫ done {T} [&] swap {S} {U} ⟧ as 255 | ∎ 256 | -------------------------------------------------------------------------------- /src/System/IO/Transducers/Properties/Monoidal.agda: -------------------------------------------------------------------------------- 1 | open import Coinduction using ( ♭ ; ♯_ ) 2 | open import Data.Empty using ( ⊥-elim ) 3 | open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ ) 4 | open import Relation.Binary.PropositionalEquality 5 | using ( _≡_ ; _≢_ ; refl ; sym ; cong ; cong₂ ) 6 | open import Relation.Nullary using ( ¬_ ; Dec ; yes ; no ) 7 | open import System.IO.Transducers.Lazy 8 | using ( _⇒_ ; inp ; out ; done ; _⟫_ ; 9 | equiv ; assoc ; assoc⁻¹ ; unit₁ ; unit₁⁻¹ ; unit₂ ; unit₂⁻¹ ; 10 | _[&]_ ; ⟦_⟧ ; _≃_ ) 11 | open import System.IO.Transducers.Reflective using ( Reflective ) 12 | open import System.IO.Transducers.Strict using ( Strict ) 13 | open import System.IO.Transducers.Session 14 | using ( I ; Σ ; IsΣ ; _∼_ ; ∼-refl ; ∼-trans ; ∼-sym ; _&_ ) 15 | renaming ( unit₁ to ∼-unit₁ ; unit₂ to ∼-unit₂ ; assoc to ∼-assoc ) 16 | open import System.IO.Transducers.Trace using ( Trace ; _✓ ; [] ; _∷_ ) 17 | open import System.IO.Transducers.Properties.Category 18 | using ( ⟦done⟧ ; done-semantics ; _⟦⟫⟧_ ; ⟫-semantics ; ⟫-≃-⟦⟫⟧ ; ⟫-resp-≃ ; done-isEquiv ; ⟫-isEquiv ; equiv-is-iso ) 19 | open import System.IO.Transducers.Properties.Lemmas 20 | using ( ≃-refl ; ≃-sym ; ✓-tl ; ✓? ; ⟦⟧-resp-✓ ; ⟦⟧-refl-✓ ; ⟦⟧-resp-[] ; 21 | IsEquiv ; isEquiv ; ≃-equiv ; I-η) 22 | 23 | module System.IO.Transducers.Properties.Monoidal where 24 | 25 | open Relation.Binary.PropositionalEquality.≡-Reasoning 26 | 27 | infixr 8 _++_ _⟦[&]⟧_ 28 | 29 | -- Concatenation of traces 30 | 31 | _++_ : ∀ {S T} → (Trace S) → (Trace T) → (Trace (S & T)) 32 | _++_ {I} [] bs = bs 33 | _++_ {Σ V F} [] bs = [] 34 | _++_ {Σ V F} (a ∷ as) bs = a ∷ (as ++ bs) 35 | _++_ {I} (() ∷ as) bs 36 | 37 | -- Projection of traces 38 | 39 | front : ∀ {S T} → (Trace (S & T)) → (Trace S) 40 | front {I} as = [] 41 | front {Σ V F} [] = [] 42 | front {Σ V F} (a ∷ as) = a ∷ front as 43 | 44 | back : ∀ {S T} → (Trace (S & T)) → (Trace T) 45 | back {I} as = as 46 | back {Σ V F} [] = [] 47 | back {Σ V F} (a ∷ as) = back {♭ F a} as 48 | 49 | -- Semantics of tensor 50 | 51 | _⟦[&]⟧_ : ∀ {S T U V} → 52 | (f : Trace S → Trace T) → (g : Trace U → Trace V) → 53 | (Trace (S & U)) → (Trace (T & V)) 54 | _⟦[&]⟧_ {S} f g as = f (front as) ++ g (back {S} as) 55 | 56 | [&]-semantics : ∀ {S T U V} (P : S ⇒ T) (Q : U ⇒ V) → 57 | ⟦ P [&] Q ⟧ ≃ ⟦ P ⟧ ⟦[&]⟧ ⟦ Q ⟧ 58 | [&]-semantics (inp {I} P) (inp Q) [] = refl 59 | [&]-semantics (inp {I} P) (inp Q) (a ∷ as) = [&]-semantics (♭ P a) (inp Q) as 60 | [&]-semantics (inp {I} P) done [] = refl 61 | [&]-semantics (inp {I} P) done (a ∷ as) = [&]-semantics (♭ P a) done as 62 | [&]-semantics (inp {Σ V F} P) Q [] = refl 63 | [&]-semantics (inp {Σ V F} P) Q (a ∷ as) = [&]-semantics (♭ P a) Q as 64 | [&]-semantics (out b P) Q as = cong (_∷_ b) ([&]-semantics P Q as) 65 | [&]-semantics (done {I}) Q as = refl 66 | [&]-semantics (done {Σ V F}) Q [] = refl 67 | [&]-semantics (done {Σ V F}) Q (a ∷ as) = cong (_∷_ a) ([&]-semantics (done {♭ F a}) Q as) 68 | [&]-semantics (inp {I} P) (out c Q) as = 69 | begin 70 | c ∷ ⟦ inp P [&] Q ⟧ as 71 | ≡⟨ cong (_∷_ c) ([&]-semantics (inp P) Q as) ⟩ 72 | c ∷ (⟦ inp P ⟧ ⟦[&]⟧ ⟦ Q ⟧) as 73 | ≡⟨ cong (_∷_ c) (cong₂ _++_ (I-η (⟦ inp P ⟧ (front as))) refl) ⟩ 74 | c ∷ ⟦ Q ⟧ _ 75 | ≡⟨ cong₂ _++_ (sym (I-η (⟦ inp P ⟧ (front as)))) refl ⟩ 76 | (⟦ inp P ⟧ ⟦[&]⟧ ⟦ out c Q ⟧) as 77 | ∎ 78 | 79 | [&]-≃-⟦[&]⟧ : ∀ {S T U V} 80 | {P : S ⇒ T} {f : Trace S → Trace T} {Q : U ⇒ V} {g : Trace U → Trace V} → 81 | (⟦ P ⟧ ≃ f) → (⟦ Q ⟧ ≃ g) → (⟦ P [&] Q ⟧ ≃ f ⟦[&]⟧ g) 82 | [&]-≃-⟦[&]⟧ {S} {T} {U} {V} {P} {f} {Q} {g} P≃f Q≃g as = 83 | begin 84 | ⟦ P [&] Q ⟧ as 85 | ≡⟨ [&]-semantics P Q as ⟩ 86 | (⟦ P ⟧ ⟦[&]⟧ ⟦ Q ⟧) as 87 | ≡⟨ cong₂ _++_ (P≃f (front as)) (Q≃g (back {S} as)) ⟩ 88 | (f ⟦[&]⟧ g) as 89 | ∎ 90 | 91 | -- Semantics of units 92 | 93 | ⟦unit₁⟧ : ∀ {S} → (Trace (I & S)) → (Trace S) 94 | ⟦unit₁⟧ as = as 95 | 96 | unit₁-semantics : ∀ {S} → ⟦ unit₁ {S} ⟧ ≃ ⟦unit₁⟧ {S} 97 | unit₁-semantics {I} as = refl 98 | unit₁-semantics {Σ V F} [] = refl 99 | unit₁-semantics {Σ V F} (a ∷ as) = cong (_∷_ a) (unit₁-semantics as) 100 | 101 | ⟦unit₁⁻¹⟧ : ∀ {S} → (Trace (I & S)) → (Trace S) 102 | ⟦unit₁⁻¹⟧ as = as 103 | 104 | unit₁⁻¹-semantics : ∀ {S} → ⟦ unit₁⁻¹ {S} ⟧ ≃ ⟦unit₁⁻¹⟧ {S} 105 | unit₁⁻¹-semantics {I} as = refl 106 | unit₁⁻¹-semantics {Σ V F} [] = refl 107 | unit₁⁻¹-semantics {Σ V F} (a ∷ as) = cong (_∷_ a) (unit₁⁻¹-semantics as) 108 | 109 | ⟦unit₂⟧ : ∀ {S} → (Trace (S & I)) → (Trace S) 110 | ⟦unit₂⟧ = front 111 | 112 | unit₂-semantics : ∀ {S} → ⟦ unit₂ {S} ⟧ ≃ ⟦unit₂⟧ {S} 113 | unit₂-semantics {I} [] = refl 114 | unit₂-semantics {Σ V F} [] = refl 115 | unit₂-semantics {Σ V F} (a ∷ as) = cong (_∷_ a) (unit₂-semantics as) 116 | unit₂-semantics {I} (() ∷ as) 117 | 118 | ⟦unit₂⁻¹⟧ : ∀ {S} → (Trace S) → (Trace (S & I)) 119 | ⟦unit₂⁻¹⟧ as = as ++ [] 120 | 121 | unit₂⁻¹-semantics : ∀ {S} → ⟦ unit₂⁻¹ {S} ⟧ ≃ ⟦unit₂⁻¹⟧ 122 | unit₂⁻¹-semantics {I} [] = refl 123 | unit₂⁻¹-semantics {Σ W F} [] = refl 124 | unit₂⁻¹-semantics {Σ W F} (a ∷ as) = cong (_∷_ a) (unit₂⁻¹-semantics as) 125 | unit₂⁻¹-semantics {I} (() ∷ as) 126 | 127 | -- Semantics of associativity 128 | 129 | ⟦assoc⟧ : ∀ {S T U} → (Trace (S & (T & U))) → (Trace ((S & T) & U)) 130 | ⟦assoc⟧ {S} {T} {U} as = 131 | (front {S} as ++ front {T} (back {S} as)) ++ back {T} (back {S} as) 132 | 133 | assoc-semantics : ∀ {S T U} → ⟦ assoc {S} {T} {U} ⟧ ≃ ⟦assoc⟧ {S} {T} {U} 134 | assoc-semantics {I} {I} {I} [] = refl 135 | assoc-semantics {I} {I} {Σ X H} [] = refl 136 | assoc-semantics {I} {Σ W G} [] = refl 137 | assoc-semantics {I} {I} {Σ X H} (a ∷ as) = cong (_∷_ a) (assoc-semantics {I} {I} as) 138 | assoc-semantics {I} {Σ W G} (a ∷ as) = cong (_∷_ a) (assoc-semantics {I} {♭ G a} as) 139 | assoc-semantics {Σ V F} [] = refl 140 | assoc-semantics {Σ V F} (a ∷ as) = cong (_∷_ a) (assoc-semantics {♭ F a} as) 141 | assoc-semantics {I} {I} {I} (() ∷ as) 142 | 143 | ⟦assoc⁻¹⟧ : ∀ {S T U} → (Trace ((S & T) & U)) → (Trace (S & (T & U))) 144 | ⟦assoc⁻¹⟧ {S} {T} {U} as = 145 | front {S} (front {S & T} as) ++ back {S} (front {S & T} as) ++ back {S & T} as 146 | 147 | assoc⁻¹-semantics : ∀ {S T U} → ⟦ assoc⁻¹ {S} {T} {U} ⟧ ≃ ⟦assoc⁻¹⟧ {S} {T} {U} 148 | assoc⁻¹-semantics {I} {I} {I} [] = refl 149 | assoc⁻¹-semantics {I} {I} {Σ X H} [] = refl 150 | assoc⁻¹-semantics {I} {Σ W G} [] = refl 151 | assoc⁻¹-semantics {I} {I} {Σ X H} (a ∷ as) = cong (_∷_ a) (assoc⁻¹-semantics {I} {I} as) 152 | assoc⁻¹-semantics {I} {Σ W G} (a ∷ as) = cong (_∷_ a) (assoc⁻¹-semantics {I} {♭ G a} as) 153 | assoc⁻¹-semantics {Σ V F} [] = refl 154 | assoc⁻¹-semantics {Σ V F} (a ∷ as) = cong (_∷_ a) (assoc⁻¹-semantics {♭ F a} as) 155 | assoc⁻¹-semantics {I} {I} {I} (() ∷ as) 156 | 157 | -- Congruence for concatenation, where the rhs can assume the lhs has terminated 158 | 159 | ++-cong : ∀ {S T} {as₁ as₂ : Trace S} {bs₁ bs₂ : Trace T} → 160 | (as₁ ≡ as₂) → (as₁ ✓ → bs₁ ≡ bs₂) → (as₁ ++ bs₁) ≡ (as₂ ++ bs₂) 161 | ++-cong {I} {T} {[]} refl bs₁≡bs₂ = bs₁≡bs₂ [] 162 | ++-cong {Σ V F} {T} {[]} refl bs₁≡bs₂ = refl 163 | ++-cong {Σ V F} {T} {a ∷ as} refl bs₁≡bs₂ = cong (_∷_ a) (++-cong refl (λ ✓as → bs₁≡bs₂ (a ∷ ✓as))) 164 | ++-cong {I} {T} {() ∷ as} refl bs₁≡bs₂ 165 | 166 | -- Concatenation respects and reflects termination 167 | 168 | ++-resp-✓ : ∀ {S T} {as : Trace S} {bs : Trace T} → (as ✓) → (bs ✓) → (as ++ bs ✓) 169 | ++-resp-✓ [] ✓bs = ✓bs 170 | ++-resp-✓ {Σ V F} (a ∷ ✓as) ✓bs = a ∷ ++-resp-✓ ✓as ✓bs 171 | ++-resp-✓ {I} (() ∷ ✓as) ✓bs 172 | 173 | ++-refl-✓₁ : ∀ {S T} {as : Trace S} {bs : Trace T} → (as ++ bs ✓) → (as ✓) 174 | ++-refl-✓₁ {I} {T} {[]} ✓cs = [] 175 | ++-refl-✓₁ {Σ V F} {T} {a ∷ as} (.a ∷ ✓cs) = a ∷ ++-refl-✓₁ ✓cs 176 | ++-refl-✓₁ {I} {T} {() ∷ as} ✓cs 177 | ++-refl-✓₁ {Σ V F} {T} {[]} () 178 | 179 | ++-refl-✓₂ : ∀ {S T} {as : Trace S} {bs : Trace T} → (as ++ bs ✓) → (bs ✓) 180 | ++-refl-✓₂ {I} {T} {[]} ✓cs = ✓cs 181 | ++-refl-✓₂ {Σ W F} {T} {a ∷ as} (.a ∷ ✓cs) = ++-refl-✓₂ {♭ F a} {T} {as} ✓cs 182 | ++-refl-✓₂ {I} {T} {() ∷ as} cs 183 | ++-refl-✓₂ {Σ V F} {T} {[]} () 184 | 185 | -- Concatenaton respects emptiness 186 | 187 | ++-resp-[] : ∀ {S T} {as : Trace S} {bs : Trace T} → 188 | (as ≡ []) → (bs ≡ []) → (as ++ bs ≡ []) 189 | ++-resp-[] {I} refl refl = refl 190 | ++-resp-[] {Σ V F} refl refl = refl 191 | 192 | -- Beta and eta equivalence for concatenation. 193 | -- Note that β₂ only holds when as is complete. 194 | 195 | ++-β₁ : ∀ {S T} (as : Trace S) → (bs : Trace T) → (front (as ++ bs) ≡ as) 196 | ++-β₁ {I} [] bs = refl 197 | ++-β₁ {I} (() ∷ as) bs 198 | ++-β₁ {Σ V F} [] bs = refl 199 | ++-β₁ {Σ V F} (a ∷ as) bs = cong (_∷_ a) (++-β₁ as bs) 200 | 201 | ++-β₂ : ∀ {S T} {as : Trace S} → (as ✓) → (bs : Trace T) → (back {S} (as ++ bs) ≡ bs) 202 | ++-β₂ {I} [] bs = refl 203 | ++-β₂ {Σ V F} (a ∷ as) bs = ++-β₂ as bs 204 | ++-β₂ {I} (() ∷ as) bs 205 | 206 | ++-η : ∀ {S T} (as : Trace (S & T)) → (front {S} as ++ back {S} as ≡ as) 207 | ++-η {I} [] = refl 208 | ++-η {I} (a ∷ as) = refl 209 | ++-η {Σ V F} [] = refl 210 | ++-η {Σ V F} (a ∷ as) = cong (_∷_ a) (++-η {♭ F a} as) 211 | 212 | -- Beta for concatenation with an incomplete trace 213 | 214 | ++-β₂-[] : ∀ {S T} {as : Trace S} → (¬ (as ✓)) → (bs : Trace T) → (back {S} (as ++ bs) ≡ []) 215 | ++-β₂-[] {I} {T} {[]} ¬✓[] bs = ⊥-elim (¬✓[] []) 216 | ++-β₂-[] {Σ V F} {T} {[]} ¬✓[] bs = refl 217 | ++-β₂-[] {Σ V F} {T} {a ∷ as} ¬✓a∷as bs = ++-β₂-[] (λ ✓as → ¬✓a∷as (a ∷ ✓as)) bs 218 | ++-β₂-[] {I} {T} {() ∷ as} ¬✓a∷as bs 219 | 220 | -- If the front of a trace is incomplete then its back is empty 221 | 222 | back≡[] : ∀ {S T as} → (¬ (front {S} {T} as ✓)) → (back {S} {T} as ≡ []) 223 | back≡[] {I} {T} {as} ¬✓as₁ = ⊥-elim (¬✓as₁ []) 224 | back≡[] {Σ V F} {T} {[]} ¬✓as₁ = refl 225 | back≡[] {Σ V F} {T} {a ∷ as} ¬✓a∷as₁ = back≡[] (λ ✓as₁ → ¬✓a∷as₁ (a ∷ ✓as₁)) 226 | 227 | -- Front respects completion, but only reflects it when T = I. 228 | 229 | front-resp-✓ : ∀ {S T} {as : Trace (S & T)} → (as ✓) → (front {S} as ✓) 230 | front-resp-✓ {I} ✓as = [] 231 | front-resp-✓ {Σ V F} (a ∷ ✓as) = a ∷ front-resp-✓ ✓as 232 | 233 | front-refl-✓ : ∀ {S} (as : Trace (S & I)) → (front {S} as ✓) → (as ✓) 234 | front-refl-✓ {I} [] ✓as₁ = [] 235 | front-refl-✓ {Σ V F} (a ∷ as) (.a ∷ ✓as₁) = a ∷ front-refl-✓ as ✓as₁ 236 | front-refl-✓ {I} (() ∷ as) ✓as₁ 237 | front-refl-✓ {Σ V F} [] () 238 | 239 | -- Back respects emptiness 240 | 241 | back-resp-[] : ∀ {S T as} → (as ≡ []) → (back {S} {T} as ≡ []) 242 | back-resp-[] {I} refl = refl 243 | back-resp-[] {Σ V F} refl = refl 244 | 245 | -- Back reflects completion for non-trivial T 246 | 247 | back-refl-✓ : ∀ {S T} {isΣ : IsΣ T} (as : Trace (S & T)) → (back {S} as ✓) → (as ✓) 248 | back-refl-✓ {I} as ✓as₂ = ✓as₂ 249 | back-refl-✓ {Σ V F} {Σ W G} (a ∷ as) ✓as₂ = a ∷ back-refl-✓ {♭ F a} as ✓as₂ 250 | back-refl-✓ {Σ V F} {I} {} as ✓as₂ 251 | back-refl-✓ {Σ V F} {Σ W G} [] () 252 | 253 | -- Back respects completion 254 | 255 | back-resp-✓ : ∀ {S} {T} {as : Trace (S & T)} → (as ✓) → (back {S} as ✓) 256 | back-resp-✓ {I} ✓as = ✓as 257 | back-resp-✓ {Σ W F} (a ∷ ✓as) = back-resp-✓ {♭ F a} ✓as 258 | 259 | -- Tensor plays nicely with concatenation when f reflects completion 260 | 261 | ⟦[&]⟧-++ : ∀ {S T U V} (f : Trace S → Trace T) (g : Trace U → Trace V) → 262 | (∀ cs → (f cs ✓) → (cs ✓)) → ∀ as bs → 263 | (f ⟦[&]⟧ g) (as ++ bs) ≡ (f as ++ g bs) 264 | ⟦[&]⟧-++ {S} {T} {U} {V} f g f-refl-✓ as bs = 265 | begin 266 | f (front {S} (as ++ bs)) ++ g (back {S} (as ++ bs)) 267 | ≡⟨ cong₂ _++_ (cong f (++-β₁ as bs)) refl ⟩ 268 | f as ++ g (back {S} (as ++ bs)) 269 | ≡⟨ ++-cong refl (λ ✓fas → cong g (++-β₂ (f-refl-✓ as ✓fas) bs)) ⟩ 270 | f as ++ g bs 271 | ∎ 272 | 273 | -- Tensor respects ≃ 274 | 275 | [&]-resp-≃ : ∀ {S T U V} {P₁ P₂ : S ⇒ T} {Q₁ Q₂ : U ⇒ V} → 276 | (⟦ P₁ ⟧ ≃ ⟦ P₂ ⟧) → (⟦ Q₁ ⟧ ≃ ⟦ Q₂ ⟧) → 277 | (⟦ P₁ [&] Q₁ ⟧ ≃ ⟦ P₂ [&] Q₂ ⟧) 278 | [&]-resp-≃ {S} {T} {U} {V} {P₁} {P₂} {Q₁} {Q₂} P₁≃P₂ Q₁≃Q₂ as = 279 | begin 280 | ⟦ P₁ [&] Q₁ ⟧ as 281 | ≡⟨ [&]-≃-⟦[&]⟧ P₁≃P₂ Q₁≃Q₂ as ⟩ 282 | (⟦ P₂ ⟧ ⟦[&]⟧ ⟦ Q₂ ⟧) as 283 | ≡⟨ sym ([&]-semantics P₂ Q₂ as) ⟩ 284 | ⟦ P₂ [&] Q₂ ⟧ as 285 | ∎ 286 | 287 | -- Tensor respects identity 288 | 289 | [&]-resp-done : ∀ S T → ⟦ done {S} [&] done {T} ⟧ ≃ ⟦ done {S & T} ⟧ 290 | [&]-resp-done S T as = 291 | begin 292 | ⟦ done {S} [&] done {T} ⟧ as 293 | ≡⟨ [&]-semantics (done {S}) (done {T}) as ⟩ 294 | front {S} as ++ back {S} as 295 | ≡⟨ ++-η {S} as ⟩ 296 | as 297 | ∎ 298 | 299 | -- Tensor respects composition when g₁ reflects completion 300 | 301 | ⟦[&]⟧-resp-⟦⟫⟧ : ∀ {S₁ S₂ T₁ T₂ U₁ U₂} → 302 | (f₁ : Trace S₁ → Trace T₁) → (g₁ : Trace T₁ → Trace U₁) → 303 | (f₂ : Trace S₂ → Trace T₂) → (g₂ : Trace T₂ → Trace U₂) → 304 | (∀ as → (g₁ as ✓) → (as ✓)) → 305 | (((f₁ ⟦⟫⟧ g₁) ⟦[&]⟧ (f₂ ⟦⟫⟧ g₂)) ≃ (f₁ ⟦[&]⟧ f₂) ⟦⟫⟧ (g₁ ⟦[&]⟧ g₂)) 306 | ⟦[&]⟧-resp-⟦⟫⟧ {S₁} f₁ g₁ f₂ g₂ g₁-refl-✓ as = 307 | sym (⟦[&]⟧-++ g₁ g₂ g₁-refl-✓ (f₁ (front {S₁} as)) (f₂ (back {S₁} as))) 308 | 309 | -- Tensor respects composition when f₁ respects completion and f₂ is strict 310 | 311 | ⟦[&]⟧-resp-⟦⟫⟧' : ∀ {S₁ S₂ T₁ T₂ U₁ U₂} → 312 | (f₁ : Trace S₁ → Trace T₁) → (g₁ : Trace T₁ → Trace U₁) → 313 | (f₂ : Trace S₂ → Trace T₂) → (g₂ : Trace T₂ → Trace U₂) → 314 | (∀ as → as ✓ → f₁ as ✓) → (f₂ [] ≡ []) → 315 | (((f₁ ⟦⟫⟧ g₁) ⟦[&]⟧ (f₂ ⟦⟫⟧ g₂)) ≃ (f₁ ⟦[&]⟧ f₂) ⟦⟫⟧ (g₁ ⟦[&]⟧ g₂)) 316 | ⟦[&]⟧-resp-⟦⟫⟧' {S₁} {S₂} {T₁} {T₂} f₁ g₁ f₂ g₂ f₁-resp-✓ f₂[]≡[] as with ✓? (f₁ (front as)) 317 | ⟦[&]⟧-resp-⟦⟫⟧' {S₁} {S₂} {T₁} {T₂} f₁ g₁ f₂ g₂ f₁-resp-✓ f₂[]≡[] as | yes ✓bs₁ = 318 | cong₂ _++_ (cong g₁ (sym (++-β₁ _ _))) (cong g₂ (sym (++-β₂ ✓bs₁ _))) 319 | ⟦[&]⟧-resp-⟦⟫⟧' {S₁} {S₂} {T₁} {T₂} f₁ g₁ f₂ g₂ f₁-resp-✓ f₂[]≡[] as | no ¬✓bs₁ = 320 | begin 321 | g₁ (f₁ as₁) ++ g₂ (f₂ as₂) 322 | ≡⟨ cong (_++_ (g₁ (f₁ as₁))) (cong g₂ (cong f₂ (back≡[] ¬✓as₁))) ⟩ 323 | g₁ (f₁ as₁) ++ g₂ (f₂ []) 324 | ≡⟨ cong (_++_ (g₁ (f₁ as₁))) (cong g₂ f₂[]≡[]) ⟩ 325 | g₁ (f₁ as₁) ++ g₂ [] 326 | ≡⟨ cong₂ _++_ (cong g₁ (sym (++-β₁ _ _))) (cong g₂ (sym (++-β₂-[] ¬✓bs₁ _))) ⟩ 327 | g₁ (front (f₁ as₁ ++ f₂ as₂)) ++ g₂ (back {T₁} (f₁ as₁ ++ f₂ as₂)) 328 | ∎ where 329 | as₁ = front {S₁} as 330 | as₂ = back {S₁} as 331 | ¬✓as₁ : ¬ as₁ ✓ 332 | ¬✓as₁ = λ as₁✓ → ¬✓bs₁ (f₁-resp-✓ as₁ as₁✓) 333 | 334 | -- Tensor respects composition when Q₁ is reflective 335 | 336 | [&]-resp-⟫ : ∀ {S₁ S₂ T₁ T₂ U₁ U₂} 337 | (P₁ : S₁ ⇒ T₁) {Q₁ : T₁ ⇒ U₁} (⟳Q₁ : Reflective Q₁) 338 | (P₂ : S₂ ⇒ T₂) (Q₂ : T₂ ⇒ U₂) → 339 | ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ ≃ ⟦ (P₁ [&] P₂) ⟫ (Q₁ [&] Q₂) ⟧ 340 | [&]-resp-⟫ P₁ {Q₁} ⟳Q₁ P₂ Q₂ as = 341 | begin 342 | ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ as 343 | ≡⟨ [&]-≃-⟦[&]⟧ (⟫-semantics P₁ Q₁) (⟫-semantics P₂ Q₂) as ⟩ 344 | ((⟦ P₁ ⟧ ⟦⟫⟧ ⟦ Q₁ ⟧) ⟦[&]⟧ (⟦ P₂ ⟧ ⟦⟫⟧ ⟦ Q₂ ⟧)) as 345 | ≡⟨ ⟦[&]⟧-resp-⟦⟫⟧ ⟦ P₁ ⟧ ⟦ Q₁ ⟧ ⟦ P₂ ⟧ ⟦ Q₂ ⟧ (⟦⟧-refl-✓ ⟳Q₁) as ⟩ 346 | ((⟦ P₁ ⟧ ⟦[&]⟧ ⟦ P₂ ⟧) ⟦⟫⟧ (⟦ Q₁ ⟧ ⟦[&]⟧ ⟦ Q₂ ⟧)) as 347 | ≡⟨ sym (⟫-≃-⟦⟫⟧ ([&]-semantics P₁ P₂) ([&]-semantics Q₁ Q₂) as) ⟩ 348 | ⟦ P₁ [&] P₂ ⟫ Q₁ [&] Q₂ ⟧ as 349 | ∎ 350 | 351 | -- Tensor respects composition when P₂ is strict 352 | 353 | [&]-resp-⟫' : ∀ {S₁ S₂ T₁ T₂ U₁ U₂} 354 | (P₁ : S₁ ⇒ T₁) (Q₁ : T₁ ⇒ U₁) 355 | {P₂ : S₂ ⇒ T₂} (#P₂ : Strict P₂) (Q₂ : T₂ ⇒ U₂) → 356 | ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ ≃ ⟦ (P₁ [&] P₂) ⟫ (Q₁ [&] Q₂) ⟧ 357 | [&]-resp-⟫' P₁ Q₁ {P₂} #P₂ Q₂ as = 358 | begin 359 | ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ as 360 | ≡⟨ [&]-≃-⟦[&]⟧ (⟫-semantics P₁ Q₁) (⟫-semantics P₂ Q₂) as ⟩ 361 | ((⟦ P₁ ⟧ ⟦⟫⟧ ⟦ Q₁ ⟧) ⟦[&]⟧ (⟦ P₂ ⟧ ⟦⟫⟧ ⟦ Q₂ ⟧)) as 362 | ≡⟨ ⟦[&]⟧-resp-⟦⟫⟧' ⟦ P₁ ⟧ ⟦ Q₁ ⟧ ⟦ P₂ ⟧ ⟦ Q₂ ⟧ (⟦⟧-resp-✓ P₁) (⟦⟧-resp-[] #P₂) as ⟩ 363 | ((⟦ P₁ ⟧ ⟦[&]⟧ ⟦ P₂ ⟧) ⟦⟫⟧ (⟦ Q₁ ⟧ ⟦[&]⟧ ⟦ Q₂ ⟧)) as 364 | ≡⟨ sym (⟫-≃-⟦⟫⟧ ([&]-semantics P₁ P₂) ([&]-semantics Q₁ Q₂) as) ⟩ 365 | ⟦ P₁ [&] P₂ ⟫ Q₁ [&] Q₂ ⟧ as 366 | ∎ 367 | 368 | -- Units and associator are equivalences 369 | 370 | unit₁-isEquiv : ∀ {S} → IsEquiv (unit₁ {S}) 371 | unit₁-isEquiv = isEquiv ∼-unit₁ ≃-refl 372 | 373 | unit₂-isEquiv : ∀ {S} → IsEquiv (unit₂ {S}) 374 | unit₂-isEquiv {S} = isEquiv (∼-unit₂ {S}) ≃-refl 375 | 376 | assoc-isEquiv : ∀ {S T U} → IsEquiv (assoc {S} {T} {U}) 377 | assoc-isEquiv {S} {T} = isEquiv (∼-assoc {S} {T}) ≃-refl 378 | 379 | unit₁⁻¹-isEquiv : ∀ {S} → IsEquiv (unit₁⁻¹ {S}) 380 | unit₁⁻¹-isEquiv = isEquiv (∼-sym ∼-unit₁) ≃-refl 381 | 382 | unit₂⁻¹-isEquiv : ∀ {S} → IsEquiv (unit₂⁻¹ {S}) 383 | unit₂⁻¹-isEquiv = isEquiv (∼-sym ∼-unit₂) ≃-refl 384 | 385 | assoc⁻¹-isEquiv : ∀ {S T U} → IsEquiv (assoc⁻¹ {S} {T} {U}) 386 | assoc⁻¹-isEquiv {S} = isEquiv (∼-sym (∼-assoc {S})) ≃-refl 387 | 388 | -- Equivalence respects & 389 | 390 | &-resp-∼ : ∀ {S T U V} → (S ∼ T) → (U ∼ V) → ((S & U) ∼ (T & V)) 391 | &-resp-∼ I U∼V = U∼V 392 | &-resp-∼ (Σ V F) U∼V = Σ V (♯ λ a → &-resp-∼ (♭ F a) U∼V) 393 | 394 | equiv-resp-⟦[&]⟧ : ∀ {S T U V} (S∼T : S ∼ T) (U∼V : U ∼ V) → 395 | ⟦ equiv S∼T ⟧ ⟦[&]⟧ ⟦ equiv U∼V ⟧ ≃ ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧ 396 | equiv-resp-⟦[&]⟧ I U∼V as = refl 397 | equiv-resp-⟦[&]⟧ (Σ V F) U∼V [] = refl 398 | equiv-resp-⟦[&]⟧ (Σ V F) U∼V (a ∷ as) = cong (_∷_ a) (equiv-resp-⟦[&]⟧ (♭ F a) U∼V as) 399 | 400 | equiv-resp-[&] : ∀ {S T U V} (S∼T : S ∼ T) (U∼V : U ∼ V) → 401 | ⟦ equiv S∼T [&] equiv U∼V ⟧ ≃ ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧ 402 | equiv-resp-[&] S∼T U∼V as = 403 | begin 404 | ⟦ equiv S∼T [&] equiv U∼V ⟧ as 405 | ≡⟨ [&]-semantics (equiv S∼T) (equiv U∼V) as ⟩ 406 | (⟦ equiv S∼T ⟧ ⟦[&]⟧ ⟦ equiv U∼V ⟧) as 407 | ≡⟨ equiv-resp-⟦[&]⟧ S∼T U∼V as ⟩ 408 | ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧ as 409 | ∎ 410 | 411 | [&]-isEquiv : ∀ {S T U V} {P : S ⇒ T} {Q : U ⇒ V} → 412 | (IsEquiv P) → (IsEquiv Q) → (IsEquiv (P [&] Q)) 413 | [&]-isEquiv {S} {T} {U} {V} {P} {Q} (isEquiv S∼T P≃S∼T) (isEquiv U∼V Q≃U∼V) = 414 | isEquiv (&-resp-∼ S∼T U∼V) λ as → 415 | begin 416 | ⟦ P [&] Q ⟧ as 417 | ≡⟨ [&]-resp-≃ P≃S∼T Q≃U∼V as ⟩ 418 | ⟦ equiv S∼T [&] equiv U∼V ⟧ as 419 | ≡⟨ equiv-resp-[&] S∼T U∼V as ⟩ 420 | ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧ as 421 | ∎ 422 | 423 | -- Isomorphisms 424 | 425 | unit₁-iso : ∀ {S} → ⟦ unit₁ {S} ⟫ unit₁⁻¹ {S} ⟧ ≃ ⟦ done ⟧ 426 | unit₁-iso = equiv-is-iso unit₁-isEquiv unit₁⁻¹-isEquiv 427 | 428 | unit₁⁻¹-iso : ∀ {S} → ⟦ unit₁⁻¹ {S} ⟫ unit₁ {S} ⟧ ≃ ⟦ done ⟧ 429 | unit₁⁻¹-iso = equiv-is-iso unit₁⁻¹-isEquiv unit₁-isEquiv 430 | 431 | unit₂-iso : ∀ {S} → ⟦ unit₂ {S} ⟫ unit₂⁻¹ {S} ⟧ ≃ ⟦ done ⟧ 432 | unit₂-iso {S} = equiv-is-iso (unit₂-isEquiv {S}) unit₂⁻¹-isEquiv 433 | 434 | unit₂⁻¹-iso : ∀ {S} → ⟦ unit₂⁻¹ {S} ⟫ unit₂ {S} ⟧ ≃ ⟦ done ⟧ 435 | unit₂⁻¹-iso {S} = equiv-is-iso unit₂⁻¹-isEquiv (unit₂-isEquiv {S}) 436 | 437 | assoc-iso : ∀ {S T U} → ⟦ assoc {S} {T} {U} ⟫ assoc⁻¹ {S} {T} {U} ⟧ ≃ ⟦ done ⟧ 438 | assoc-iso {S} {T} = equiv-is-iso (assoc-isEquiv {S} {T}) (assoc⁻¹-isEquiv {S} {T}) 439 | 440 | assoc⁻¹-iso : ∀ {S T U} → ⟦ assoc⁻¹ {S} {T} {U} ⟫ assoc {S} {T} {U} ⟧ ≃ ⟦ done ⟧ 441 | assoc⁻¹-iso {S} {T} = equiv-is-iso (assoc⁻¹-isEquiv {S} {T}) (assoc-isEquiv {S} {T}) 442 | 443 | -- Coherence conditions 444 | 445 | assoc-unit : ∀ {S T} → 446 | ⟦ done {S} [&] unit₁ {T} ⟧ ≃ ⟦ assoc {S} {I} {T} ⟫ unit₂ {S} [&] done {T} ⟧ 447 | assoc-unit {S} {T} = 448 | ≃-equiv ([&]-isEquiv (done-isEquiv {S}) (unit₁-isEquiv {T})) 449 | (⟫-isEquiv (assoc-isEquiv {S} {I} {T}) ([&]-isEquiv (unit₂-isEquiv {S}) (done-isEquiv {T}))) 450 | 451 | assoc-assoc : ∀ {S T U V} → 452 | ⟦ done {S} [&] assoc {T} {U} {V} ⟫ 453 | assoc {S} {T & U} {V} ⟫ 454 | assoc {S} {T} {U} [&] done {V} ⟧ ≃ 455 | ⟦ assoc {S} {T} {U & V} ⟫ assoc {S & T} {U} {V} ⟧ 456 | assoc-assoc {S} {T} {U} {V} = 457 | ≃-equiv 458 | (⟫-isEquiv ([&]-isEquiv (done-isEquiv {S}) (assoc-isEquiv {T} {U} {V})) 459 | (⟫-isEquiv (assoc-isEquiv {S} {T & U} {V}) 460 | ([&]-isEquiv (assoc-isEquiv {S} {T} {U}) done-isEquiv))) 461 | (⟫-isEquiv (assoc-isEquiv {S} {T} {U & V}) (assoc-isEquiv {S & T} {U} {V})) 462 | 463 | -- Concatenation plays nicely with associativity 464 | 465 | ⟦assoc⟧-++ : ∀ {S T U} → (as : Trace S) (bs : Trace T) (cs : Trace U) → 466 | ⟦assoc⟧ {S} (as ++ (bs ++ cs)) ≡ ((as ++ bs) ++ cs) 467 | ⟦assoc⟧-++ {I} {I} [] bs cs = refl 468 | ⟦assoc⟧-++ {I} {Σ W G} [] [] cs = refl 469 | ⟦assoc⟧-++ {I} {Σ W G} [] (b ∷ bs) cs = cong (_∷_ b) (⟦assoc⟧-++ {I} [] bs cs) 470 | ⟦assoc⟧-++ {Σ W F} [] bs cs = refl 471 | ⟦assoc⟧-++ {Σ W F} (a ∷ as) bs cs = cong (_∷_ a) (⟦assoc⟧-++ as bs cs) 472 | ⟦assoc⟧-++ {I} (() ∷ as) bs cs 473 | 474 | ⟦assoc⁻¹⟧-++ : ∀ {S T U} → (as : Trace S) (bs : Trace T) (cs : Trace U) → 475 | ⟦assoc⁻¹⟧ {S} ((as ++ bs) ++ cs) ≡ (as ++ (bs ++ cs)) 476 | ⟦assoc⁻¹⟧-++ {I} {I} [] bs cs = refl 477 | ⟦assoc⁻¹⟧-++ {I} {Σ W G} [] [] cs = refl 478 | ⟦assoc⁻¹⟧-++ {I} {Σ W G} [] (b ∷ bs) cs = cong (_∷_ b) (⟦assoc⁻¹⟧-++ {I} [] bs cs) 479 | ⟦assoc⁻¹⟧-++ {Σ W F} [] bs cs = refl 480 | ⟦assoc⁻¹⟧-++ {Σ W F} (a ∷ as) bs cs = cong (_∷_ a) (⟦assoc⁻¹⟧-++ as bs cs) 481 | ⟦assoc⁻¹⟧-++ {I} (() ∷ as) bs cs 482 | 483 | -- Front and back play well with associativity 484 | 485 | front-⟦assoc⟧ : ∀ {S T U} (as : Trace (S & (T & U))) → 486 | (front {S} as ≡ front {S} (front {S & T} (⟦assoc⟧ {S} as))) 487 | front-⟦assoc⟧ {I} as = refl 488 | front-⟦assoc⟧ {Σ V F} [] = refl 489 | front-⟦assoc⟧ {Σ V F} (a ∷ as) = cong (_∷_ a) (front-⟦assoc⟧ as) 490 | 491 | mid-⟦assoc⟧ : ∀ {S T U} (as : Trace (S & (T & U))) → 492 | (front {T} (back {S} as) ≡ back {S} (front {S & T} (⟦assoc⟧ {S} as))) 493 | mid-⟦assoc⟧ {I} {T} as = cong (front {T}) (sym (++-η {T} as)) 494 | mid-⟦assoc⟧ {Σ V F} {I} [] = refl 495 | mid-⟦assoc⟧ {Σ V F} {Σ W G} [] = refl 496 | mid-⟦assoc⟧ {Σ V F} (a ∷ as) = mid-⟦assoc⟧ {♭ F a} as 497 | 498 | back-⟦assoc⟧ : ∀ {S T U} (as : Trace (S & (T & U))) → 499 | (back {T} (back {S} as) ≡ back {S & T} (⟦assoc⟧ {S} as)) 500 | back-⟦assoc⟧ {I} {T} as = cong (back {T}) (sym (++-η {T} as)) 501 | back-⟦assoc⟧ {Σ V F} {I} [] = refl 502 | back-⟦assoc⟧ {Σ V F} {Σ W G} [] = refl 503 | back-⟦assoc⟧ {Σ V F} (a ∷ as) = back-⟦assoc⟧ {♭ F a} as 504 | 505 | -- Units are natural 506 | 507 | ⟦unit₁⟧-natural : ∀ {S T} (f : Trace S → Trace T) → 508 | (⟦done⟧ {I} ⟦[&]⟧ f) ⟦⟫⟧ ⟦unit₁⟧ ≃ ⟦unit₁⟧ ⟦⟫⟧ f 509 | ⟦unit₁⟧-natural f [] = refl 510 | ⟦unit₁⟧-natural f (a ∷ as) = refl 511 | 512 | unit₁-natural : ∀ {S T} (P : S ⇒ T) → 513 | ⟦ done {I} [&] P ⟫ unit₁ ⟧ ≃ ⟦ unit₁ ⟫ P ⟧ 514 | unit₁-natural P as = 515 | begin 516 | ⟦ done {I} [&] P ⟫ unit₁ ⟧ as 517 | ≡⟨ ⟫-≃-⟦⟫⟧ ([&]-semantics (done {I}) P) unit₁-semantics as ⟩ 518 | (⟦done⟧ {I} ⟦[&]⟧ ⟦ P ⟧ ⟦⟫⟧ ⟦unit₁⟧) as 519 | ≡⟨ ⟦unit₁⟧-natural ⟦ P ⟧ as ⟩ 520 | (⟦unit₁⟧ ⟦⟫⟧ ⟦ P ⟧) as 521 | ≡⟨ sym (⟫-≃-⟦⟫⟧ unit₁-semantics ≃-refl as) ⟩ 522 | ⟦ unit₁ ⟫ P ⟧ as 523 | ∎ 524 | 525 | ⟦unit₂⟧-natural : ∀ {S T} (f : Trace S → Trace T) → 526 | (f ⟦[&]⟧ ⟦done⟧ {I}) ⟦⟫⟧ ⟦unit₂⟧ ≃ ⟦unit₂⟧ ⟦⟫⟧ f 527 | ⟦unit₂⟧-natural {S} {T} f as = 528 | ++-β₁ (f (front {S} as)) (back {S} as) 529 | 530 | unit₂-natural : ∀ {S T} (P : S ⇒ T) → 531 | ⟦ P [&] done {I} ⟫ unit₂ ⟧ ≃ ⟦ unit₂ ⟫ P ⟧ 532 | unit₂-natural {S} {T} P as = 533 | begin 534 | ⟦ P [&] done {I} ⟫ unit₂ ⟧ as 535 | ≡⟨ ⟫-≃-⟦⟫⟧ ([&]-semantics P (done {I})) (unit₂-semantics {T}) as ⟩ 536 | (⟦ P ⟧ ⟦[&]⟧ ⟦done⟧ {I} ⟦⟫⟧ ⟦unit₂⟧) as 537 | ≡⟨ ⟦unit₂⟧-natural ⟦ P ⟧ as ⟩ 538 | (⟦unit₂⟧ ⟦⟫⟧ ⟦ P ⟧) as 539 | ≡⟨ sym (⟫-≃-⟦⟫⟧ (unit₂-semantics {S}) ≃-refl as) ⟩ 540 | ⟦ unit₂ ⟫ P ⟧ as 541 | ∎ 542 | 543 | -- Associativity is natural 544 | 545 | ⟦assoc⟧-natural : ∀ {S S' T T' U U'} 546 | (f : Trace S → Trace S') (g : Trace T → Trace T') (h : Trace U → Trace U') → 547 | ((f ⟦[&]⟧ (g ⟦[&]⟧ h)) ⟦⟫⟧ ⟦assoc⟧ {S'} {T'} {U'}) ≃ 548 | (⟦assoc⟧ {S} {T} {U} ⟦⟫⟧ ((f ⟦[&]⟧ g) ⟦[&]⟧ h)) 549 | ⟦assoc⟧-natural {S} {S'} {T} {T'} {U} {U'} f g h as = 550 | begin 551 | ⟦assoc⟧ {S'} (f as₁ ++ g as₂ ++ h as₃) 552 | ≡⟨ ⟦assoc⟧-++ (f as₁) (g as₂) (h as₃) ⟩ 553 | (f as₁ ++ g as₂) ++ h as₃ 554 | ≡⟨ cong₂ _++_ (cong₂ _++_ (cong f (front-⟦assoc⟧ as)) 555 | (cong g (mid-⟦assoc⟧ {S} as))) (cong h (back-⟦assoc⟧ {S} as)) ⟩ 556 | ((f ⟦[&]⟧ g) ⟦[&]⟧ h) ((as₁ ++ as₂) ++ as₃) 557 | ∎ where 558 | as₁ = front {S} as 559 | as₂ = front {T} (back {S} as) 560 | as₃ = back {T} (back {S} as) 561 | 562 | assoc-natural : ∀ {S S' T T' U U'} (P : S ⇒ S') (Q : T ⇒ T') (R : U ⇒ U') → 563 | ⟦ P [&] (Q [&] R) ⟫ assoc {S'} {T'} {U'} ⟧ ≃ 564 | ⟦ assoc {S} {T} {U} ⟫ (P [&] Q) [&] R ⟧ 565 | assoc-natural {S} {S'} {T} {T'} {U} {U'} P Q R as = 566 | begin 567 | ⟦ P [&] (Q [&] R) ⟫ assoc {S'} {T'} {U'} ⟧ as 568 | ≡⟨ ⟫-≃-⟦⟫⟧ ([&]-≃-⟦[&]⟧ {P = P} ≃-refl ([&]-semantics Q R)) (assoc-semantics {S'} {T'} {U'}) as ⟩ 569 | ((⟦ P ⟧ ⟦[&]⟧ (⟦ Q ⟧ ⟦[&]⟧ ⟦ R ⟧)) ⟦⟫⟧ ⟦assoc⟧ {S'} {T'} {U'}) as 570 | ≡⟨ ⟦assoc⟧-natural ⟦ P ⟧ ⟦ Q ⟧ ⟦ R ⟧ as ⟩ 571 | (⟦assoc⟧ {S} {T} {U} ⟦⟫⟧ ((⟦ P ⟧ ⟦[&]⟧ ⟦ Q ⟧) ⟦[&]⟧ ⟦ R ⟧)) as 572 | ≡⟨ sym (⟫-≃-⟦⟫⟧ (assoc-semantics {S} {T} {U}) ([&]-≃-⟦[&]⟧ ([&]-semantics P Q) ≃-refl) as) ⟩ 573 | ⟦ assoc {S} {T} {U} ⟫ (P [&] Q) [&] R ⟧ as 574 | ∎ 575 | --------------------------------------------------------------------------------