diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,36 +1,43 @@ -Release notes for agda2hs v1.3 +Release notes for agda2hs v1.4 ============================== Changes ------- Changes to agda2hs: -- Increased Agda base version to 2.7 -- Increased bounds to support GHC 9.8.4 and GHC 9.10.2 -- Re-implemented the canonicity check for instances to be simpler but more robust -- Added {-# COMPILE AGDA2HS ... inline #-} pragma for marking definitions to be inlined during compilation to Haskell -- Added {-# COMPILE AGDA2HS ... tuple #-} pragma for compiling record types in Agda to a tuple type in Haskell -- Non-erased implicit arguments and instance arguments are now compiled to regular arguments in Haskell -- Non-erased module parameters are now compiled to regular arguments in Haskell -- Rank-N Haskell types are now supported -- Added `agda2hs locate` command printing the path to the agda2hs prelude `.agda-lib` file +- Increased Agda base version to 2.8. +- Increased bounds to support GHC 9.12.2. +- agda2hs will now skip compilation of files that are up-to-date. +- Added support for multi-parameter type classes. +- Added support for quantified constraints. +- Agda record types that compile to a Haskell data type are now + required to have the `no-eta-equality` directive. +- agda2hs will now assume that any modules under the `Haskell.` + namespace are part of the trusted FFI with Haskell. + Concretely, no code will be generated for these modules and + the `Haskell.` prefix will be dropped from the module name. Additions to the agda2hs Prelude: -- New module `Haskell.Extra.Dec` for working with decidability proofs (compiled to `Bool`) -- New module `Haskell.Extra.Refinement` for working with refinement types (compiled to the base type) -- New module `Haskell.Extra.Erase` for working with erased types (compiled to `()`) -- New module `Haskell.Extra.Sigma` for working with dependent pair types (compiled to tuples) -- New module `Haskell.Extra.Loop` providing a safe `loop` function (using an erased fuel argument) -- New module `Haskell.Extra.Delay` providing a `Delay` monad for non-termination (compiled to pure functions in Haskell) -- New function `the` in `Haskell.Prim` for generating Haskell type annotations -- Added properties to `Haskell.Law.Equality`: `subst`, `subst0` -- Added properties to `Haskell.Law.Bool`: `ifFlip`, `ifTrueEqThen`, `ifFalseEqThen` -- Added properties to `Haskell.Law.List`: `map-concatMap`, `map-<*>-recomp`, `concatMap-++-distr` -- Added proofs that many of the instances defined in the prelude are lawful +- The builtin sort `Set` has been renamed to `Type` in the agda2hs Prelude +- The `Rezz` type defined in `Haskell.Extra.Erase` has been renamed to `Singleton`. +- The bindings to the Haskell `base` library are now located under `lib/base` + to allow for adding bindings to other Haskell libraries. +- Added new module `Haskell.Control.Exception` with the `assert` function + which can be used to assert any decidable property, with the decidability + proof being compiled to a boolean check in Haskell. +- Added new module `Haskell.Data.Maybe` with `fromMaybe` and other functions. +- Added new module `Haskell.Data.List` with functions `nub`, `deleteAll`, and `sort` + together with some of their properties. +- Added new modules `Haskell.Data.Map` and `Haskell.Data.Set` from the + `containers` package, together with a number of their properties. + These libraries are part of the new `containers` package located in `lib/containers`. +- Added properties of boolean values and operations under `Haskell.Law.Bool`. +- Added laws for the `Num` type class and its instances under `Haskell.Law.Num`. -See https://github.com/agda/agda2hs/issues?q=milestone%3A1.3+is%3Apr for the full list of changes. +See https://github.com/agda/agda2hs/issues?q=milestone%3A1.4+is%3Apr for the full list of changes. + Fixed issues ------------ -See https://github.com/agda/agda2hs/issues?q=milestone%3A1.3+is%3Aissue for the full list of fixed issues. +See https://github.com/agda/agda2hs/issues?q=milestone%3A1.4+is%3Aissue for the full list of fixed issues. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2024 Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette, Viktor Csimma, Aleksander Wolska, Paul Bittner, Andreas Källberg, Bohdan Liesnikov, and Jakob Naucke. +Copyright 2025 Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette, Viktor Csimma, Aleksander Wolska, Paul Bittner, Andreas Källberg, Bohdan Liesnikov, Jakob Naucke, and Heinrich Apfelmus. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: diff --git a/agda2hs.agda-lib b/agda2hs.agda-lib deleted file mode 100644 --- a/agda2hs.agda-lib +++ /dev/null @@ -1,4 +0,0 @@ -name: agda2hs -depend: -include: lib -flags: -W noUnsupportedIndexedMatch --erasure diff --git a/agda2hs.cabal b/agda2hs.cabal --- a/agda2hs.cabal +++ b/agda2hs.cabal @@ -1,11 +1,11 @@ cabal-version: 2.4 name: agda2hs -version: 1.3 +version: 1.4 license: BSD-3-Clause license-file: LICENSE -author: Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette, Viktor Csimma, Aleksander Wolska, Paul Bittner, Andreas Källberg, Bohdan Liesnikov, and Jakob Naucke +author: Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette, Viktor Csimma, Aleksander Wolska, Paul Bittner, Andreas Källberg, Bohdan Liesnikov, Jakob Naucke, and Heinrich Apfelmus maintainer: jesper@sikanda.be -copyright: 2024 Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette, Viktor Csimma, Aleksander Wolska, Paul Bittner, Andreas Källberg, Bohdan Liesnikov, and Jakob Naucke +copyright: 2025 Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette, Viktor Csimma, Aleksander Wolska, Paul Bittner, Andreas Källberg, Bohdan Liesnikov, Jakob Naucke, and Heinrich Apfelmus category: Language, Compiler build-type: Simple synopsis: Compiling Agda code to readable Haskell. @@ -18,8 +18,9 @@ extra-doc-files: CHANGELOG.md README.md -data-files: agda2hs.agda-lib - lib/**/*.agda +data-files: + lib/base/base.agda-lib + lib/base/**/*.agda source-repository head type: git @@ -44,23 +45,25 @@ Agda2Hs.Compile.Utils, Agda2Hs.Compile.Var, Agda2Hs.Config, - Agda2Hs.HsUtils, + Agda2Hs.Language.Haskell, + Agda2Hs.Language.Haskell.Pretty, + Agda2Hs.Language.Haskell.Utils, Agda2Hs.Pragma, Agda2Hs.Render, AgdaInternals, Paths_agda2hs autogen-modules: Paths_agda2hs - build-depends: base >= 4.13 && < 4.21, - Agda >= 2.7.0 && < 2.8.0, + build-depends: base >= 4.13 && < 4.22, + Agda >= 2.8.0 && < 2.9.0, bytestring >= 0.11.5 && < 0.13, - containers >= 0.6 && < 0.8, + containers >= 0.6 && < 0.9, unordered-containers >= 0.2.19 && < 0.3, mtl (>= 2.2 && < 2.3) || (>= 2.3.1 && < 2.4), transformers >= 0.6 && < 0.7, monad-control >= 1.0 && < 1.1, directory >= 1.2.6.2 && < 1.4, - filepath >= 1.4.1.0 && < 1.5, + filepath >= 1.4.1.0 && < 1.6, haskell-src-exts >= 1.23 && < 1.25, syb >= 0.7.2 && < 0.8, text >= 2.0.2 && < 2.2, @@ -78,4 +81,5 @@ NamedFieldPuns PatternSynonyms NondecreasingIndentation + OverloadedStrings ghc-options: -rtsopts diff --git a/lib/Haskell/Control/Monad.agda b/lib/Haskell/Control/Monad.agda deleted file mode 100644 --- a/lib/Haskell/Control/Monad.agda +++ /dev/null @@ -1,11 +0,0 @@ -module Haskell.Control.Monad where - -open import Haskell.Prim -open import Haskell.Prim.Bool -open import Haskell.Prim.Monad -open import Haskell.Prim.String -open import Haskell.Extra.Erase - -guard : {{ MonadFail m }} → (b : Bool) → m (Erase (b ≡ True)) -guard True = return (Erased refl) -guard False = fail "Guard was not True" diff --git a/lib/Haskell/Extra/Dec.agda b/lib/Haskell/Extra/Dec.agda deleted file mode 100644 --- a/lib/Haskell/Extra/Dec.agda +++ /dev/null @@ -1,48 +0,0 @@ -module Haskell.Extra.Dec where - -open import Haskell.Prelude -open import Haskell.Extra.Refinement -open import Agda.Primitive - -private variable - ℓ : Level - P : Set - -@0 Reflects : Set ℓ → Bool → Set ℓ -Reflects P True = P -Reflects P False = P → ⊥ - -of : {b : Bool} → if b then P else (P → ⊥) → Reflects P b -of {b = False} np = np -of {b = True} p = p - -invert : ∀ {b} → Reflects P b → if b then P else (P → ⊥) -invert {b = False} np = np -invert {b = True} p = p - -extractTrue : ∀ { b } → ⦃ true : b ≡ True ⦄ → Reflects P b → P -extractTrue {b = True} p = p - -extractFalse : ∀ { b } → ⦃ true : b ≡ False ⦄ → Reflects P b → (P → ⊥) -extractFalse {b = False} np = np - -mapReflects : ∀ {cond} → (a → b) → (b → a) - → Reflects a cond → Reflects b cond -mapReflects {cond = False} f g x = x ∘ g -mapReflects {cond = True} f g x = f x - -Dec : ∀ {ℓ} → @0 Set ℓ → Set ℓ -Dec P = ∃ Bool (Reflects P) -{-# COMPILE AGDA2HS Dec inline #-} - -mapDec : {@0 a b : Set} - → @0 (a → b) - → @0 (b → a) - → Dec a → Dec b -mapDec f g (True ⟨ x ⟩) = True ⟨ f x ⟩ -mapDec f g (False ⟨ h ⟩) = False ⟨ h ∘ g ⟩ -{-# COMPILE AGDA2HS mapDec transparent #-} - -ifDec : Dec a → (@0 {{a}} → b) → (@0 {{a → ⊥}} → b) → b -ifDec (b ⟨ p ⟩) x y = if b then (λ where {{refl}} → x {{p}}) else (λ where {{refl}} → y {{p}}) -{-# COMPILE AGDA2HS ifDec inline #-} diff --git a/lib/Haskell/Extra/Delay.agda b/lib/Haskell/Extra/Delay.agda deleted file mode 100644 --- a/lib/Haskell/Extra/Delay.agda +++ /dev/null @@ -1,39 +0,0 @@ -{-# OPTIONS --sized-types #-} - -module Haskell.Extra.Delay where - -open import Agda.Builtin.Size public - -open import Haskell.Prelude -open import Haskell.Prim.Thunk -open import Haskell.Extra.Refinement - -private variable - x y z : a - @0 i : Size - -data Delay (a : Set) (@0 i : Size) : Set where - now : a → Delay a i - later : Thunk (Delay a) i → Delay a i - -data HasResult (x : a) : Delay a i → Set where - now : HasResult x (now x) - later : HasResult x (y .force) → HasResult x (later y) - -runDelay : {@0 x : a} (y : Delay a ∞) → @0 HasResult x y → a -runDelay (now x) now = x -runDelay (later y) (later p) = runDelay (y .force) p - -runDelaySound : {@0 x : a} (y : Delay a ∞) → (@0 hr : HasResult x y) → runDelay y hr ≡ x -runDelaySound (now x) now = refl -runDelaySound (later y) (later hr) = runDelaySound (y .force) hr - --- tryDelay and unDelay cannot and should not be compiled to Haskell, --- so they are marked as erased. -@0 tryDelay : (y : Delay a ∞) → Nat → Maybe (∃ a (λ x → HasResult x y)) -tryDelay (now x) _ = Just (x ⟨ now ⟩) -tryDelay (later y) zero = Nothing -tryDelay (later y) (suc n) = fmap (mapRefine later) (tryDelay (y .force) n) - -@0 unDelay : (y : Delay a ∞) (n : Nat) → @0 {IsJust (tryDelay y n)} → a -unDelay y n {p} = fromJust (tryDelay y n) {p} .value diff --git a/lib/Haskell/Extra/Erase.agda b/lib/Haskell/Extra/Erase.agda deleted file mode 100644 --- a/lib/Haskell/Extra/Erase.agda +++ /dev/null @@ -1,82 +0,0 @@ -module Haskell.Extra.Erase where - - open import Agda.Primitive - open import Agda.Builtin.Sigma - open import Agda.Builtin.Equality - - open import Haskell.Prim - open import Haskell.Prim.List - open import Haskell.Extra.Refinement - open import Haskell.Law.Equality - - private variable - @0 x y : a - @0 xs : List a - - record Erase (@0 a : Set ℓ) : Set ℓ where - instance constructor iErased - field @0 {{get}} : a - open Erase public - {-# COMPILE AGDA2HS Erase tuple #-} - - pattern Erased x = iErased {{x}} - - infixr 4 ⟨_⟩_ - record Σ0 (@0 a : Set) (b : @0 a → Set) : Set where - constructor ⟨_⟩_ - field - @0 proj₁ : a - proj₂ : b proj₁ - open Σ0 public - {-# COMPILE AGDA2HS Σ0 unboxed #-} - - pattern <_> x = record { proj₁ = _ ; proj₂ = x } - - -- Resurrection of erased values - Rezz : (@0 x : a) → Set - Rezz x = ∃ _ (x ≡_) - - {-# COMPILE AGDA2HS Rezz inline #-} - - pattern rezz x = x ⟨ refl ⟩ - - instance - rezz-id : {x : a} → Rezz x - rezz-id = rezz _ - {-# COMPILE AGDA2HS rezz-id inline #-} - - rezzCong : {@0 a : Set} {@0 x : a} (f : a → b) → Rezz x → Rezz (f x) - rezzCong f (x ⟨ p ⟩) = f x ⟨ cong f p ⟩ - {-# COMPILE AGDA2HS rezzCong inline #-} - - rezzCong2 : (f : a → b → c) → Rezz x → Rezz y → Rezz (f x y) - rezzCong2 f (x ⟨ p ⟩) (y ⟨ q ⟩) = f x y ⟨ cong₂ f p q ⟩ - {-# COMPILE AGDA2HS rezzCong2 inline #-} - - rezzHead : Rezz (x ∷ xs) → Rezz x - rezzHead {x = x} (ys ⟨ p ⟩) = - head ys - ⟨ subst (λ ys → ⦃ @0 _ : NonEmpty ys ⦄ → x ≡ head ys) - p refl ⟩ - where instance @0 ne : NonEmpty ys - ne = subst NonEmpty p itsNonEmpty - {-# COMPILE AGDA2HS rezzHead inline #-} - - rezzTail : Rezz (x ∷ xs) → Rezz xs - rezzTail {xs = xs} (ys ⟨ p ⟩) = - tail ys - ⟨ subst (λ ys → ⦃ @0 _ : NonEmpty ys ⦄ → xs ≡ tail ys) - p refl ⟩ - where instance @0 ne : NonEmpty ys - ne = subst NonEmpty p itsNonEmpty - {-# COMPILE AGDA2HS rezzTail inline #-} - - rezzErase : {@0 a : Set} {@0 x : a} → Rezz (Erased x) - rezzErase {x = x} = Erased x ⟨ refl ⟩ - {-# COMPILE AGDA2HS rezzErase inline #-} - - erase-injective : Erased x ≡ Erased y → x ≡ y - erase-injective refl = refl - - inspect_by_ : (x : a) → (Rezz x → b) → b - inspect x by f = f (rezz x) diff --git a/lib/Haskell/Extra/Loop.agda b/lib/Haskell/Extra/Loop.agda deleted file mode 100644 --- a/lib/Haskell/Extra/Loop.agda +++ /dev/null @@ -1,26 +0,0 @@ - -open import Haskell.Prelude - -module Haskell.Extra.Loop where - -data Fuel (f : a → Either a b) : (x : Either a b) → Set where - done : ∀ {y} → Fuel f (Right y) - more : ∀ {x} → Fuel f (f x) → Fuel f (Left x) - -tryFuel : (f : a → Either a b) (x : Either a b) (n : Nat) → Maybe (Fuel f x) -tryFuel f x zero = Nothing -tryFuel f (Left x) (suc n) = more <$> tryFuel f (f x) n -tryFuel f (Right y) (suc n) = Just done - -getFuel : (f : a → Either a b) (x : Either a b) (n : Nat) - → {IsJust (tryFuel f x n)} → Fuel f x -getFuel f x n {p} = fromJust (tryFuel f x n) {p} - -module _ {a b : Set} where - loop : (f : a → Either a b) (x : a) → @0 Fuel f (Left x) → b - loop f x (more n) = go (f x) n - where - go : (x : Either a b) → @0 Fuel f x → b - go (Left x) (more n) = go (f x) n - go (Right y) done = y -{-# COMPILE AGDA2HS loop #-} diff --git a/lib/Haskell/Extra/Refinement.agda b/lib/Haskell/Extra/Refinement.agda deleted file mode 100644 --- a/lib/Haskell/Extra/Refinement.agda +++ /dev/null @@ -1,28 +0,0 @@ -module Haskell.Extra.Refinement where - -open import Haskell.Prelude -open import Agda.Primitive - -private variable - ℓ ℓ′ : Level - -record ∃ (a : Set ℓ) (@0 P : a → Set ℓ′) : Set (ℓ ⊔ ℓ′) where - constructor _⟨_⟩ - field - value : a - @0 proof : P value -open ∃ public -{-# COMPILE AGDA2HS ∃ unboxed #-} - -mapRefine : {@0 P Q : a → Set ℓ} (@0 f : ∀ {x} → P x → Q x) → ∃ a P → ∃ a Q -mapRefine f (x ⟨ p ⟩) = x ⟨ f p ⟩ - -{-# COMPILE AGDA2HS mapRefine transparent #-} - -refineMaybe : {@0 P : a → Set ℓ} - → (mx : Maybe a) → @0 (∀ {x} → mx ≡ Just x → P x) - → Maybe (∃ a P) -refineMaybe Nothing f = Nothing -refineMaybe (Just x) f = Just (x ⟨ f refl ⟩) - -{-# COMPILE AGDA2HS refineMaybe transparent #-} diff --git a/lib/Haskell/Extra/Sigma.agda b/lib/Haskell/Extra/Sigma.agda deleted file mode 100644 --- a/lib/Haskell/Extra/Sigma.agda +++ /dev/null @@ -1,17 +0,0 @@ -module Haskell.Extra.Sigma where - -record Σ (a : Set) (b : @0 a → Set) : Set where - constructor _,_ - field - fst : a - snd : b fst -open Σ public -{-# COMPILE AGDA2HS Σ tuple #-} - -infix 2 Σ-syntax - -Σ-syntax : (a : Set) → (@0 a → Set) → Set -Σ-syntax = Σ -{-# COMPILE AGDA2HS Σ-syntax inline #-} - -syntax Σ-syntax a (λ x → b) = Σ[ x ∈ a ] b diff --git a/lib/Haskell/Law.agda b/lib/Haskell/Law.agda deleted file mode 100644 --- a/lib/Haskell/Law.agda +++ /dev/null @@ -1,20 +0,0 @@ -module Haskell.Law where - -open import Haskell.Prim -open import Haskell.Prim.Bool - -open import Haskell.Law.Def public -open import Haskell.Law.Applicative public -open import Haskell.Law.Bool public -open import Haskell.Law.Either public -open import Haskell.Law.Eq public -open import Haskell.Law.Equality public -open import Haskell.Law.Functor public -open import Haskell.Law.Int public -open import Haskell.Law.Integer public -open import Haskell.Law.List public -open import Haskell.Law.Maybe public -open import Haskell.Law.Monad public -open import Haskell.Law.Monoid public -open import Haskell.Law.Nat public -open import Haskell.Law.Ord public diff --git a/lib/Haskell/Law/Applicative.agda b/lib/Haskell/Law/Applicative.agda deleted file mode 100644 --- a/lib/Haskell/Law/Applicative.agda +++ /dev/null @@ -1,7 +0,0 @@ -module Haskell.Law.Applicative where - -open import Haskell.Law.Applicative.Def public -open import Haskell.Law.Applicative.Either public -open import Haskell.Law.Applicative.IO public -open import Haskell.Law.Applicative.List public -open import Haskell.Law.Applicative.Maybe public diff --git a/lib/Haskell/Law/Applicative/Def.agda b/lib/Haskell/Law/Applicative/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Applicative/Def.agda +++ /dev/null @@ -1,41 +0,0 @@ -module Haskell.Law.Applicative.Def where - -open import Haskell.Prim -open import Haskell.Prim.Functor - -open import Haskell.Prim.Applicative -open import Haskell.Prim.Monoid -open import Haskell.Prim.Tuple - -open import Haskell.Law.Functor - -record IsLawfulApplicative (F : Set → Set) ⦃ iAppF : Applicative F ⦄ : Set₁ where - field - overlap ⦃ super ⦄ : IsLawfulFunctor F - - -- Identity: pure id <*> v = v - identity : (v : F a) → (pure id <*> v) ≡ v - - -- Composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w) - composition : {a b c : Set} → (u : F (b → c)) (v : F (a → b)) (w : F a) - → (pure _∘_ <*> u <*> v <*> w) ≡ (u <*> (v <*> w)) - - -- Homomorphism: pure f <*> pure x = pure (f x) - homomorphism : {a b : Set} → (f : a → b) (x : a) - → (Applicative._<*>_ iAppF (pure f) (pure x)) ≡ (pure (f x)) - - -- Interchange: u <*> pure y = pure ($ y) <*> u - interchange : {a b : Set} → (u : F (a → b)) (y : a) - → (u <*> (pure y)) ≡ (pure (_$ y) <*> u) - - -- fmap f x = pure f <*> x - functor : (f : a → b) (x : F a) → (fmap f x) ≡ ((pure f) <*> x) - -open IsLawfulApplicative ⦃ ... ⦄ public - -instance postulate - iLawfulApplicativeFun : IsLawfulApplicative (λ b → a → b) - - iLawfulApplicativeTuple₂ : ⦃ Monoid a ⦄ → Applicative (a ×_) - - iLawfulApplicativeTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Applicative (a × b ×_) diff --git a/lib/Haskell/Law/Applicative/Either.agda b/lib/Haskell/Law/Applicative/Either.agda deleted file mode 100644 --- a/lib/Haskell/Law/Applicative/Either.agda +++ /dev/null @@ -1,29 +0,0 @@ -module Haskell.Law.Applicative.Either where - -open import Haskell.Prim -open import Haskell.Prim.Either - -open import Haskell.Prim.Applicative - -open import Haskell.Law.Applicative.Def - -open import Haskell.Law.Functor.Either - -instance - iLawfulApplicativeEither : IsLawfulApplicative (Either a) - -- (λ { true → true ; false → false }) - - iLawfulApplicativeEither .identity = λ { (Left _) → refl; (Right _) → refl } - - iLawfulApplicativeEither .composition = - λ { (Left _) _ _ → refl - ; (Right _) (Left _) _ → refl - ; (Right _) (Right _) (Left _) → refl - ; (Right _) (Right _) (Right _) → refl - } - - iLawfulApplicativeEither .homomorphism _ _ = refl - - iLawfulApplicativeEither .interchange = λ { (Left _) _ → refl; (Right _) _ → refl } - - iLawfulApplicativeEither .functor = λ { _ (Left _) → refl; _ (Right _) → refl } diff --git a/lib/Haskell/Law/Applicative/IO.agda b/lib/Haskell/Law/Applicative/IO.agda deleted file mode 100644 --- a/lib/Haskell/Law/Applicative/IO.agda +++ /dev/null @@ -1,12 +0,0 @@ -module Haskell.Law.Applicative.IO where - -open import Haskell.Prim -open import Haskell.Prim.IO - -open import Haskell.Prim.Applicative - -open import Haskell.Law.Applicative.Def - -open import Haskell.Law.Functor.IO - -instance postulate iLawfulApplicativeIO : IsLawfulApplicative IO diff --git a/lib/Haskell/Law/Applicative/List.agda b/lib/Haskell/Law/Applicative/List.agda deleted file mode 100644 --- a/lib/Haskell/Law/Applicative/List.agda +++ /dev/null @@ -1,54 +0,0 @@ -module Haskell.Law.Applicative.List where - -open import Haskell.Prim -open import Haskell.Prim.List - -open import Haskell.Prim.Applicative -open import Haskell.Prim.Functor - -open import Haskell.Law.Applicative.Def - -open import Haskell.Law.Equality -open import Haskell.Law.Functor.List -open import Haskell.Law.List - -private - identityList : {a : Set} → (v : List a) → (pure id <*> v) ≡ v - identityList [] = refl - identityList (x ∷ xs) - rewrite identityList xs - = refl - - compositionList : {a b c : Set} → (u : List (b → c)) (v : List (a → b)) (w : List a) - → ((((pure _∘_) <*> u) <*> v) <*> w) ≡ (u <*> (v <*> w)) - compositionList [] _ _ = refl - compositionList (u ∷ us) v w - rewrite sym $ concatMap-++-distr (map (u ∘_) v) (((pure _∘_) <*> us) <*> v) (λ f → map f w) - | sym $ map-<*>-recomp v w u - | compositionList us v w - = refl - - interchangeList : {a b : Set} → (u : List (a → b)) → (y : a) - → (u <*> (pure y)) ≡ (pure (_$ y) <*> u) - interchangeList [] _ = refl - interchangeList (x ∷ xs) y - rewrite interchangeList xs y - = refl - - functorList : {a b : Set} → (f : a → b) → (x : List a) - → (fmap f x) ≡ ((pure f) <*> x) - functorList _ [] = refl - functorList f (x ∷ xs) - rewrite functorList f xs - | ++-[] (map f xs) - | ++-[] (f x ∷ map f xs) - = refl - -instance - iLawfulApplicativeList : IsLawfulApplicative List - iLawfulApplicativeList = λ where - .identity → identityList - .composition → compositionList - .homomorphism _ x → refl - .interchange → interchangeList - .functor → functorList diff --git a/lib/Haskell/Law/Applicative/Maybe.agda b/lib/Haskell/Law/Applicative/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Law/Applicative/Maybe.agda +++ /dev/null @@ -1,27 +0,0 @@ -module Haskell.Law.Applicative.Maybe where - -open import Haskell.Prim -open import Haskell.Prim.Maybe - -open import Haskell.Prim.Applicative - -open import Haskell.Law.Applicative.Def - -open import Haskell.Law.Functor.Maybe - -instance - iLawfulApplicativeMaybe : IsLawfulApplicative Maybe - iLawfulApplicativeMaybe .identity = λ { Nothing → refl; (Just _) → refl } - - iLawfulApplicativeMaybe .composition = - λ { Nothing _ _ → refl - ; (Just _) Nothing _ → refl - ; (Just _) (Just _) Nothing → refl - ; (Just _) (Just _) (Just _) → refl - } - - iLawfulApplicativeMaybe .homomorphism _ _ = refl - - iLawfulApplicativeMaybe .interchange = λ { Nothing _ → refl; (Just _) _ → refl } - - iLawfulApplicativeMaybe .functor = λ { _ Nothing → refl; _ (Just _) → refl } diff --git a/lib/Haskell/Law/Bool.agda b/lib/Haskell/Law/Bool.agda deleted file mode 100644 --- a/lib/Haskell/Law/Bool.agda +++ /dev/null @@ -1,86 +0,0 @@ -module Haskell.Law.Bool where - -open import Haskell.Prim -open import Haskell.Prim.Bool - -open import Haskell.Law.Equality - --------------------------------------------------- --- && - -&&-sym : ∀ (a b : Bool) → (a && b) ≡ (b && a) -&&-sym False False = refl -&&-sym False True = refl -&&-sym True False = refl -&&-sym True True = refl - -&&-semantics : ∀ (a b : Bool) → a ≡ True → b ≡ True → (a && b) ≡ True -&&-semantics True True _ _ = refl - -&&-leftAssoc : ∀ (a b c : Bool) → (a && b && c) ≡ True → ((a && b) && c) ≡ True -&&-leftAssoc True True True _ = refl - -&&-leftAssoc' : ∀ (a b c : Bool) → (a && b && c) ≡ ((a && b) && c) -&&-leftAssoc' False b c = refl -&&-leftAssoc' True b c = refl - -&&-leftTrue : ∀ (a b : Bool) → (a && b) ≡ True → a ≡ True -&&-leftTrue True True _ = refl - -&&-leftTrue' : ∀ (a b c : Bool) → a ≡ (b && c) → a ≡ True → c ≡ True -&&-leftTrue' .True True True _ refl = refl - -&&-rightTrue : ∀ (a b : Bool) → (a && b) ≡ True → b ≡ True -&&-rightTrue True True _ = refl - -&&-rightTrue' : ∀ (a b c : Bool) → a ≡ (b && c) → a ≡ True → b ≡ True -&&-rightTrue' .True True True _ refl = refl - --------------------------------------------------- --- || - --- if a then True else b - -||-excludedMiddle : ∀ (a b : Bool) → (a || not a) ≡ True -||-excludedMiddle False _ = refl -||-excludedMiddle True _ = refl - -||-leftTrue : ∀ (a b : Bool) → a ≡ True → (a || b) ≡ True -||-leftTrue .True b refl = refl - -||-rightTrue : ∀ (a b : Bool) → b ≡ True → (a || b) ≡ True -||-rightTrue False .True refl = refl -||-rightTrue True .True refl = refl - --------------------------------------------------- --- not - -not-not : ∀ (a : Bool) → not (not a) ≡ a -not-not False = refl -not-not True = refl - -not-involution : ∀ (a b : Bool) → a ≡ not b → not a ≡ b -not-involution .(not b) b refl = not-not b - --------------------------------------------------- --- if_then_else_ - -ifFlip : ∀ (b) - → (t : {{not b ≡ True}} → a) - → (e : {{not b ≡ False}} → a) - → (if not b then t else e) ≡ - (if b then (e {{not-involution _ _ it}}) else t {{not-involution _ _ it}}) -ifFlip False _ _ = refl -ifFlip True _ _ = refl - -ifTrueEqThen : ∀ (b : Bool) - → {thn : {{b ≡ True}} → a} - → {els : {{b ≡ False}} → a} - → (pf : b ≡ True) → (if b then thn else els) ≡ thn {{pf}} -ifTrueEqThen .True refl = refl - -ifFalseEqElse : ∀ (b : Bool) - → {thn : {{b ≡ True}} → a} - → {els : {{b ≡ False}} → a} - → (pf : b ≡ False) → (if b then thn else els) ≡ els {{pf}} -ifFalseEqElse .False refl = refl diff --git a/lib/Haskell/Law/Def.agda b/lib/Haskell/Law/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Def.agda +++ /dev/null @@ -1,6 +0,0 @@ -module Haskell.Law.Def where - -open import Haskell.Prim - -Injective : (a → b) → Set _ -Injective f = ∀ {x y} → f x ≡ f y → x ≡ y diff --git a/lib/Haskell/Law/Either.agda b/lib/Haskell/Law/Either.agda deleted file mode 100644 --- a/lib/Haskell/Law/Either.agda +++ /dev/null @@ -1,12 +0,0 @@ -module Haskell.Law.Either where - -open import Haskell.Prim -open import Haskell.Prim.Either - -open import Haskell.Law.Def - -Left-injective : Injective (Left {a}{b}) -Left-injective refl = refl - -Right-injective : Injective (Right {a}{b}) -Right-injective refl = refl diff --git a/lib/Haskell/Law/Eq.agda b/lib/Haskell/Law/Eq.agda deleted file mode 100644 --- a/lib/Haskell/Law/Eq.agda +++ /dev/null @@ -1,4 +0,0 @@ -module Haskell.Law.Eq where - -open import Haskell.Law.Eq.Def public -open import Haskell.Law.Eq.Instances public diff --git a/lib/Haskell/Law/Eq/Def.agda b/lib/Haskell/Law/Eq/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Eq/Def.agda +++ /dev/null @@ -1,68 +0,0 @@ -module Haskell.Law.Eq.Def where - -open import Haskell.Prim -open import Haskell.Prim.Bool -open import Haskell.Prim.Double - -open import Haskell.Prim.Eq - -open import Haskell.Extra.Dec - -open import Haskell.Law.Bool -open import Haskell.Law.Equality - -record IsLawfulEq (e : Set) ⦃ iEq : Eq e ⦄ : Set₁ where - field - isEquality : ∀ (x y : e) → Reflects (x ≡ y) (x == y) - - equality : ∀ (x y : e) → (x == y) ≡ True → x ≡ y - equality x y h = extractTrue ⦃ h ⦄ (isEquality x y) - - nequality : ∀ (x y : e) → (x == y) ≡ False → (x ≡ y → ⊥) - nequality x y h = extractFalse ⦃ h ⦄ (isEquality x y) - - -- contrapositive of nequality - equality' : ∀ (x y : e) → x ≡ y → (x == y) ≡ True - equality' x y h with x == y in eq - ... | False = magic (nequality x y eq h) - ... | True = refl - - -- contrapositive of equality - nequality' : ∀ (x y : e) → (x ≡ y → ⊥) → (x == y) ≡ False - nequality' x y h with x == y in eq - ... | True = magic (h (equality x y eq)) - ... | False = refl - -open IsLawfulEq ⦃ ... ⦄ public - --- Reflexivity: x == x = True -eqReflexivity : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ - → ∀ (x : e) → (x == x) ≡ True -eqReflexivity x = equality' x x refl - --- Symmetry: x == y = y == x -eqSymmetry : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ - → ∀ (x y : e) → (x == y) ≡ (y == x) -eqSymmetry x y with x == y in eq -... | True = sym (equality' y x (sym (equality x y eq))) -... | False = sym (nequality' y x (λ qe → (nequality x y eq) (sym qe))) - --- Transitivity: if x == y && y == z = True, then x == z = True -eqTransitivity : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ - → ∀ (x y z : e) → ((x == y) && (y == z)) ≡ True → (x == z) ≡ True -eqTransitivity x y z h - = equality' x z (trans - (equality x y (&&-leftTrue (x == y) (y == z) h)) - (equality y z (&&-rightTrue (x == y) (y == z) h))) - --- Extensionality: if x == y = True and f is a function whose return type is an instance of Eq, then f x == f y = True -eqExtensionality : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ - → ⦃ iEq : Eq a ⦄ → ⦃ iLawfulEq : IsLawfulEq a ⦄ - → ∀ ( x y : e ) ( f : e → a ) → (x == y) ≡ True → (f x == f y) ≡ True -eqExtensionality x y f h = equality' (f x) (f y) (cong f (equality x y h)) - --- Negation: x /= y = not (x == y) -eqNegation : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ - → ∀ { x y : e } → (x /= y) ≡ not (x == y) -eqNegation = refl - diff --git a/lib/Haskell/Law/Eq/Instances.agda b/lib/Haskell/Law/Eq/Instances.agda deleted file mode 100644 --- a/lib/Haskell/Law/Eq/Instances.agda +++ /dev/null @@ -1,138 +0,0 @@ -module Haskell.Law.Eq.Instances where - -open import Agda.Builtin.Char.Properties renaming (primCharToNatInjective to c2n-injective) -open import Agda.Builtin.Word.Properties renaming (primWord64ToNatInjective to w2n-injective) - -open import Haskell.Prim -open import Haskell.Prim.Eq - -open import Haskell.Prim.Either using ( Either; Left; Right ) -open import Haskell.Prim.Int using ( Int; int64 ) -open import Haskell.Prim.Maybe -open import Haskell.Prim.Ord using ( Ordering; LT; GT; EQ ) -open import Haskell.Prim.Tuple -open import Haskell.Prim.Word using ( Word ) - -open import Haskell.Extra.Dec using ( mapReflects ) - -open import Haskell.Law.Eq.Def -open import Haskell.Law.Equality - -open import Haskell.Law.Either -open import Haskell.Law.Int -open import Haskell.Law.Integer -open import Haskell.Law.List using ( ∷-injective-left; ∷-injective-right ) -open import Haskell.Law.Maybe -open import Haskell.Law.Nat - -open _×_×_ - -instance - iLawfulEqNat : IsLawfulEq Nat - iLawfulEqNat .isEquality zero zero = refl - iLawfulEqNat .isEquality zero (suc _) = λ () - iLawfulEqNat .isEquality (suc _) zero = λ () - iLawfulEqNat .isEquality (suc x) (suc y) = mapReflects - (cong suc) - suc-injective - (isEquality x y) - - iLawfulEqWord : IsLawfulEq Word - iLawfulEqWord .isEquality x y - with (w2n x) in h₁ | (w2n y) in h₂ - ... | a | b = mapReflects - (λ h → w2n-injective x y $ sym $ trans (trans h₂ $ sym h) (sym h₁)) - (λ h → trans (sym $ trans (cong w2n (sym h)) h₁) h₂) - (isEquality a b) - - iLawfulEqBool : IsLawfulEq Bool - iLawfulEqBool .isEquality False False = refl - iLawfulEqBool .isEquality False True = λ() - iLawfulEqBool .isEquality True False = λ() - iLawfulEqBool .isEquality True True = refl - - iLawfulEqChar : IsLawfulEq Char - iLawfulEqChar .isEquality x y - with (c2n x) in h₁ | (c2n y) in h₂ - ... | a | b = mapReflects { a ≡ b } { x ≡ y } { eqNat a b } - (λ h → c2n-injective x y $ sym $ trans (trans h₂ $ sym h) (sym h₁)) - (λ h → trans (sym $ trans (cong c2n (sym h)) h₁) h₂) - (isEquality a b) - - iLawfulEqEither : ⦃ iEqA : Eq a ⦄ → ⦃ iEqB : Eq b ⦄ - → ⦃ IsLawfulEq a ⦄ → ⦃ IsLawfulEq b ⦄ - → IsLawfulEq (Either a b) - iLawfulEqEither .isEquality (Left _) (Right _) = λ () - iLawfulEqEither .isEquality (Right _) (Left _) = λ () - iLawfulEqEither .isEquality (Left x) (Left y) = mapReflects - (cong Left) (Left-injective) (isEquality x y) - iLawfulEqEither .isEquality (Right x) (Right y) = mapReflects - (cong Right) (Right-injective) (isEquality x y) - - iLawfulEqInt : IsLawfulEq Int - iLawfulEqInt .isEquality (int64 x) (int64 y) = mapReflects - (cong int64) int64-injective (isEquality x y) - - iLawfulEqInteger : IsLawfulEq Integer - iLawfulEqInteger .isEquality (pos n) (pos m) = mapReflects - (cong pos) pos-injective (isEquality n m) - iLawfulEqInteger .isEquality (pos _) (negsuc _) = λ () - iLawfulEqInteger .isEquality (negsuc _) (pos _) = λ () - iLawfulEqInteger .isEquality (negsuc n) (negsuc m) = mapReflects - (cong negsuc) neg-injective (isEquality n m) - - iLawfulEqList : ⦃ iEqA : Eq a ⦄ → ⦃ IsLawfulEq a ⦄ → IsLawfulEq (List a) - iLawfulEqList .isEquality [] [] = refl - iLawfulEqList .isEquality [] (_ ∷ _) = λ () - iLawfulEqList .isEquality (_ ∷ _) [] = λ () - iLawfulEqList .isEquality (x ∷ xs) (y ∷ ys) - with (x == y) in h₁ - ... | True = mapReflects - (λ h → cong₂ (_∷_) (equality x y h₁) h) - ∷-injective-right - (isEquality xs ys) - ... | False = λ h → (nequality x y h₁) (∷-injective-left h) - - iLawfulEqMaybe : ⦃ iEqA : Eq a ⦄ → ⦃ IsLawfulEq a ⦄ → IsLawfulEq (Maybe a) - iLawfulEqMaybe .isEquality Nothing Nothing = refl - iLawfulEqMaybe .isEquality Nothing (Just _) = λ() - iLawfulEqMaybe .isEquality (Just _) Nothing = λ() - iLawfulEqMaybe .isEquality (Just x) (Just y) = mapReflects - (cong Just) Just-injective (isEquality x y) - - iLawfulEqOrdering : IsLawfulEq Ordering - iLawfulEqOrdering .isEquality LT LT = refl - iLawfulEqOrdering .isEquality LT EQ = λ() - iLawfulEqOrdering .isEquality LT GT = λ() - iLawfulEqOrdering .isEquality EQ LT = λ() - iLawfulEqOrdering .isEquality EQ EQ = refl - iLawfulEqOrdering .isEquality EQ GT = λ() - iLawfulEqOrdering .isEquality GT LT = λ() - iLawfulEqOrdering .isEquality GT EQ = λ() - iLawfulEqOrdering .isEquality GT GT = refl - - iLawfulEqTuple₂ : ⦃ iEqA : Eq a ⦄ ⦃ iEqB : Eq b ⦄ - → ⦃ IsLawfulEq a ⦄ → ⦃ IsLawfulEq b ⦄ - → IsLawfulEq (a × b) - iLawfulEqTuple₂ .isEquality (x₁ , x₂) (y₁ , y₂) - with (x₁ == y₁) in h₁ - ... | True = mapReflects - (λ h → cong₂ _,_ (equality x₁ y₁ h₁) h) - (cong snd) - (isEquality x₂ y₂) - ... | False = λ h → exFalso (equality' x₁ y₁ (cong fst h)) h₁ - - iLawfulEqTuple₃ : ⦃ iEqA : Eq a ⦄ ⦃ iEqB : Eq b ⦄ ⦃ iEqC : Eq c ⦄ - → ⦃ IsLawfulEq a ⦄ → ⦃ IsLawfulEq b ⦄ → ⦃ IsLawfulEq c ⦄ - → IsLawfulEq (a × b × c) - iLawfulEqTuple₃ .isEquality (x₁ , x₂ , x₃) (y₁ , y₂ , y₃) - with (x₁ == y₁) in h₁ - ... | True = mapReflects - (λ h → cong₂ (λ a (b , c) → a , b , c) (equality x₁ y₁ h₁) h) - (cong λ h → snd3 h , thd3 h) - (isEquality (x₂ , x₃) (y₂ , y₃)) - ... | False = λ h → exFalso (equality' x₁ y₁ (cong fst3 h)) h₁ - - - iLawfulEqUnit : IsLawfulEq ⊤ - iLawfulEqUnit .isEquality tt tt = refl diff --git a/lib/Haskell/Law/Equality.agda b/lib/Haskell/Law/Equality.agda deleted file mode 100644 --- a/lib/Haskell/Law/Equality.agda +++ /dev/null @@ -1,67 +0,0 @@ -module Haskell.Law.Equality where - -open import Haskell.Prim - -open import Agda.Builtin.TrustMe - -_≠_ : {A : Set} → A → A → Set -_≠_ a b = a ≡ b → ⊥ - -infix 4 _≠_ - --------------------------------------------------- --- Basic Laws - -cong : {A B : Set} → ∀ (f : A → B) {x y} → x ≡ y → f x ≡ f y -cong f refl = refl - -cong₂ : ∀ (f : a → b → c) {x y u v} → x ≡ y → u ≡ v → f x u ≡ f y v -cong₂ f refl refl = refl - -sym : ∀ {A : Set} {x y : A} → x ≡ y → y ≡ x -sym refl = refl - -trans : ∀ {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z -trans refl refl = refl - -subst : ∀ {A : Set} (P : A → Set) {x y : A} → x ≡ y → P x → P y -subst P refl z = z - --------------------------------------------------- --- Scary Things - -trustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y -trustMe = primTrustMe - --------------------------------------------------- --- ≡-Reasoning - -infix 1 begin_ -infixr 2 _≡⟨⟩_ step-≡ step-≡˘ -infix 3 _∎ - -begin_ : ∀{x y : a} → x ≡ y → x ≡ y -begin_ x≡y = x≡y - -_≡⟨⟩_ : ∀ (x {y} : a) → x ≡ y → x ≡ y -_ ≡⟨⟩ x≡y = x≡y - -step-≡ : ∀ (x {y z} : a) → y ≡ z → x ≡ y → x ≡ z -step-≡ _ y≡z x≡y = trans x≡y y≡z - -step-≡˘ : ∀ (x {y z} : a) → y ≡ z → y ≡ x → x ≡ z -step-≡˘ _ y≡z y≡x = trans (sym y≡x) y≡z - -_∎ : ∀ (x : a) → x ≡ x -_∎ _ = refl - -syntax step-≡ x y≡z x≡y = x ≡⟨ x≡y ⟩ y≡z -syntax step-≡˘ x y≡z y≡x = x ≡˘⟨ y≡x ⟩ y≡z - - -------------------------------------------------- --- Utility Functions - -subst0 : {@0 a : Set} (@0 p : @0 a → Set) {@0 x y : a} → @0 x ≡ y → p x → p y -subst0 p refl z = z -{-# COMPILE AGDA2HS subst0 transparent #-} diff --git a/lib/Haskell/Law/Function.agda b/lib/Haskell/Law/Function.agda deleted file mode 100644 --- a/lib/Haskell/Law/Function.agda +++ /dev/null @@ -1,171 +0,0 @@ -module Haskell.Law.Function where - -open import Haskell.Prim -open import Haskell.Law.Equality - - -{-| -Pointwise equality on functions. -This says that two functions produce the same -result for all input values. --} -infix 4 _≗_ -_≗_ : ∀ {A B : Set} (f g : A → B) → Set -f ≗ g = ∀ a → f a ≡ g a - -Commutative : {a : Set} → (a → a → a) → Set -Commutative _+_ = ∀ x y → x + y ≡ y + x - -Associative : {a : Set} → (a → a → a) → Set -Associative _+_ = ∀ x y z → (x + y) + z ≡ x + (y + z) - -Identityˡ : {a : Set} → (a → a → a) → a → Set -Identityˡ _+_ 𝟘 = ∀ x → 𝟘 + x ≡ x - -Identityʳ : {a : Set} → (a → a → a) → a → Set -Identityʳ _+_ 𝟘 = ∀ x → x + 𝟘 ≡ x - -Distributiveˡ : {a : Set} → (_+_ : a → a → a) → (_*_ : a → a → a) → Set -Distributiveˡ _+_ _*_ = ∀ x y z → x * (y + z) ≡ (x * y) + (x * z) - -Distributiveʳ : {a : Set} → (_+_ : a → a → a) → (_*_ : a → a → a) → Set -Distributiveʳ _+_ _*_ = ∀ x y z → (y + z) * x ≡ (y * x) + (z * x) - -{-| -Definition of homomorphism over unary functions. -A function φ is homomorphic w.r.t. some function or structure f -when it preserves this structure in its target domain b -(where this structure is called g). --} -Homomorphism₁ : ∀ {a b : Set} (f : a → a) (g : b → b) - → (φ : a → b) → Set -Homomorphism₁ f g φ = φ ∘ f ≗ g ∘ φ - -{-| -Definition of homomorphism over binary functions. -A function φ is homomorphic w.r.t. some structure _+ᵃ_ -when it preserves this structure in its target domain b -(where this structure is called _+ᵇ_). --} -Homomorphism₂ : ∀ {a b : Set} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) - → (φ : a → b) → Set -Homomorphism₂ _+ᵃ_ _+ᵇ_ φ = ∀ x y → φ (x +ᵃ y) ≡ φ x +ᵇ φ y - -record Embedding₂ {a b : Set} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) : Set where - field - hom : Homomorphism₂ _+ᵃ_ _+ᵇ_ φ - embed : φ⁻¹ ∘ φ ≗ id - -record MonoidEmbedding₂ {a b : Set} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) (0ᵃ : a) (0ᵇ : b) : Set where - field - embedding : Embedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ - 0-hom : φ 0ᵃ ≡ 0ᵇ - -map-comm : ∀ {a b : Set} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) - → Embedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ - → Commutative _+ᵇ_ - → Commutative _+ᵃ_ -map-comm _+ᵃ_ _+ᵇ_ φ φ⁻¹ proj comm x y = - begin - x +ᵃ y - ≡˘⟨ embed (x +ᵃ y) ⟩ - φ⁻¹ (φ (x +ᵃ y)) - ≡⟨ cong φ⁻¹ (hom x y) ⟩ - φ⁻¹ (φ x +ᵇ φ y) - ≡⟨ cong φ⁻¹ (comm (φ x) (φ y)) ⟩ - φ⁻¹ (φ y +ᵇ φ x) - ≡˘⟨ cong φ⁻¹ (hom y x) ⟩ - φ⁻¹ (φ (y +ᵃ x)) - ≡⟨ embed (y +ᵃ x) ⟩ - y +ᵃ x - ∎ - where - open Embedding₂ proj - -map-assoc : ∀ {a b : Set} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) - → Embedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ - → Associative _+ᵇ_ - → Associative _+ᵃ_ -map-assoc _+ᵃ_ _+ᵇ_ φ φ⁻¹ proj assoc x y z = - begin - (x +ᵃ y) +ᵃ z - ≡⟨ sym (embed ((x +ᵃ y) +ᵃ z)) ⟩ - φ⁻¹ (φ ((x +ᵃ y) +ᵃ z)) - ≡⟨ cong φ⁻¹ (hom (x +ᵃ y) z) ⟩ - φ⁻¹ (φ (x +ᵃ y) +ᵇ φ z) - ≡⟨ cong φ⁻¹ (cong (_+ᵇ φ z) (hom x y)) ⟩ - φ⁻¹ ((φ x +ᵇ φ y) +ᵇ φ z) - ≡⟨ cong φ⁻¹ (assoc (φ x) (φ y) (φ z)) ⟩ - φ⁻¹ (φ x +ᵇ (φ y +ᵇ φ z)) - ≡⟨ cong φ⁻¹ (cong (φ x +ᵇ_) (sym (hom y z))) ⟩ - φ⁻¹ (φ x +ᵇ φ (y +ᵃ z)) - ≡⟨ cong φ⁻¹ (sym (hom x (y +ᵃ z))) ⟩ - φ⁻¹ (φ (x +ᵃ (y +ᵃ z))) - ≡⟨ embed (x +ᵃ (y +ᵃ z)) ⟩ - x +ᵃ (y +ᵃ z) - ∎ - where - open Embedding₂ proj - -map-idˡ : ∀ {a b : Set} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) (0ᵃ : a) (0ᵇ : b) - → MonoidEmbedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ 0ᵃ 0ᵇ - → Identityˡ _+ᵇ_ 0ᵇ - → Identityˡ _+ᵃ_ 0ᵃ -map-idˡ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ membed idˡ x = - 0ᵃ +ᵃ x ≡⟨ sym (embed (0ᵃ +ᵃ x)) ⟩ - g (f (0ᵃ +ᵃ x)) ≡⟨ cong g (hom 0ᵃ x) ⟩ - g (f 0ᵃ +ᵇ f x) ≡⟨ cong g (cong (_+ᵇ f x) 0-hom) ⟩ - g (0ᵇ +ᵇ f x) ≡⟨ cong g (idˡ (f x)) ⟩ - g (f x) ≡⟨ embed x ⟩ - x ∎ - where - open MonoidEmbedding₂ membed - open Embedding₂ embedding - -map-idʳ : ∀ {a b : Set} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) (0ᵃ : a) (0ᵇ : b) - → MonoidEmbedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ 0ᵃ 0ᵇ - → Identityʳ _+ᵇ_ 0ᵇ - → Identityʳ _+ᵃ_ 0ᵃ -map-idʳ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ membed idʳ x = - x +ᵃ 0ᵃ ≡⟨ sym (embed (x +ᵃ 0ᵃ)) ⟩ - g (f (x +ᵃ 0ᵃ)) ≡⟨ cong g (hom x 0ᵃ) ⟩ - g (f x +ᵇ f 0ᵃ) ≡⟨ cong g (cong (f x +ᵇ_) 0-hom) ⟩ - g (f x +ᵇ 0ᵇ) ≡⟨ cong g (idʳ (f x)) ⟩ - g (f x) ≡⟨ embed x ⟩ - x ∎ - where - open MonoidEmbedding₂ membed - open Embedding₂ embedding - -module _ {a b : Set} - (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) - (_*ᵃ_ : a → a → a) (_*ᵇ_ : b → b → b) - (f : a → b) (g : b → a) - (embed : g ∘ f ≗ id) - (+-hom : Homomorphism₂ _+ᵃ_ _+ᵇ_ f) - (*-hom : Homomorphism₂ _*ᵃ_ _*ᵇ_ f) - where - - map-distributeˡ : Distributiveˡ _+ᵇ_ _*ᵇ_ → Distributiveˡ _+ᵃ_ _*ᵃ_ - map-distributeˡ distributeˡ-b x y z = - x *ᵃ (y +ᵃ z) ≡˘⟨ embed (x *ᵃ (y +ᵃ z)) ⟩ - g (f (x *ᵃ (y +ᵃ z))) ≡⟨ cong g (*-hom x (y +ᵃ z)) ⟩ - g (f x *ᵇ f (y +ᵃ z)) ≡⟨ cong g (cong (f x *ᵇ_) (+-hom y z)) ⟩ - g (f x *ᵇ (f y +ᵇ f z)) ≡⟨ cong g (distributeˡ-b (f x) (f y) (f z)) ⟩ - g ((f x *ᵇ f y) +ᵇ (f x *ᵇ f z)) ≡˘⟨ cong g (cong (_+ᵇ (f x *ᵇ f z)) (*-hom x y)) ⟩ - g (f (x *ᵃ y) +ᵇ (f x *ᵇ f z)) ≡˘⟨ cong g (cong (f (x *ᵃ y) +ᵇ_) (*-hom x z)) ⟩ - g (f (x *ᵃ y) +ᵇ f (x *ᵃ z)) ≡˘⟨ cong g (+-hom (x *ᵃ y) (x *ᵃ z)) ⟩ - g (f ((x *ᵃ y) +ᵃ (x *ᵃ z))) ≡⟨ embed ((x *ᵃ y) +ᵃ (x *ᵃ z)) ⟩ - (x *ᵃ y) +ᵃ (x *ᵃ z) ∎ - - map-distributeʳ : Distributiveʳ _+ᵇ_ _*ᵇ_ → Distributiveʳ _+ᵃ_ _*ᵃ_ - map-distributeʳ distributeʳ-b x y z = - (y +ᵃ z) *ᵃ x ≡˘⟨ embed ((y +ᵃ z) *ᵃ x) ⟩ - g (f ((y +ᵃ z) *ᵃ x)) ≡⟨ cong g (*-hom (y +ᵃ z) x) ⟩ - g (f (y +ᵃ z) *ᵇ f x) ≡⟨ cong g (cong (_*ᵇ f x) (+-hom y z)) ⟩ - g ((f y +ᵇ f z) *ᵇ f x) ≡⟨ cong g (distributeʳ-b (f x) (f y) (f z)) ⟩ - g ((f y *ᵇ f x) +ᵇ (f z *ᵇ f x)) ≡˘⟨ cong g (cong (_+ᵇ (f z *ᵇ f x)) (*-hom y x)) ⟩ - g (f (y *ᵃ x) +ᵇ (f z *ᵇ f x)) ≡˘⟨ cong g (cong (f (y *ᵃ x) +ᵇ_) (*-hom z x)) ⟩ - g (f (y *ᵃ x) +ᵇ f (z *ᵃ x)) ≡˘⟨ cong g (+-hom (y *ᵃ x) (z *ᵃ x)) ⟩ - g (f ((y *ᵃ x) +ᵃ (z *ᵃ x))) ≡⟨ embed ((y *ᵃ x) +ᵃ (z *ᵃ x)) ⟩ - (y *ᵃ x) +ᵃ (z *ᵃ x) ∎ diff --git a/lib/Haskell/Law/Functor.agda b/lib/Haskell/Law/Functor.agda deleted file mode 100644 --- a/lib/Haskell/Law/Functor.agda +++ /dev/null @@ -1,7 +0,0 @@ -module Haskell.Law.Functor where - -open import Haskell.Law.Functor.Def public -open import Haskell.Law.Functor.Either public -open import Haskell.Law.Functor.IO public -open import Haskell.Law.Functor.List public -open import Haskell.Law.Functor.Maybe public diff --git a/lib/Haskell/Law/Functor/Def.agda b/lib/Haskell/Law/Functor/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Functor/Def.agda +++ /dev/null @@ -1,24 +0,0 @@ -module Haskell.Law.Functor.Def where - -open import Haskell.Prim -open import Haskell.Prim.Tuple - -open import Haskell.Prim.Functor - -record IsLawfulFunctor (F : Set → Set) ⦃ iFuncF : Functor F ⦄ : Set₁ where - field - -- Identity: fmap id == id - identity : (fa : F a) → (fmap id) fa ≡ id fa - - -- Composition: fmap (f . g) == fmap f . fmap g - composition : (fa : F a) (f : a → b) (g : b → c) - → fmap (g ∘ f) fa ≡ (fmap g ∘ fmap f) fa - -open IsLawfulFunctor ⦃ ... ⦄ public - -instance postulate - iLawfulFunctorFun : IsLawfulFunctor (λ b → a → b) - - iLawfulFunctorTuple₂ : IsLawfulFunctor (a ×_) - - iLawfulFunctorTuple₃ : IsLawfulFunctor (a × b ×_) diff --git a/lib/Haskell/Law/Functor/Either.agda b/lib/Haskell/Law/Functor/Either.agda deleted file mode 100644 --- a/lib/Haskell/Law/Functor/Either.agda +++ /dev/null @@ -1,14 +0,0 @@ -module Haskell.Law.Functor.Either where - -open import Haskell.Prim -open import Haskell.Prim.Either - -open import Haskell.Prim.Functor - -open import Haskell.Law.Functor.Def - -instance - iLawfulFunctorEither : IsLawfulFunctor (Either a) - iLawfulFunctorEither .identity = λ { (Left _) → refl; (Right _) → refl } - - iLawfulFunctorEither .composition = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } diff --git a/lib/Haskell/Law/Functor/IO.agda b/lib/Haskell/Law/Functor/IO.agda deleted file mode 100644 --- a/lib/Haskell/Law/Functor/IO.agda +++ /dev/null @@ -1,10 +0,0 @@ -module Haskell.Law.Functor.IO where - -open import Haskell.Prim -open import Haskell.Prim.IO - -open import Haskell.Prim.Functor - -open import Haskell.Law.Functor.Def - -instance postulate isLawFulFunctorIO : IsLawfulFunctor IO diff --git a/lib/Haskell/Law/Functor/List.agda b/lib/Haskell/Law/Functor/List.agda deleted file mode 100644 --- a/lib/Haskell/Law/Functor/List.agda +++ /dev/null @@ -1,25 +0,0 @@ -module Haskell.Law.Functor.List where - -open import Haskell.Prim -open import Haskell.Prim.List - -open import Haskell.Prim.Functor - -open import Haskell.Law.Equality -open import Haskell.Law.Functor.Def - -private - identityList : (fa : List a) → (fmap id) fa ≡ id fa - identityList [] = refl - identityList (x ∷ xs) rewrite identityList xs = refl - - compositionList : (fa : List a) → (f : a → b) → (g : b → c) - → fmap (g ∘ f) fa ≡ (fmap g ∘ fmap f) fa - compositionList [] _ _ = refl - compositionList (x ∷ xs) f g rewrite compositionList xs f g = refl - -instance - iLawfulFunctorList : IsLawfulFunctor List - iLawfulFunctorList = λ where - .identity → identityList - .composition → compositionList diff --git a/lib/Haskell/Law/Functor/Maybe.agda b/lib/Haskell/Law/Functor/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Law/Functor/Maybe.agda +++ /dev/null @@ -1,14 +0,0 @@ -module Haskell.Law.Functor.Maybe where - -open import Haskell.Prim -open import Haskell.Prim.Maybe - -open import Haskell.Prim.Functor - -open import Haskell.Law.Functor.Def - -instance - iLawfulFunctorMaybe : IsLawfulFunctor Maybe - iLawfulFunctorMaybe .identity = λ { Nothing → refl; (Just _) → refl } - - iLawfulFunctorMaybe .composition = λ { Nothing _ _ → refl; (Just _) _ _ → refl } diff --git a/lib/Haskell/Law/Int.agda b/lib/Haskell/Law/Int.agda deleted file mode 100644 --- a/lib/Haskell/Law/Int.agda +++ /dev/null @@ -1,9 +0,0 @@ -module Haskell.Law.Int where - -open import Haskell.Prim -open import Haskell.Prim.Int using ( int64 ) - -open import Haskell.Law.Def - -int64-injective : Injective int64 -int64-injective refl = refl diff --git a/lib/Haskell/Law/Integer.agda b/lib/Haskell/Law/Integer.agda deleted file mode 100644 --- a/lib/Haskell/Law/Integer.agda +++ /dev/null @@ -1,11 +0,0 @@ -module Haskell.Law.Integer where - -open import Haskell.Prim - -open import Haskell.Law.Def - -pos-injective : Injective pos -pos-injective refl = refl - -neg-injective : Injective negsuc -neg-injective refl = refl diff --git a/lib/Haskell/Law/List.agda b/lib/Haskell/Law/List.agda deleted file mode 100644 --- a/lib/Haskell/Law/List.agda +++ /dev/null @@ -1,145 +0,0 @@ -module Haskell.Law.List where - -open import Haskell.Law.Equality -open import Haskell.Prim renaming (addNat to _+ₙ_) -open import Haskell.Prim.Foldable -open import Haskell.Prim.List -open import Haskell.Prim.Applicative - -[]≠∷ : ∀ x (xs : List a) → [] ≠ x ∷ xs -[]≠∷ x xs () - --------------------------------------------------- --- _∷_ - -module _ {x y : a} {xs ys : List a} where - ∷-injective-left : x ∷ xs ≡ y ∷ ys → x ≡ y - ∷-injective-left refl = refl - - ∷-injective-right : x ∷ xs ≡ y ∷ ys → xs ≡ ys - ∷-injective-right refl = refl - --------------------------------------------------- --- map - -map-id : (xs : List a) → map id xs ≡ xs -map-id [] = refl -map-id (x ∷ xs) = cong (x ∷_) (map-id xs) - -map-++ : ∀ (f : a → b) xs ys → map f (xs ++ ys) ≡ map f xs ++ map f ys -map-++ f [] ys = refl -map-++ f (x ∷ xs) ys = cong (f x ∷_) (map-++ f xs ys) - -lengthMap : ∀ (f : a → b) xs → lengthNat (map f xs) ≡ lengthNat xs -lengthMap f [] = refl -lengthMap f (x ∷ xs) = cong suc (lengthMap f xs) - -map-∘ : ∀ (g : b → c) (f : a → b) xs → map (g ∘ f) xs ≡ (map g ∘ map f) xs -map-∘ g f [] = refl -map-∘ g f (x ∷ xs) = cong (_ ∷_) (map-∘ g f xs) - -map-concatMap : ∀ (f : a → b) (xs : List a) → (map f xs) ≡ concatMap (λ g → f g ∷ []) xs -map-concatMap f [] = refl -map-concatMap f (x ∷ xs) - rewrite map-concatMap f xs - = refl - -map-<*>-recomp : {a b c : Set} → (xs : List (a → b)) → (ys : List a) → (u : (b → c)) - → ((map (u ∘_) xs) <*> ys) ≡ map u (xs <*> ys) -map-<*>-recomp [] _ _ = refl -map-<*>-recomp (x ∷ xs) ys u - rewrite map-∘ u x ys - | map-++ u (map x ys) (xs <*> ys) - | map-<*>-recomp xs ys u - = refl - --------------------------------------------------- --- _++_ - -lengthNat-++ : ∀ (xs : List a) {ys} → - lengthNat (xs ++ ys) ≡ lengthNat xs +ₙ lengthNat ys -lengthNat-++ [] = refl -lengthNat-++ (x ∷ xs) = cong suc (lengthNat-++ xs) - -++-[] : ∀ (xs : List a) → xs ++ [] ≡ xs -++-[] [] = refl -++-[] (x ∷ xs) rewrite ++-[] xs = refl - -[]-++ : ∀ (xs : List a) → [] ++ xs ≡ xs -[]-++ xs = refl - -++-assoc : ∀ (xs ys zs : List a) → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs) -++-assoc [] ys zs = refl -++-assoc (x ∷ xs) ys zs rewrite ++-assoc xs ys zs = refl - -++-∷-assoc : ∀ xs y (ys : List a) → xs ++ y ∷ ys ≡ (xs ++ y ∷ []) ++ ys -++-∷-assoc [] y ys = refl -++-∷-assoc (x ∷ xs) y ys = cong (x ∷_) (++-∷-assoc xs y ys) - -∷-++-assoc : ∀ x xs (ys : List a) → (x ∷ xs) ++ ys ≡ x ∷ (xs ++ ys) -∷-++-assoc x xs ys = refl - -++-identity-right-unique : ∀ (xs : List a) {ys} → xs ≡ xs ++ ys → ys ≡ [] -++-identity-right-unique [] refl = refl -++-identity-right-unique (x ∷ xs) eq = - ++-identity-right-unique xs (∷-injective-right eq) - -++-identity-left-unique : ∀ {xs} (ys : List a) → xs ≡ ys ++ xs → ys ≡ [] -++-identity-left-unique [] _ = refl -++-identity-left-unique {xs = x ∷ xs} (y ∷ ys) eq - with ++-identity-left-unique (ys ++ (x ∷ [])) (begin - xs ≡⟨ ∷-injective-right eq ⟩ - ys ++ x ∷ xs ≡⟨ sym (++-assoc ys (x ∷ []) xs) ⟩ - (ys ++ x ∷ []) ++ xs ∎) -++-identity-left-unique {xs = x ∷ xs} (y ∷ [] ) eq | () -++-identity-left-unique {xs = x ∷ xs} (y ∷ _ ∷ _) eq | () - -++-cancel-left : ∀ (xs ys : List a) {zs} → xs ++ ys ≡ xs ++ zs → ys ≡ zs -++-cancel-left [] ys eq = eq -++-cancel-left (x ∷ xs) ys eq = ++-cancel-left xs ys (∷-injective-right eq) - -++-cancel-right : ∀ (xs ys : List a) {zs} → xs ++ zs ≡ ys ++ zs → xs ≡ ys -++-cancel-right [] [] eq = refl -++-cancel-right (x ∷ xs) [] eq = ++-identity-left-unique (x ∷ xs) (sym eq) -++-cancel-right [] (y ∷ ys) eq = sym $ ++-identity-left-unique (y ∷ ys) eq -++-cancel-right (x ∷ xs) (y ∷ ys) eq - rewrite ∷-injective-left eq = cong (y ∷_) $ ++-cancel-right xs ys (∷-injective-right eq) - -++-conical-left : (xs ys : List a) → xs ++ ys ≡ [] → xs ≡ [] -++-conical-left [] _ refl = refl - -++-conical-right : (xs ys : List a) → xs ++ ys ≡ [] → ys ≡ [] -++-conical-right [] _ refl = refl - -∷-not-identity : ∀ x (xs ys : List a) → (x ∷ xs) ++ ys ≡ ys → ⊥ -∷-not-identity x xs ys eq = []≠∷ x xs (sym $ ++-identity-left-unique (x ∷ xs) (sym eq)) - -concatMap-++-distr : ∀ (xs ys : List a) (f : a → List b) → - ((concatMap f xs) ++ (concatMap f ys)) ≡ (concatMap f (xs ++ ys)) -concatMap-++-distr [] ys f = refl -concatMap-++-distr (x ∷ xs) ys f - rewrite ++-assoc (f x) (concatMap f xs) (concatMap f ys) - | concatMap-++-distr xs ys f - = refl - --------------------------------------------------- --- foldr - -foldr-universal : ∀ (h : List a → b) f e → (h [] ≡ e) → - (∀ x xs → h (x ∷ xs) ≡ f x (h xs)) → - ∀ xs → h xs ≡ foldr f e xs -foldr-universal h f e base step [] = base -foldr-universal h f e base step (x ∷ xs) rewrite step x xs = cong (f x) (foldr-universal h f e base step xs) - -foldr-cong : ∀ {f g : a → b → b} {d e : b} → - (∀ x y → f x y ≡ g x y) → d ≡ e → - ∀ (xs : List a) → foldr f d xs ≡ foldr g e xs -foldr-cong f≡g d≡e [] = d≡e -foldr-cong f≡g d≡e (x ∷ xs) rewrite foldr-cong f≡g d≡e xs = f≡g x _ - -foldr-fusion : (h : b → c) {f : a → b → b} {g : a → c → c} (e : b) → - (∀ x y → h (f x y) ≡ g x (h y)) → - ∀ (xs : List a) → h (foldr f e xs) ≡ foldr g (h e) xs -foldr-fusion h {f} {g} e fuse = - foldr-universal (h ∘ foldr f e) g (h e) refl - (λ x xs → fuse x (foldr f e xs)) diff --git a/lib/Haskell/Law/Maybe.agda b/lib/Haskell/Law/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Law/Maybe.agda +++ /dev/null @@ -1,9 +0,0 @@ -module Haskell.Law.Maybe where - -open import Haskell.Prim -open import Haskell.Prim.Maybe - -open import Haskell.Law.Def - -Just-injective : Injective (Just {a = a}) -Just-injective refl = refl diff --git a/lib/Haskell/Law/Monad.agda b/lib/Haskell/Law/Monad.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monad.agda +++ /dev/null @@ -1,7 +0,0 @@ -module Haskell.Law.Monad where - -open import Haskell.Law.Monad.Def public -open import Haskell.Law.Monad.Either public -open import Haskell.Law.Monad.IO public -open import Haskell.Law.Monad.List public -open import Haskell.Law.Monad.Maybe public diff --git a/lib/Haskell/Law/Monad/Def.agda b/lib/Haskell/Law/Monad/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monad/Def.agda +++ /dev/null @@ -1,46 +0,0 @@ -module Haskell.Law.Monad.Def where - -open import Haskell.Prim - -open import Haskell.Prim.Applicative -open import Haskell.Prim.Functor -open import Haskell.Prim.Monad -open import Haskell.Prim.Monoid -open import Haskell.Prim.Tuple - -open import Haskell.Law.Applicative - -record IsLawfulMonad (F : Set → Set) ⦃ iMonadF : Monad F ⦄ : Set₁ where - field - overlap ⦃ super ⦄ : IsLawfulApplicative F - - -- Left identity: return a >>= k = k a - leftIdentity : {a : Set} → (a' : a) (k : a → F b) → ((return a') >>= k) ≡ k a' - - -- Right identity: m >>= return = m - rightIdentity : {a : Set} → (ma : F a) → (ma >>= return) ≡ ma - - -- Associativity: m >>= (\x -> k x >>= h) = (m >>= k) >>= h - associativity : {a b c : Set} → (ma : F a) (f : a → F b) (g : b → F c) - → (ma >>= (λ x → f x >>= g)) ≡ ((ma >>= f) >>= g) - - -- pure = return - pureIsReturn : (a' : a) → pure a' ≡ (Monad.return iMonadF a') - -- m1 <*> m2 = m1 >>= (\x1 -> m2 >>= (\x2 -> return (x1 x2))) - sequence2bind : {a b : Set} → (mab : F (a → b)) (ma : F a) - → (mab <*> ma) ≡ (mab >>= (λ x1 → (ma >>= (λ x2 → return (x1 x2))))) - - -- fmap f xs = xs >>= return . f - fmap2bind : {a b : Set} → (f : a → b) (ma : F a) - → fmap f ma ≡ (ma >>= (return ∘ f)) - -- (>>) = (*>) - rSequence2rBind : (ma : F a) → (mb : F b) → (ma *> mb) ≡ (ma >> mb) - -open IsLawfulMonad ⦃ ... ⦄ public - -instance postulate - iLawfulMonadFun : IsLawfulMonad (λ b → a → b) - - iLawfulMonadTuple₂ : ⦃ Monoid a ⦄ → Monad (a ×_) - - iLawfulMonadTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Monad (a × b ×_) diff --git a/lib/Haskell/Law/Monad/Either.agda b/lib/Haskell/Law/Monad/Either.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monad/Either.agda +++ /dev/null @@ -1,34 +0,0 @@ -module Haskell.Law.Monad.Either where - -open import Haskell.Prim -open import Haskell.Prim.Either - -open import Haskell.Prim.Monad - -open import Haskell.Law.Monad.Def - -open import Haskell.Law.Applicative.Either - -instance - iLawfulMonadEither : IsLawfulMonad (Either a) - iLawfulMonadEither .leftIdentity _ _ = refl - - iLawfulMonadEither .rightIdentity = λ { (Left _) → refl; (Right _) → refl } - - iLawfulMonadEither .associativity = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } - - iLawfulMonadEither .pureIsReturn _ = refl - - iLawfulMonadEither .sequence2bind = - λ { (Left _) _ → refl - ; (Right _) (Left _) → refl - ; (Right _) (Right _) → refl - } - - iLawfulMonadEither .fmap2bind = λ { _ (Left _) → refl; _ (Right _) → refl } - - iLawfulMonadEither .rSequence2rBind = - λ { (Left _) _ → refl - ; (Right _) (Left _) → refl - ; (Right _) (Right _) → refl - } diff --git a/lib/Haskell/Law/Monad/IO.agda b/lib/Haskell/Law/Monad/IO.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monad/IO.agda +++ /dev/null @@ -1,12 +0,0 @@ -module Haskell.Law.Monad.IO where - -open import Haskell.Prim -open import Haskell.Prim.IO - -open import Haskell.Prim.Monad - -open import Haskell.Law.Monad.Def - -open import Haskell.Law.Applicative.IO - -instance postulate iLawfulMonadIO : IsLawfulMonad IO diff --git a/lib/Haskell/Law/Monad/List.agda b/lib/Haskell/Law/Monad/List.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monad/List.agda +++ /dev/null @@ -1,48 +0,0 @@ -module Haskell.Law.Monad.List where - -open import Haskell.Prim -open import Haskell.Prim.List - -open import Haskell.Prim.Monad - -open import Haskell.Law.Monad.Def -open import Haskell.Law.List - -open import Haskell.Law.Applicative.List - -instance - iLawfulMonadList : IsLawfulMonad List - iLawfulMonadList .leftIdentity a k - rewrite ++-[] (k a) - = refl - - iLawfulMonadList .rightIdentity [] = refl - iLawfulMonadList .rightIdentity (_ ∷ xs) - rewrite rightIdentity xs - = refl - - iLawfulMonadList .associativity [] f g = refl - iLawfulMonadList .associativity (x ∷ xs) f g - rewrite associativity xs f g - | concatMap-++-distr (f x) (xs >>= f) g - = refl - - iLawfulMonadList .pureIsReturn _ = refl - - iLawfulMonadList .sequence2bind [] _ = refl - iLawfulMonadList .sequence2bind (f ∷ fs) xs - rewrite sequence2bind fs xs - | map-concatMap f xs - = refl - - iLawfulMonadList .fmap2bind f [] = refl - iLawfulMonadList .fmap2bind f (_ ∷ xs) - rewrite fmap2bind f xs - = refl - - iLawfulMonadList .rSequence2rBind [] mb = refl - iLawfulMonadList .rSequence2rBind (x ∷ ma) mb - rewrite rSequence2rBind ma mb - | map-id mb - = refl - diff --git a/lib/Haskell/Law/Monad/Maybe.agda b/lib/Haskell/Law/Monad/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monad/Maybe.agda +++ /dev/null @@ -1,35 +0,0 @@ -module Haskell.Law.Monad.Maybe where - -open import Haskell.Prim -open import Haskell.Prim.Maybe - -open import Haskell.Prim.Monad - -open import Haskell.Law.Monad.Def - -open import Haskell.Law.Applicative.Maybe - -instance - iLawfulMonadMaybe : IsLawfulMonad Maybe - iLawfulMonadMaybe .leftIdentity _ _ = refl - - iLawfulMonadMaybe .rightIdentity = λ { Nothing → refl; (Just _) → refl } - - iLawfulMonadMaybe .associativity = λ { Nothing _ _ → refl; (Just _) _ _ → refl } - - iLawfulMonadMaybe .pureIsReturn _ = refl - - iLawfulMonadMaybe .sequence2bind = - λ { Nothing _ → refl - ; (Just _) Nothing → refl - ; (Just _) (Just _) → refl - } - - iLawfulMonadMaybe .fmap2bind = λ { _ Nothing → refl; _ (Just _) → refl } - - iLawfulMonadMaybe .rSequence2rBind = - λ { Nothing _ → refl - ; (Just _) Nothing → refl - ; (Just _) (Just _) → refl - } - diff --git a/lib/Haskell/Law/Monoid.agda b/lib/Haskell/Law/Monoid.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monoid.agda +++ /dev/null @@ -1,10 +0,0 @@ -module Haskell.Law.Monoid where - -open import Haskell.Law.Semigroup.Def public -open import Haskell.Law.Semigroup.Either public -open import Haskell.Law.Semigroup.List public -open import Haskell.Law.Semigroup.Maybe public - -open import Haskell.Law.Monoid.Def public -open import Haskell.Law.Monoid.List public -open import Haskell.Law.Monoid.Maybe public diff --git a/lib/Haskell/Law/Monoid/Def.agda b/lib/Haskell/Law/Monoid/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monoid/Def.agda +++ /dev/null @@ -1,38 +0,0 @@ -module Haskell.Law.Monoid.Def where - -open import Haskell.Prim -open import Haskell.Prim.Tuple - -open import Haskell.Prim.Foldable -open import Haskell.Prim.Monoid - -open import Haskell.Law.Semigroup.Def - -record IsLawfulMonoid (a : Set) ⦃ iMonoidA : Monoid a ⦄ : Set₁ where - field - overlap ⦃ super ⦄ : IsLawfulSemigroup a - - -- Right identity: x <> mempty = x - rightIdentity : (x : a) → x <> mempty ≡ x - - -- Left identity: mempty <> x = x - leftIdentity : (x : a) → mempty <> x ≡ x - - -- Concatenation: mconcat = foldr (<>) mempty - concatenation : (xs : List a) → mconcat xs ≡ foldr _<>_ mempty xs - -open IsLawfulMonoid ⦃ ... ⦄ public - -postulate instance - iLawfulMonoidFun : ⦃ iSemB : Monoid b ⦄ → ⦃ IsLawfulMonoid b ⦄ → IsLawfulMonoid (a → b) - - iLawfulMonoidUnit : IsLawfulMonoid ⊤ - - iLawfulMonoidTuple₂ : ⦃ iSemA : Monoid a ⦄ ⦃ iSemB : Monoid b ⦄ - → ⦃ IsLawfulMonoid a ⦄ → ⦃ IsLawfulMonoid b ⦄ - → IsLawfulMonoid (a × b) - - iLawfulMonoidTuple₃ : ⦃ iSemA : Monoid a ⦄ ⦃ iSemB : Monoid b ⦄ ⦃ iSemC : Monoid c ⦄ - → ⦃ IsLawfulMonoid a ⦄ → ⦃ IsLawfulMonoid b ⦄ → ⦃ IsLawfulMonoid c ⦄ - → IsLawfulMonoid (a × b × c) - diff --git a/lib/Haskell/Law/Monoid/List.agda b/lib/Haskell/Law/Monoid/List.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monoid/List.agda +++ /dev/null @@ -1,29 +0,0 @@ -module Haskell.Law.Monoid.List where - -open import Haskell.Prim -open import Haskell.Prim.List - -open import Haskell.Prim.Monoid - -open import Haskell.Law.List -open import Haskell.Law.Monoid.Def -open import Haskell.Law.Semigroup.Def -open import Haskell.Law.Semigroup.List - -instance - iLawfulMonoidList : IsLawfulMonoid (List a) - iLawfulMonoidList .rightIdentity [] = refl - iLawfulMonoidList .rightIdentity (x ∷ xs) - rewrite ++-[] (x ∷ xs) - = refl - - iLawfulMonoidList .leftIdentity [] = refl - iLawfulMonoidList .leftIdentity (x ∷ xs) - rewrite ++-[] (x ∷ xs) - = refl - - iLawfulMonoidList .concatenation [] = refl - iLawfulMonoidList .concatenation (x ∷ xs) - rewrite ++-[] (x ∷ xs) - | concatenation xs - = refl diff --git a/lib/Haskell/Law/Monoid/Maybe.agda b/lib/Haskell/Law/Monoid/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Law/Monoid/Maybe.agda +++ /dev/null @@ -1,21 +0,0 @@ -module Haskell.Law.Monoid.Maybe where - -open import Haskell.Prim -open import Haskell.Prim.Maybe - -open import Haskell.Prim.Monoid - -open import Haskell.Law.Monoid.Def -open import Haskell.Law.Semigroup.Def -open import Haskell.Law.Semigroup.Maybe - -instance - iLawfulMonoidMaybe : ⦃ iMonoidA : Monoid a ⦄ → ⦃ iLawfulMonoidA : IsLawfulMonoid a ⦄ → IsLawfulMonoid (Maybe a) - iLawfulMonoidMaybe .rightIdentity = λ { Nothing → refl; (Just _) → refl } - - iLawfulMonoidMaybe .leftIdentity = λ { Nothing → refl; (Just _) → refl } - - iLawfulMonoidMaybe .concatenation [] = refl - iLawfulMonoidMaybe .concatenation (x ∷ xs) - rewrite (concatenation xs) - = refl diff --git a/lib/Haskell/Law/Nat.agda b/lib/Haskell/Law/Nat.agda deleted file mode 100644 --- a/lib/Haskell/Law/Nat.agda +++ /dev/null @@ -1,51 +0,0 @@ -module Haskell.Law.Nat where - -open import Haskell.Prim -open import Haskell.Prim.Num - -open import Haskell.Law.Def -open import Haskell.Law.Equality - -suc-injective : Injective suc -suc-injective refl = refl - -{-| -The canonical formalization of the -less-than-or-equal-to relation for natural numbers. --} -data _≤_ : Nat → Nat → Set where - z≤n : ∀ {n} → zero ≤ n - s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n - -≤-refl : ∀ (x : Nat) → x ≤ x -≤-refl zero = z≤n -≤-refl (suc x) = s≤s (≤-refl x) - -≤-antisym : ∀ {x y : Nat} - → x ≤ y - → y ≤ x - ----- - → x ≡ y -≤-antisym z≤n z≤n = refl -≤-antisym (s≤s x≤y) (s≤s y≤x) = cong suc (≤-antisym x≤y y≤x) - -≤-trans : ∀ {x y z : Nat} - → x ≤ y - → y ≤ z - ----- - → x ≤ z -≤-trans z≤n y≤z = z≤n -≤-trans (s≤s x≤y) (s≤s y≤z) = s≤s (≤-trans x≤y y≤z) - -x≤x+1 : ∀ (x : Nat) → x ≤ suc x -x≤x+1 zero = z≤n -x≤x+1 (suc x) = s≤s (x≤x+1 x) - -x+[y-x]≡y : ∀ (x y : Nat) → x ≤ y → x + monusNat y x ≡ y -x+[y-x]≡y zero y x≤y = refl -x+[y-x]≡y (suc x) (suc y) (s≤s x≤y) = cong suc (x+[y-x]≡y x y x≤y) - -y-x≤y : ∀ (x y : Nat) → monusNat y x ≤ y -y-x≤y zero y = ≤-refl y -y-x≤y (suc x) zero = z≤n -y-x≤y (suc x) (suc y) = ≤-trans (y-x≤y x y) (x≤x+1 y) diff --git a/lib/Haskell/Law/Num.agda b/lib/Haskell/Law/Num.agda deleted file mode 100644 --- a/lib/Haskell/Law/Num.agda +++ /dev/null @@ -1,7 +0,0 @@ -module Haskell.Law.Num where - -open import Haskell.Law.Num.Def public -open import Haskell.Law.Num.Int public -open import Haskell.Law.Num.Integer public -open import Haskell.Law.Num.Nat public -open import Haskell.Law.Num.Word public diff --git a/lib/Haskell/Law/Num/Def.agda b/lib/Haskell/Law/Num/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Num/Def.agda +++ /dev/null @@ -1,125 +0,0 @@ -module Haskell.Law.Num.Def where - -open import Haskell.Prim -open import Haskell.Prim.Num -open import Haskell.Prim.Integer - -record IsLawfulNum (a : Set) ⦃ iNum : Num a ⦄ : Set₁ where - field - +-assoc : ∀ (x y z : a) → (x + y) + z ≡ x + (y + z) - - +-comm : ∀ (x y : a) → x + y ≡ y + x - - +-idˡ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 0}} - → fromInteger 0 + x ≡ x - +-idʳ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 0}} - → x + fromInteger 0 ≡ x - - neg-inv : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 0}} {{@0 _ : Num.NegateOK iNum x}} - → x + negate x ≡ fromInteger 0 - - *-assoc : ∀ (x y z : a) → (x * y) * z ≡ x * (y * z) - - *-idˡ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 1}} - → fromInteger 1 * x ≡ x - *-idʳ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 1}} - → x * fromInteger 1 ≡ x - - distributeˡ : ∀ (x y z : a) → x * (y + z) ≡ (x * y) + (x * z) - distributeʳ : ∀ (x y z : a) → (y + z) * x ≡ (y * x) + (z * x) - - -- We are currently missing the following because toInteger is missing in our Prelude. - -- "if the type also implements Integral, then fromInteger is a left inverse for toInteger, i.e. fromInteger (toInteger i) == i" -open IsLawfulNum ⦃ ... ⦄ public - -open import Haskell.Law.Equality -open import Haskell.Law.Function - -{-| -A number homomorphism establishes a homomorphism from one Num type a to another one b. -In particular, zero and one are mapped to zero and one in the other Num type, -and addition, multiplication, and negation are homorphic. --} -record NumHomomorphism (a b : Set) ⦃ iNuma : Num a ⦄ ⦃ iNumb : Num b ⦄ (φ : a → b) : Set where - 0ᵃ = Num.fromInteger iNuma (pos 0) - 0ᵇ = Num.fromInteger iNumb (pos 0) - 1ᵃ = Num.fromInteger iNuma (pos 1) - 1ᵇ = Num.fromInteger iNumb (pos 1) - - field - +-hom : Homomorphism₂ _+_ _+_ φ - *-hom : Homomorphism₂ _*_ _*_ φ - ⦃ minus-ok ⦄ : ∀ {x y : a} → ⦃ MinusOK x y ⦄ → MinusOK (φ x) (φ y) - ⦃ negate-ok ⦄ : ∀ {x : a} → ⦃ NegateOK x ⦄ → NegateOK (φ x) - ⦃ fromInteger-ok ⦄ : ∀ {i : Integer} → ⦃ Num.FromIntegerOK iNuma i ⦄ → Num.FromIntegerOK iNumb i - 0-hom : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 0) ⦄ → φ 0ᵃ ≡ 0ᵇ - 1-hom : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 1) ⦄ → φ 1ᵃ ≡ 1ᵇ - negate-hom : ∀ (x : a) → ⦃ @0 _ : Num.NegateOK iNuma x ⦄ → φ (negate x) ≡ negate (φ x) --Homomorphism₁ inlined for type instances - -{-| -A number embedding is an invertible number homomorphism. --} -record NumEmbedding (a b : Set) ⦃ iNuma : Num a ⦄ ⦃ iNumb : Num b ⦄ (φ : a → b) (φ⁻¹ : b → a) : Set where - field - hom : NumHomomorphism a b φ - embed : φ⁻¹ ∘ φ ≗ id - - open NumHomomorphism hom - - +-Embedding₂ : Embedding₂ _+_ _+_ φ φ⁻¹ - Embedding₂.hom +-Embedding₂ = +-hom - Embedding₂.embed +-Embedding₂ = embed - - *-Embedding₂ : Embedding₂ _*_ _*_ φ φ⁻¹ - Embedding₂.hom *-Embedding₂ = *-hom - Embedding₂.embed *-Embedding₂ = embed - - +-MonoidEmbedding₂ : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 0) ⦄ → MonoidEmbedding₂ _+_ _+_ φ φ⁻¹ 0ᵃ 0ᵇ - MonoidEmbedding₂.embedding +-MonoidEmbedding₂ = +-Embedding₂ - MonoidEmbedding₂.0-hom +-MonoidEmbedding₂ = 0-hom - - *-MonoidEmbedding₂ : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 1) ⦄ → MonoidEmbedding₂ _*_ _*_ φ φ⁻¹ 1ᵃ 1ᵇ - MonoidEmbedding₂.embedding *-MonoidEmbedding₂ = *-Embedding₂ - MonoidEmbedding₂.0-hom *-MonoidEmbedding₂ = 1-hom - -{-| -Given an embedding from one number type a onto another one b, -we can conclude that b satisfies the laws of Num if a satisfies the -laws of Num. --} -map-IsLawfulNum : ∀ {a b : Set} ⦃ iNuma : Num a ⦄ ⦃ iNumb : Num b ⦄ - → (a2b : a → b) (b2a : b → a) - → NumEmbedding a b a2b b2a - → IsLawfulNum b - ----------------------- - → IsLawfulNum a -map-IsLawfulNum {a} {b} {{numa}} {{numb}} f g proj lawb = - record - { +-assoc = map-assoc _+ᵃ_ _+ᵇ_ f g +-Embedding₂ (+-assoc lawb) - ; +-comm = map-comm _+ᵃ_ _+ᵇ_ f g +-Embedding₂ (+-comm lawb) - ; +-idˡ = λ x → map-idˡ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ +-MonoidEmbedding₂ (λ y → +-idˡ lawb y) x - ; +-idʳ = λ x → map-idʳ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ +-MonoidEmbedding₂ (λ y → +-idʳ lawb y) x - ; neg-inv = map-neg-inv - ; *-assoc = map-assoc _*ᵃ_ _*ᵇ_ f g *-Embedding₂ (*-assoc lawb) - ; *-idˡ = λ x → map-idˡ _*ᵃ_ _*ᵇ_ f g 1ᵃ 1ᵇ *-MonoidEmbedding₂ (λ y → *-idˡ lawb y) x - ; *-idʳ = λ x → map-idʳ _*ᵃ_ _*ᵇ_ f g 1ᵃ 1ᵇ *-MonoidEmbedding₂ (λ y → *-idʳ lawb y) x - ; distributeˡ = map-distributeˡ _+ᵃ_ _+ᵇ_ _*ᵃ_ _*ᵇ_ f g embed +-hom *-hom (distributeˡ lawb) - ; distributeʳ = map-distributeʳ _+ᵃ_ _+ᵇ_ _*ᵃ_ _*ᵇ_ f g embed +-hom *-hom (distributeʳ lawb) - } - where - open NumEmbedding proj - open NumHomomorphism hom - open IsLawfulNum lawb - open Num numa renaming (_+_ to _+ᵃ_; _*_ to _*ᵃ_; negate to negateᵃ) - open Num numb renaming (_+_ to _+ᵇ_; _*_ to _*ᵇ_; negate to negateᵇ) - - map-neg-inv : ∀ (x : a) ⦃ @0 _ : Num.FromIntegerOK numa (pos 0) ⦄ ⦃ @0 _ : Num.NegateOK numa x ⦄ - → x +ᵃ negateᵃ x ≡ 0ᵃ - map-neg-inv x = - x +ᵃ negateᵃ x ≡˘⟨ embed (x +ᵃ negateᵃ x) ⟩ - g (f (x +ᵃ negateᵃ x)) ≡⟨ cong g (+-hom x (negateᵃ x)) ⟩ - g (f x +ᵇ f (negateᵃ x)) ≡⟨ cong g (cong (f x +ᵇ_) (negate-hom x)) ⟩ - g (f x +ᵇ negateᵇ (f x)) ≡⟨ cong g (neg-inv lawb (f x)) ⟩ - g 0ᵇ ≡˘⟨ cong g 0-hom ⟩ - g (f 0ᵃ) ≡⟨ embed 0ᵃ ⟩ - 0ᵃ ∎ diff --git a/lib/Haskell/Law/Num/Int.agda b/lib/Haskell/Law/Num/Int.agda deleted file mode 100644 --- a/lib/Haskell/Law/Num/Int.agda +++ /dev/null @@ -1,27 +0,0 @@ -module Haskell.Law.Num.Int where - -open import Haskell.Prim using (refl; tt) -open import Haskell.Prim.Num -open import Haskell.Prim.Int -open import Haskell.Prim.Word - -open import Haskell.Law.Num.Def -open import Haskell.Law.Num.Word - -instance - open NumHomomorphism - open NumEmbedding - - iNumEmbeddingIntWord : NumEmbedding Int Word intToWord int64 - +-hom (hom iNumEmbeddingIntWord) (int64 _) (int64 _) = refl - *-hom (hom iNumEmbeddingIntWord) (int64 _) (int64 _) = refl - minus-ok (hom iNumEmbeddingIntWord) = tt - negate-ok (hom iNumEmbeddingIntWord) = tt - fromInteger-ok (hom iNumEmbeddingIntWord) = tt - 0-hom (hom iNumEmbeddingIntWord) = refl - 1-hom (hom iNumEmbeddingIntWord) = refl - negate-hom (hom iNumEmbeddingIntWord) (int64 _) = refl - embed iNumEmbeddingIntWord (int64 _) = refl - - iLawfulNumInt : IsLawfulNum Int - iLawfulNumInt = map-IsLawfulNum intToWord int64 iNumEmbeddingIntWord iLawfulNumWord diff --git a/lib/Haskell/Law/Num/Integer.agda b/lib/Haskell/Law/Num/Integer.agda deleted file mode 100644 --- a/lib/Haskell/Law/Num/Integer.agda +++ /dev/null @@ -1,297 +0,0 @@ -module Haskell.Law.Num.Integer where - -open import Haskell.Prim -open import Haskell.Prim.Num -open import Haskell.Prim.Integer - -open import Haskell.Law.Equality -open import Haskell.Law.Num.Def -open import Haskell.Law.Num.Nat - --- Open the internal definitions because --- these must be transparent for proofs. -open Haskell.Prim.Integer.Internal - -addInteger-idˡ : ∀ (x : Integer) → 0 + x ≡ x -addInteger-idˡ (pos _) = refl -addInteger-idˡ (negsuc _) = cong negsuc refl - -addInteger-idʳ : ∀ (x : Integer) → x + 0 ≡ x -addInteger-idʳ (pos n) = cong pos $ addNat-idʳ n -addInteger-idʳ (negsuc _) = cong negsuc refl - -mulInteger-idˡ : ∀ (x : Integer) → 1 * x ≡ x -mulInteger-idˡ (pos x) = cong pos (addNat-idʳ x) -mulInteger-idˡ (negsuc x) = cong negsuc (addNat-idʳ x) - -mulInteger-idʳ : ∀ (x : Integer) → x * 1 ≡ x -mulInteger-idʳ (pos x) = cong pos (mulNat-idʳ x) -mulInteger-idʳ (negsuc x) = cong negsuc (mulNat-idʳ x) - -subNat-refl : ∀ (x : Nat) → subNat x x ≡ 0 -subNat-refl zero = refl -subNat-refl (suc x) = subNat-refl x - -n-n≡0-Nat : ∀ (x y : Nat) → subNat (x + y) x ≡ pos y -n-n≡0-Nat x zero rewrite addNat-idʳ x = subNat-refl x -n-n≡0-Nat zero (suc _) = refl -n-n≡0-Nat (suc x) (suc y) = n-n≡0-Nat x (suc y) - -n-n≡0-Integer : ∀ (x : Integer) → x + (negateInteger x) ≡ 0 -n-n≡0-Integer (pos zero) = refl -n-n≡0-Integer (pos (suc x)) = subNat-refl x -n-n≡0-Integer (negsuc x) = subNat-refl x - -mulInteger-zeroˡ : ∀ (x : Integer) → 0 * x ≡ 0 -mulInteger-zeroˡ (pos _) = refl -mulInteger-zeroˡ (negsuc _) = refl - -mulInteger-zeroʳ : ∀ (x : Integer) → x * 0 ≡ 0 -mulInteger-zeroʳ (pos n) = cong pos (mulNat-zeroʳ n) -mulInteger-zeroʳ (negsuc n) rewrite mulNat-zeroʳ n = refl - -addInteger-comm : ∀ (x y : Integer) → x + y ≡ y + x -addInteger-comm (pos x) (pos y) = cong pos (addNat-comm x y) -addInteger-comm (pos _) (negsuc _) = refl -addInteger-comm (negsuc _) (pos _) = refl -addInteger-comm (negsuc x) (negsuc y) = cong negsuc (cong suc (addNat-comm x y)) - -subNat|x-[y+z]≡x-y-z : ∀ (x y z : Nat) → subNat x (y + suc z) ≡ subNat x y + negsuc z -subNat|x-[y+z]≡x-y-z _ zero _ = refl -subNat|x-[y+z]≡x-y-z zero (suc y) z = cong negsuc (addNat-suc y z) -subNat|x-[y+z]≡x-y-z (suc x) (suc y) z = subNat|x-[y+z]≡x-y-z x y z - -subNat|x-y+z≡[x+z]-y : ∀ (x y z : Nat) → subNat x y + pos (suc z) ≡ subNat (x + suc z) y -subNat|x-y+z≡[x+z]-y _ zero _ = refl -subNat|x-y+z≡[x+z]-y zero (suc _) _ = refl -subNat|x-y+z≡[x+z]-y (suc x) (suc y) z = subNat|x-y+z≡[x+z]-y x y z - -subNat-cong-suc : ∀ (x y : Nat) → subNat (suc x) y ≡ pos 1 + subNat x y -subNat-cong-suc _ zero = refl -subNat-cong-suc zero (suc _) = refl -subNat-cong-suc (suc x) (suc y) = subNat-cong-suc x y - -subNat|x+[y-z]≡[1+x]+[y-[1+z]] : ∀ (x y z : Nat) → pos x + subNat y z ≡ pos (suc x) + subNat y (suc z) -subNat|x+[y-z]≡[1+x]+[y-[1+z]] x zero zero = cong pos (addNat-idʳ x) -subNat|x+[y-z]≡[1+x]+[y-[1+z]] x (suc y) zero = cong pos (addNat-suc x y) -subNat|x+[y-z]≡[1+x]+[y-[1+z]] _ zero (suc _) = refl -subNat|x+[y-z]≡[1+x]+[y-[1+z]] x (suc y) (suc z) = subNat|x+[y-z]≡[1+x]+[y-[1+z]] x y z - -subNat|x-y+[1+z]≡[1+x]+[z-y] : ∀ (x y z : Nat) → subNat x y + pos (suc z) ≡ pos (suc x) + subNat z y -subNat|x-y+[1+z]≡[1+x]+[z-y] x zero z = cong pos (addNat-suc x z) -subNat|x-y+[1+z]≡[1+x]+[z-y] zero (suc _) zero = refl -subNat|x-y+[1+z]≡[1+x]+[z-y] zero (suc y) (suc z) = subNat-cong-suc z y -subNat|x-y+[1+z]≡[1+x]+[z-y] (suc x) (suc y) z = - subNat x y + pos (suc z) ≡⟨ subNat|x-y+[1+z]≡[1+x]+[z-y] x y z ⟩ - pos (suc x) + subNat z y ≡⟨ subNat|x+[y-z]≡[1+x]+[y-[1+z]] (suc x) z y ⟩ - pos (suc (suc x)) + subNat z (suc y) ∎ - -subNat|[1+x+y]-z≡[1+x]+[y-z] : ∀ (x y z : Nat) → subNat (suc x + y) z ≡ pos (suc x) + subNat y z -subNat|[1+x+y]-z≡[1+x]+[y-z] _ _ zero = refl -subNat|[1+x+y]-z≡[1+x]+[y-z] x zero (suc z) = cong (λ eq → subNat eq z) (addNat-idʳ x) -subNat|[1+x+y]-z≡[1+x]+[y-z] x (suc y) (suc z) = - subNat (x + suc y) z ≡⟨ sym (subNat|x-y+z≡[x+z]-y x z y) ⟩ - subNat x z + pos (suc y) ≡⟨ subNat|x-y+[1+z]≡[1+x]+[z-y] x z y ⟩ - pos (suc x) + subNat y z ∎ - -subNat|x-y+[-[1+z]]≡x-z+[-[1+y]] : ∀ (x y z : Nat) → subNat x y + negsuc z ≡ subNat x z + negsuc y -subNat|x-y+[-[1+z]]≡x-z+[-[1+y]] x y z = begin - subNat x y + negsuc z ≡⟨ sym (subNat|x-[y+z]≡x-y-z x y z) ⟩ - subNat x (y + suc z) ≡⟨ cong (subNat x) (addNat-comm y (suc z)) ⟩ - subNat x (suc z + y) ≡⟨ cong (subNat x) (sym (addNat-suc z y)) ⟩ - subNat x (z + suc y) ≡⟨ subNat|x-[y+z]≡x-y-z x z y ⟩ - subNat x z + negsuc y ∎ - -subNat-cong-+ : ∀ (x y z : Nat) → subNat (x + y) (x + z) ≡ subNat y z -subNat-cong-+ x y zero rewrite addNat-idʳ x = n-n≡0-Nat x y -subNat-cong-+ zero _ (suc _) = refl -subNat-cong-+ (suc x) y (suc z) = subNat-cong-+ x y (suc z) - -subNat-distrib-minus : ∀ (m n o : Nat) → subNat n o * pos m ≡ subNat (n * m) (o * m) -subNat-distrib-minus _ _ zero = refl -subNat-distrib-minus zero zero (suc o) rewrite mulNat-zeroʳ o = refl -subNat-distrib-minus (suc _) zero (suc _) = refl -subNat-distrib-minus zero (suc n) (suc o) rewrite mulNat-zeroʳ o | mulInteger-zeroʳ (subNat n o) | mulNat-zeroʳ n = refl -subNat-distrib-minus (suc m) (suc n) (suc o) = - subNat n o * (pos (suc m)) ≡⟨ subNat-distrib-minus (suc m) n o ⟩ - subNat (n * suc m) (o * suc m) ≡⟨ sym (subNat-cong-+ m (n * suc m) (o * suc m)) ⟩ - subNat (m + (n * suc m)) (m + (o * suc m)) ∎ - -subNat-mult-flip-negsuc : ∀ (m n o : Nat) → subNat o n * negsuc m ≡ subNat n o * pos (suc m) -subNat-mult-flip-negsuc _ zero zero = refl -subNat-mult-flip-negsuc _ zero (suc _) = refl -subNat-mult-flip-negsuc _ (suc _) zero = refl -subNat-mult-flip-negsuc m (suc n) (suc o) = subNat-mult-flip-negsuc m n o - -subNat-distrib-minus-cong-+ : ∀ (m n o : Nat) → subNat o n * (pos (suc m)) ≡ subNat (m + (o * suc m)) (m + (n * suc m)) -subNat-distrib-minus-cong-+ m n o = begin - subNat o n * (pos (suc m)) ≡⟨ subNat-distrib-minus (suc m) o n ⟩ - subNat (o * suc m) (n * suc m) ≡⟨ sym (subNat-cong-+ m (o * suc m) (n * suc m)) ⟩ - subNat (m + (o * suc m)) (m + (n * suc m)) ∎ - - -addInteger-assoc : ∀ (x y z : Integer) → (x + y) + z ≡ x + (y + z) -addInteger-assoc (pos zero) j k rewrite addInteger-idˡ j | addInteger-idˡ (j + k) = refl -addInteger-assoc i (pos zero) k rewrite addInteger-idʳ i | addInteger-idˡ k = refl -addInteger-assoc i j (pos zero) rewrite addInteger-idʳ (i + j) | addInteger-idʳ j = refl -addInteger-assoc (negsuc m) (negsuc n) (pos (suc o)) = - (negsuc m + negsuc n) + pos (suc o) ≡⟨⟩ - negsuc (suc (m + n)) + pos (suc o) ≡⟨⟩ - subNat o (suc m + n) ≡⟨ cong (subNat o) (addNat-comm (suc m) n) ⟩ - subNat o (n + suc m) ≡⟨ subNat|x-[y+z]≡x-y-z o n m ⟩ - subNat o n + negsuc m ≡⟨ addInteger-comm (subNat o n) (negsuc m) ⟩ - negsuc m + subNat o n ≡⟨⟩ - negsuc m + (negsuc n + pos (suc o)) ∎ -addInteger-assoc (negsuc m) (pos (suc n)) (pos (suc o)) = - (negsuc m + pos (suc n)) + pos (suc o) ≡⟨⟩ - subNat n m + pos (suc o) ≡⟨ subNat|x-y+z≡[x+z]-y n m o ⟩ - subNat (n + suc o) m ≡⟨⟩ - negsuc m + pos (suc (n + suc o)) ≡⟨⟩ - negsuc m + (pos (suc n) + pos (suc o)) ∎ -addInteger-assoc (pos (suc m)) (negsuc n) (negsuc o) = - (pos (suc m) + negsuc n) + negsuc o ≡⟨⟩ - subNat m n + negsuc o ≡⟨ sym $ subNat|x-[y+z]≡x-y-z m n o ⟩ - subNat m (n + suc o) ≡⟨ cong (subNat m) (addNat-suc n o) ⟩ - subNat m (suc (n + o)) ≡⟨⟩ - pos (suc m) + (negsuc (suc (n + o))) ≡⟨⟩ - pos (suc m) + (negsuc n + negsuc o) ∎ -addInteger-assoc (pos (suc m)) (negsuc n) (pos (suc o)) = - (pos (suc m) + negsuc n) + pos (suc o) ≡⟨⟩ - subNat m n + pos (suc o) ≡⟨ subNat|x-y+[1+z]≡[1+x]+[z-y] m n o ⟩ - pos (suc m) + subNat o n ≡⟨⟩ - pos (suc m) + (negsuc n + pos (suc o)) ∎ -addInteger-assoc (pos (suc x)) (pos (suc y)) (negsuc z) = begin - (pos (suc x) + pos (suc y)) + negsuc z ≡⟨⟩ - pos (suc (x + (suc y))) + negsuc z ≡⟨ cong (_+ negsuc z) (cong pos (cong suc (addNat-suc x y))) ⟩ - pos (suc (suc (x + y))) + negsuc z ≡⟨⟩ - subNat (suc (x + y)) z ≡⟨⟩ - subNat (suc x + y) z ≡⟨ subNat|[1+x+y]-z≡[1+x]+[y-z] x y z ⟩ - pos (suc x) + subNat y z ≡⟨⟩ - pos (suc x) + (pos (suc y) + negsuc z) ∎ -addInteger-assoc (negsuc m) (negsuc n) (negsuc o) = cong negsuc $ cong suc $ - suc ((m + n) + o) ≡⟨ cong suc (addNat-assoc m n o) ⟩ - suc (m + (n + o)) ≡⟨ sym (addNat-suc m (n + o)) ⟩ - m + (suc (n + o)) ∎ -addInteger-assoc (negsuc m) (pos (suc n)) (negsuc o) = - (negsuc m + pos (suc n)) + negsuc o ≡⟨⟩ - subNat n m + negsuc o ≡⟨ subNat|x-y+[-[1+z]]≡x-z+[-[1+y]] n m o ⟩ - subNat n o + negsuc m ≡⟨ addInteger-comm (subNat n o) (negsuc m) ⟩ - negsuc m + subNat n o ≡⟨⟩ - negsuc m + (pos (suc n) - pos (suc o)) ∎ -addInteger-assoc (pos (suc m)) (pos (suc n)) (pos (suc o)) = cong pos (addNat-assoc (suc m) (suc n) (suc o)) - -distribute-1ˡ : ∀ (x y : Nat) → x * (1 + y) ≡ x + (y * x) -distribute-1ˡ x y = begin - x * (suc y) ≡⟨ mulNat-suc x y ⟩ - x + (x * y) ≡⟨ cong (x +_) (mulNat-comm x y) ⟩ - x + (y * x) ∎ - -mulInteger-comm : ∀ (x y : Integer) → x * y ≡ y * x -mulInteger-comm (pos x) (pos y) = cong pos (mulNat-comm x y) -mulInteger-comm (pos x) (negsuc y) = cong negNat $ distribute-1ˡ x y -mulInteger-comm (negsuc x) (pos y) = cong negNat $ sym $ distribute-1ˡ y x -mulInteger-comm (negsuc x) (negsuc y) = cong pos $ cong suc $ - y + (x * (suc y)) ≡⟨ cong (y +_) (distribute-1ˡ x y) ⟩ - y + (x + (y * x)) ≡⟨ cong (y +_) (cong (x +_) (mulNat-comm y x)) ⟩ - y + (x + (x * y)) ≡⟨ sym (addNat-assoc y x (x * y)) ⟩ - (y + x) + (x * y) ≡⟨ cong (_+ x * y) (addNat-comm y x) ⟩ - (x + y) + (x * y) ≡⟨ addNat-assoc x y (x * y) ⟩ - x + (y + (x * y)) ≡⟨ cong (x +_) (sym (distribute-1ˡ y x)) ⟩ - x + (y * (suc x)) ∎ - -distrib-lemma : ∀ (m n o : Nat) → suc (m + ((n + o) * suc m)) ≡ (n * suc m) + (suc (m + (o * suc m))) -distrib-lemma m n o = - suc (m + ((n + o) * suc m)) ≡⟨ cong suc (cong (m +_) (mulNat-distributeʳ-addNat (suc m) n o)) ⟩ - suc (m + ((n * suc m) + (o * suc m))) ≡⟨⟩ - suc m + ((n * suc m) + (o * suc m)) ≡⟨ sym (addNat-assoc (suc m) (n * suc m) (o * suc m) ) ⟩ - (suc m + (n * suc m)) + (o * suc m) ≡⟨ cong (_+ o * suc m) (addNat-comm (suc m) (n * suc m)) ⟩ - ((n * suc m) + suc m) + (o * suc m) ≡⟨ addNat-assoc (n * suc m) (suc m) (o * suc m) ⟩ - (n * suc m) + (suc (m + (o * suc m))) ∎ - -distrib-lemma2 : ∀ (m n o : Nat) → m + ((n * suc m) + (suc m + (o * suc m))) ≡ suc ((m + (n * suc m)) + (m + (o * suc m))) -distrib-lemma2 m n o = - m + ( (n * suc m) + (suc m + (o * suc m))) ≡⟨⟩ - m + ( (n * suc m) + suc (m + (o * suc m))) ≡⟨ sym (addNat-assoc m (n * suc m) (suc (m + (o * suc m)))) ⟩ - (m + (n * suc m)) + suc (m + (o * suc m)) ≡⟨ addNat-suc (m + (n * suc m)) (m + (o * suc m)) ⟩ - suc ((m + (n * suc m)) + (m + (o * suc m))) ∎ - -mulInteger-distributeʳ-addInteger : ∀ (x y z : Integer) → (y + z) * x ≡ (y * x) + (z * x) -mulInteger-distributeʳ-addInteger (pos zero) j k rewrite mulInteger-zeroʳ j | mulInteger-zeroʳ k | mulInteger-zeroʳ (j + k) = refl -mulInteger-distributeʳ-addInteger i (pos zero) k rewrite addInteger-idˡ k | mulInteger-zeroˡ i | addInteger-idˡ (k * i) = refl -mulInteger-distributeʳ-addInteger i j (pos zero) rewrite addInteger-idʳ j | mulInteger-zeroˡ i | addInteger-idʳ (j * i) = refl -mulInteger-distributeʳ-addInteger (negsuc m) (negsuc n) (pos (suc o)) = begin - subNat o n * negsuc m ≡⟨ subNat-mult-flip-negsuc m n o ⟩ - subNat n o * pos (suc m) ≡⟨ subNat-distrib-minus-cong-+ m o n ⟩ - subNat (m + (n * suc m)) (m + (o * suc m)) ∎ -mulInteger-distributeʳ-addInteger (negsuc m) (pos (suc n)) (pos (suc o)) = cong negsuc $ begin - m + ((n + suc o) * suc m) ≡⟨ cong (m +_) (mulNat-distributeʳ-addNat (suc m) n (suc o)) ⟩ - m + ( (n * suc m) + (suc m + (o * suc m))) ≡⟨ distrib-lemma2 m n o ⟩ - suc ((m + (n * suc m)) + (m + (o * suc m))) ∎ -- Y -mulInteger-distributeʳ-addInteger (pos (suc m)) (negsuc n) (negsuc o) = cong negsuc $ begin - m + (suc (m + ((n + o) * suc m))) ≡⟨⟩ - m + (suc m + ((n + o) * suc m)) ≡⟨ cong (m +_) (distrib-lemma m n o) ⟩ - m + ( (n * suc m) + (suc m + (o * suc m))) ≡⟨ distrib-lemma2 m n o ⟩ - suc ((m + (n * suc m)) + (m + (o * suc m))) ∎ -- Y -mulInteger-distributeʳ-addInteger (pos (suc m)) (negsuc n) (pos (suc o)) = subNat-distrib-minus-cong-+ m n o -mulInteger-distributeʳ-addInteger (pos (suc m)) (pos (suc n)) (negsuc o) = subNat-distrib-minus-cong-+ m o n -mulInteger-distributeʳ-addInteger (negsuc m) (negsuc n) (negsuc o) = cong pos $ cong suc $ - m + (suc (m + ((n + o) * suc m))) ≡⟨⟩ - m + (suc m + ((n + o) * suc m)) ≡⟨ cong (m +_) (distrib-lemma m n o) ⟩ - m + ((n * suc m) + (suc m + (o * suc m))) ≡⟨ sym (addNat-assoc m (n * suc m) (suc m + (o * suc m))) ⟩ - (m + (n * suc m)) + (suc (m + (o * suc m))) ∎ -- X -mulInteger-distributeʳ-addInteger (negsuc m) (pos (suc n)) (negsuc o) = - subNat n o * negsuc m ≡⟨ subNat-mult-flip-negsuc m o n ⟩ - subNat o n * pos (suc m) ≡⟨ subNat-distrib-minus-cong-+ m n o ⟩ - subNat (m + (o * suc m)) (m + (n * suc m)) ∎ -mulInteger-distributeʳ-addInteger (pos (suc m)) (pos (suc n)) (pos (suc o)) = cong pos $ cong suc $ - m + ((n + suc o) * suc m) ≡⟨ cong (m +_) (mulNat-distributeʳ-addNat (suc m) n (suc o)) ⟩ - m + ((n * suc m) + (suc m + (o * suc m))) ≡⟨ sym (addNat-assoc m (n * suc m) (suc m + (o * suc m))) ⟩ - (m + (n * suc m)) + (suc m + (o * suc m)) ≡⟨⟩ - (m + (n * suc m)) + (suc (m + (o * suc m))) ∎ -- X - -mulInteger-distributeˡ-addInteger : ∀ (x y z : Integer) → x * (y + z) ≡ (x * y) + (x * z) -mulInteger-distributeˡ-addInteger x y z - -- This proof works the very same as addNat-distributeˡ-mulNat. - rewrite (mulInteger-comm x (y + z)) -- makes or goal become: (y + z) * x ≡ (x * y) + (x * z) - rewrite (mulInteger-comm x y) -- makes or goal become: (y + z) * x ≡ (y * x) + (x * z) - rewrite (mulInteger-comm x z) -- makes or goal become: (y + z) * x ≡ (y * x) + (z * x) - = mulInteger-distributeʳ-addInteger x y z - -mulInteger-assoc-lemma-2 : ∀ (m n o : Nat) → (n + m * suc n) * suc o ≡ (n * suc o) + (m * suc (o + (n * suc o))) -mulInteger-assoc-lemma-2 m n o = begin - (n + (m * suc n)) * (suc o) ≡⟨ mulNat-distributeʳ-addNat (suc o) n (m * suc n) ⟩ - (n * (suc o)) + ((m * suc n) * (suc o)) ≡⟨ cong (n * suc o +_) (mulNat-assoc m (suc n) (suc o)) ⟩ - (n * suc o) + (m * suc (o + (n * suc o))) ∎ - -mulInteger-assoc-lemma : ∀ (m n o : Nat) - → o + ((n + m * suc n) * suc o) ≡ (o + (n * suc o)) + (m * suc (o + (n * suc o))) -mulInteger-assoc-lemma m n o = begin - o + ((n + m * suc n) * suc o) ≡⟨ cong (o +_) (mulInteger-assoc-lemma-2 m n o) ⟩ - o + ((n * suc o) + (m * suc (o + (n * suc o)))) ≡⟨ sym (addNat-assoc o (n * suc o) (m * suc (o + (n * suc o)))) ⟩ - (o + (n * suc o)) + (m * suc (o + (n * suc o))) ∎ - -mulInteger-assoc : ∀ (x y z : Integer) → (x * y) * z ≡ x * (y * z) -mulInteger-assoc (pos zero) j k rewrite mulInteger-zeroˡ j | mulInteger-zeroˡ k | mulInteger-zeroˡ (j * k) = refl -mulInteger-assoc i (pos zero) k rewrite mulInteger-zeroʳ i | mulInteger-zeroˡ k | mulInteger-zeroʳ i = refl -mulInteger-assoc i j (pos zero) rewrite mulInteger-zeroʳ j | mulInteger-zeroʳ i | mulInteger-zeroʳ (i * j) = refl -mulInteger-assoc (negsuc m) (negsuc n) (pos (suc o)) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) -mulInteger-assoc (negsuc m) (pos (suc n)) (pos (suc o)) = cong negsuc (mulInteger-assoc-lemma m n o) -mulInteger-assoc (pos (suc m)) (negsuc n) (negsuc o) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) -mulInteger-assoc (pos (suc m)) (negsuc n) (pos (suc o)) = cong negsuc (mulInteger-assoc-lemma m n o) -mulInteger-assoc (pos (suc m)) (pos (suc n)) (negsuc o) = cong negsuc (mulInteger-assoc-lemma m n o) -mulInteger-assoc (negsuc m) (negsuc n) (negsuc o) = cong negsuc (mulInteger-assoc-lemma m n o) -mulInteger-assoc (negsuc m) (pos (suc n)) (negsuc o) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) -mulInteger-assoc (pos (suc m)) (pos (suc n)) (pos (suc o)) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) - -instance - iLawfulNumInteger : IsLawfulNum Integer - iLawfulNumInteger .IsLawfulNum.+-assoc = addInteger-assoc - iLawfulNumInteger .IsLawfulNum.+-comm = addInteger-comm - iLawfulNumInteger .IsLawfulNum.+-idˡ x = addInteger-idˡ x - iLawfulNumInteger .IsLawfulNum.+-idʳ x = addInteger-idʳ x - iLawfulNumInteger .IsLawfulNum.neg-inv x = n-n≡0-Integer x - iLawfulNumInteger .IsLawfulNum.*-assoc = mulInteger-assoc - iLawfulNumInteger .IsLawfulNum.*-idˡ x = mulInteger-idˡ x - iLawfulNumInteger .IsLawfulNum.*-idʳ x = mulInteger-idʳ x - iLawfulNumInteger .IsLawfulNum.distributeˡ = mulInteger-distributeˡ-addInteger - iLawfulNumInteger .IsLawfulNum.distributeʳ = mulInteger-distributeʳ-addInteger diff --git a/lib/Haskell/Law/Num/Nat.agda b/lib/Haskell/Law/Num/Nat.agda deleted file mode 100644 --- a/lib/Haskell/Law/Num/Nat.agda +++ /dev/null @@ -1,103 +0,0 @@ -module Haskell.Law.Num.Nat where - -open import Haskell.Prim -open import Haskell.Prim.Num - -open import Haskell.Law.Equality -open import Haskell.Law.Num.Def - -addNat-suc : ∀ m n → m + suc n ≡ suc (m + n) -addNat-suc zero n = refl -addNat-suc (suc m) n = cong suc (addNat-suc m n) - -addNat-idˡ : ∀ (x : Nat) → 0 + x ≡ x -addNat-idˡ _ = refl - -addNat-idʳ : ∀ (x : Nat) → x + 0 ≡ x -addNat-idʳ zero = refl -addNat-idʳ (suc x) = cong suc (addNat-idʳ x) - -addNat-comm : ∀ (x y : Nat) → x + y ≡ y + x -addNat-comm zero y = sym (addNat-idʳ y) -addNat-comm (suc x) y = begin - suc (x + y) ≡⟨ cong suc (addNat-comm x y) ⟩ - suc (y + x) ≡⟨ sym (addNat-suc y x) ⟩ - y + suc x ∎ - -addNat-assoc : ∀ (x y z : Nat) → (x + y) + z ≡ x + (y + z) -addNat-assoc zero _ _ = refl -addNat-assoc (suc m) n o = cong suc (addNat-assoc m n o) - -mulNat-suc : ∀ (m n : Nat) → m * suc n ≡ m + m * n -mulNat-suc zero n = refl -mulNat-suc (suc m) n = begin - suc m * suc n ≡⟨⟩ - suc n + m * suc n ≡⟨ cong (suc n +_) (mulNat-suc m n) ⟩ - suc n + (m + m * n) ≡⟨⟩ - suc (n + (m + m * n)) ≡⟨ cong suc (sym (addNat-assoc n m (m * n))) ⟩ - suc (n + m + m * n) ≡⟨ cong (λ x → suc (x + m * n)) (addNat-comm n m) ⟩ - suc (m + n + m * n) ≡⟨ cong suc (addNat-assoc m n (m * n)) ⟩ - suc (m + (n + m * n)) ≡⟨⟩ - suc m + suc m * n ∎ - -mulNat-idˡ : ∀ (x : Nat) → 1 * x ≡ x -mulNat-idˡ = addNat-idʳ - -mulNat-idʳ : ∀ (x : Nat) → x * 1 ≡ x -mulNat-idʳ zero = refl -mulNat-idʳ (suc x) = cong suc (mulNat-idʳ x) - -mulNat-zeroˡ : ∀ (x : Nat) → 0 * x ≡ 0 -mulNat-zeroˡ _ = refl - -mulNat-zeroʳ : ∀ (x : Nat) → x * 0 ≡ 0 -mulNat-zeroʳ zero = refl -mulNat-zeroʳ (suc x) = mulNat-zeroʳ x - -mulNat-comm : ∀ (x y : Nat) → x * y ≡ y * x -mulNat-comm zero y = sym (mulNat-zeroʳ y) -mulNat-comm (suc x) y = begin - suc x * y ≡⟨⟩ - y + x * y ≡⟨ cong (y +_) (mulNat-comm x y) ⟩ - y + y * x ≡⟨ sym (mulNat-suc y x) ⟩ - y * suc x ∎ - -mulNat-distributeʳ-addNat : ∀ (x y z : Nat) → (y + z) * x ≡ (y * x) + (z * x) -mulNat-distributeʳ-addNat _ zero _ = refl -mulNat-distributeʳ-addNat x (suc y) z = begin - (suc y + z) * x ≡⟨⟩ - x + (y + z) * x ≡⟨ cong (x +_) (mulNat-distributeʳ-addNat x y z) ⟩ - x + (y * x + z * x) ≡⟨ sym (addNat-assoc x (y * x) (z * x)) ⟩ - x + y * x + z * x ≡⟨⟩ - suc y * x + z * x ∎ - -mulNat-distributeˡ-addNat : ∀ (x y z : Nat) → x * (y + z) ≡ (x * y) + (x * z) -mulNat-distributeˡ-addNat x y z - -- This proof transform left distribution to right distribution by using commutativity of *. - -- the initial goal is: x * (y + z) ≡ (x * y) + (x * z) - rewrite (mulNat-comm x (y + z)) -- makes or goal become: (y + z) * x ≡ (x * y) + (x * z) - rewrite (mulNat-comm x y) -- makes or goal become: (y + z) * x ≡ (y * x) + (x * z) - rewrite (mulNat-comm x z) -- makes or goal become: (y + z) * x ≡ (y * x) + (z * x) - = mulNat-distributeʳ-addNat x y z - -mulNat-assoc : ∀ (x y z : Nat) → (x * y) * z ≡ x * (y * z) -mulNat-assoc zero _ _ = refl -mulNat-assoc (suc x) y z = begin - (suc x * y) * z ≡⟨⟩ - (y + x * y) * z ≡⟨ mulNat-distributeʳ-addNat z y (x * y) ⟩ - y * z + (x * y) * z ≡⟨ cong (y * z +_) (mulNat-assoc x y z) ⟩ - y * z + x * (y * z) ≡⟨⟩ - suc x * (y * z) ∎ - -instance - iLawfulNumNat : IsLawfulNum Nat - iLawfulNumNat .IsLawfulNum.+-assoc = addNat-assoc - iLawfulNumNat .IsLawfulNum.+-comm = addNat-comm - iLawfulNumNat .IsLawfulNum.+-idˡ x = addNat-idˡ x - iLawfulNumNat .IsLawfulNum.+-idʳ x = addNat-idʳ x - iLawfulNumNat .IsLawfulNum.neg-inv zero = refl -- inline this proof because it has not much use anyway I guess? - iLawfulNumNat .IsLawfulNum.*-assoc = mulNat-assoc - iLawfulNumNat .IsLawfulNum.*-idˡ x = mulNat-idˡ x - iLawfulNumNat .IsLawfulNum.*-idʳ x = mulNat-idʳ x - iLawfulNumNat .IsLawfulNum.distributeˡ = mulNat-distributeˡ-addNat - iLawfulNumNat .IsLawfulNum.distributeʳ = mulNat-distributeʳ-addNat diff --git a/lib/Haskell/Law/Num/Word.agda b/lib/Haskell/Law/Num/Word.agda deleted file mode 100644 --- a/lib/Haskell/Law/Num/Word.agda +++ /dev/null @@ -1,106 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} -module Haskell.Law.Num.Word where - -open import Haskell.Prim -open import Haskell.Prim.Num -open import Haskell.Prim.Word -open Haskell.Prim.Word.WordInternal - -open import Haskell.Law.Equality -open import Haskell.Law.Function -open import Haskell.Law.Nat - -open import Haskell.Law.Num.Def -open import Haskell.Law.Num.Nat - -open Num iNumNat renaming (_+_ to _+ⁿ_; _*_ to _*ⁿ_) -open Num iNumWord renaming (_+_ to _+ʷ_; _*_ to _*ʷ_) - -postulate - -- This is a reasonable axiom because there are more natural numbers than - -- integer. More precisely, Words denote a finite subset of Integers. - -- This means, there is am embedding of Words into Integers as stated by - -- this axiom. - n2w∘w2n≡id : ∀ (x : Word) → n2w (w2n x) ≡ x - - -- Conversion of natural numbers to words is invertible as long as the - -- natural is within word bounds. - w2n∘n2w≡id : ∀ (x : Nat) → x ≤ 2⁶⁴ → w2n (n2w x) ≡ x - - -- Definitions of word arithmetics are based on conversions to Nats. - -- That conversion must be homomorphic w.r.t. to addition and multiplication - -- to not break their properties. - w2n-+-hom : Homomorphism₂ _+ʷ_ _+ⁿ_ w2n - w2n-*-hom : Homomorphism₂ _*ʷ_ _*ⁿ_ w2n - - -- 2⁶⁴ is the upper bound of the ring that forms Words in Nats. - max-int≡0 : n2w 2⁶⁴ ≡ 0 - - -- Words are bounded. They can never be larger than 2⁶⁴. - bounded : ∀ (x : Word) → w2n x ≤ 2⁶⁴ - -open MonoidEmbedding₂ - -+-wordsAsNats : MonoidEmbedding₂ addWord addNat w2n n2w 0 0 -Embedding₂.hom (embedding +-wordsAsNats) = w2n-+-hom -Embedding₂.embed (embedding +-wordsAsNats) = n2w∘w2n≡id -0-hom +-wordsAsNats = refl - -*-wordsAsNats : MonoidEmbedding₂ mulWord mulNat w2n n2w 1 1 -Embedding₂.hom (embedding *-wordsAsNats) = w2n-*-hom -Embedding₂.embed (embedding *-wordsAsNats) = n2w∘w2n≡id -0-hom *-wordsAsNats = refl - -addWord-idˡ : Identityˡ addWord 0 -addWord-idˡ = map-idˡ addWord addNat w2n n2w 0 0 +-wordsAsNats addNat-idˡ - -addWord-idʳ : Identityʳ addWord 0 -addWord-idʳ = map-idʳ addWord addNat w2n n2w 0 0 +-wordsAsNats addNat-idʳ - -addWord-comm : Commutative addWord -addWord-comm = map-comm addWord addNat w2n n2w (embedding +-wordsAsNats) addNat-comm - -addWord-assoc : Associative addWord -addWord-assoc = map-assoc addWord addNat w2n n2w (embedding +-wordsAsNats) addNat-assoc - -mulWord-comm : Commutative mulWord -mulWord-comm = map-comm mulWord mulNat w2n n2w (embedding *-wordsAsNats) mulNat-comm - -mulWord-assoc : Associative mulWord -mulWord-assoc = map-assoc mulWord mulNat w2n n2w (embedding *-wordsAsNats) mulNat-assoc - -mulWord-idˡ : Identityˡ mulWord 1 -mulWord-idˡ = map-idˡ mulWord mulNat w2n n2w 1 1 *-wordsAsNats mulNat-idˡ - -mulWord-idʳ : Identityʳ mulWord 1 -mulWord-idʳ = map-idʳ mulWord mulNat w2n n2w 1 1 *-wordsAsNats mulNat-idʳ - -mulWord-distributeˡ-addWord : Distributiveˡ addWord mulWord -mulWord-distributeˡ-addWord = map-distributeˡ addWord addNat mulWord mulNat w2n n2w n2w∘w2n≡id w2n-+-hom w2n-*-hom mulNat-distributeˡ-addNat - -mulWord-distributeʳ-addWord : Distributiveʳ addWord mulWord -mulWord-distributeʳ-addWord = map-distributeʳ addWord addNat mulWord mulNat w2n n2w n2w∘w2n≡id w2n-+-hom w2n-*-hom mulNat-distributeʳ-addNat - -neg-inv-word : ∀ (x : Word) → addWord x (negateWord x) ≡ 0 -neg-inv-word x = - x + negateWord x ≡⟨⟩ - n2w (w2n x + w2n (negateWord x)) ≡⟨⟩ - n2w (w2n x + w2n (n2w (monusNat 2⁶⁴ (w2n x)))) ≡⟨ cong n2w (cong (w2n x +_) (w2n∘n2w≡id (monusNat 2⁶⁴ (w2n x)) (y-x≤y (w2n x) 2⁶⁴))) ⟩ - n2w (w2n x + monusNat 2⁶⁴ (w2n x)) ≡⟨ cong n2w (x+[y-x]≡y (w2n x) 2⁶⁴ (bounded x)) ⟩ - n2w 2⁶⁴ ≡⟨ max-int≡0 ⟩ - 0 ∎ - -instance - open IsLawfulNum - - iLawfulNumWord : IsLawfulNum Word - +-assoc iLawfulNumWord = addWord-assoc - +-comm iLawfulNumWord = addWord-comm - +-idˡ iLawfulNumWord = λ x → addWord-idˡ x - +-idʳ iLawfulNumWord = λ x → addWord-idʳ x - neg-inv iLawfulNumWord = λ x → neg-inv-word x - *-assoc iLawfulNumWord = mulWord-assoc - *-idˡ iLawfulNumWord = λ x → mulWord-idˡ x - *-idʳ iLawfulNumWord = λ x → mulWord-idʳ x - distributeˡ iLawfulNumWord = mulWord-distributeˡ-addWord - distributeʳ iLawfulNumWord = mulWord-distributeʳ-addWord diff --git a/lib/Haskell/Law/Ord.agda b/lib/Haskell/Law/Ord.agda deleted file mode 100644 --- a/lib/Haskell/Law/Ord.agda +++ /dev/null @@ -1,6 +0,0 @@ -module Haskell.Law.Ord where - -open import Haskell.Law.Ord.Def public -open import Haskell.Law.Ord.Bool public -open import Haskell.Law.Ord.Maybe public -open import Haskell.Law.Ord.Ordering public diff --git a/lib/Haskell/Law/Ord/Bool.agda b/lib/Haskell/Law/Ord/Bool.agda deleted file mode 100644 --- a/lib/Haskell/Law/Ord/Bool.agda +++ /dev/null @@ -1,68 +0,0 @@ -module Haskell.Law.Ord.Bool where - -open import Haskell.Prim -open import Haskell.Prim.Ord - -open import Haskell.Law.Eq -open import Haskell.Law.Equality -open import Haskell.Law.Ord.Def - -instance - iLawfulOrdBool : IsLawfulOrd Bool - - iLawfulOrdBool .comparability False False = refl - iLawfulOrdBool .comparability False True = refl - iLawfulOrdBool .comparability True False = refl - iLawfulOrdBool .comparability True True = refl - - iLawfulOrdBool .transitivity False False False _ = refl - iLawfulOrdBool .transitivity False False True _ = refl - iLawfulOrdBool .transitivity False True True _ = refl - iLawfulOrdBool .transitivity True True True _ = refl - - iLawfulOrdBool .reflexivity False = refl - iLawfulOrdBool .reflexivity True = refl - - iLawfulOrdBool .antisymmetry False False _ = refl - iLawfulOrdBool .antisymmetry True True _ = refl - - iLawfulOrdBool .lte2gte False False = refl - iLawfulOrdBool .lte2gte False True = refl - iLawfulOrdBool .lte2gte True False = refl - iLawfulOrdBool .lte2gte True True = refl - - iLawfulOrdBool .lt2LteNeq False False = refl - iLawfulOrdBool .lt2LteNeq False True = refl - iLawfulOrdBool .lt2LteNeq True False = refl - iLawfulOrdBool .lt2LteNeq True True = refl - - iLawfulOrdBool .lt2gt False False = refl - iLawfulOrdBool .lt2gt False True = refl - iLawfulOrdBool .lt2gt True False = refl - iLawfulOrdBool .lt2gt True True = refl - - iLawfulOrdBool .compareLt False False = refl - iLawfulOrdBool .compareLt False True = refl - iLawfulOrdBool .compareLt True False = refl - iLawfulOrdBool .compareLt True True = refl - - iLawfulOrdBool .compareGt False False = refl - iLawfulOrdBool .compareGt False True = refl - iLawfulOrdBool .compareGt True False = refl - iLawfulOrdBool .compareGt True True = refl - - iLawfulOrdBool .compareEq False False = refl - iLawfulOrdBool .compareEq False True = refl - iLawfulOrdBool .compareEq True False = refl - iLawfulOrdBool .compareEq True True = refl - - iLawfulOrdBool .min2if False False = refl - iLawfulOrdBool .min2if False True = refl - iLawfulOrdBool .min2if True False = refl - iLawfulOrdBool .min2if True True = refl - - iLawfulOrdBool .max2if False False = refl - iLawfulOrdBool .max2if False True = refl - iLawfulOrdBool .max2if True False = refl - iLawfulOrdBool .max2if True True = refl - diff --git a/lib/Haskell/Law/Ord/Def.agda b/lib/Haskell/Law/Ord/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Ord/Def.agda +++ /dev/null @@ -1,203 +0,0 @@ -module Haskell.Law.Ord.Def where - -open import Haskell.Prim -open import Haskell.Prim.Ord -open import Haskell.Prim.Bool -open import Haskell.Prim.Int -open import Haskell.Prim.Word -open import Haskell.Prim.Integer -open import Haskell.Prim.Double -open import Haskell.Prim.Tuple -open import Haskell.Prim.Monoid -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Either - -open import Haskell.Prim.Eq -open import Haskell.Law.Eq - -open import Haskell.Law.Bool -open import Haskell.Law.Equality - -record IsLawfulOrd (a : Set) ⦃ iOrd : Ord a ⦄ : Set₁ where - field - overlap ⦃ super ⦄ : IsLawfulEq a - - -- Comparability: x <= y || y <= x = True - comparability : ∀ (x y : a) → (x <= y || y <= x) ≡ True - - -- Transitivity: if x <= y && y <= z = True, then x <= z = True - transitivity : ∀ ( x y z : a ) → ((x <= y) && (y <= z)) ≡ True → (x <= z) ≡ True - - -- Reflexivity: x <= x = True - reflexivity : ∀ (x : a) → (x <= x) ≡ True - - -- Antisymmetry: if x <= y && y <= x = True, then x == y = True - antisymmetry : ∀ (x y : a) → ((x <= y) && (y <= x)) ≡ True → (x == y) ≡ True - - -- x >= y = y <= x - lte2gte : ∀ (x y : a) → (x <= y) ≡ (y >= x) - - -- x < y = x <= y && x /= y - lt2LteNeq : ∀ (x y : a) → (x < y) ≡ (x <= y && x /= y) - - -- x > y = y < x - lt2gt : ∀ (x y : a) → (x < y) ≡ (y > x) - - -- x < y = compare x y == LT - compareLt : ∀ (x y : a) → (x < y) ≡ (compare x y == LT) - - -- x > y = compare x y == GT - compareGt : ∀ (x y : a) → (x > y) ≡ (compare x y == GT) - - -- x == y = compare x y == EQ - compareEq : ∀ (x y : a) → (x == y) ≡ (compare x y == EQ) - - -- min x y == if x <= y then x else y = True - min2if : ∀ (x y : a) → ((min x y) == (if (x <= y) then x else y)) ≡ True - - -- max x y == if x >= y then x else y = True - max2if : ∀ (x y : a) → ((max x y) == (if (x >= y) then x else y)) ≡ True - -open IsLawfulOrd ⦃ ... ⦄ public - --------------------------------------------------- --- Some more helper laws - -eq2nlt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x == y) ≡ True → (x < y) ≡ False -eq2nlt x y h - rewrite compareEq x y - | compareLt x y - | equality (compare x y) EQ h - = refl - -eq2ngt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x == y) ≡ True → (x > y) ≡ False -eq2ngt x y h - rewrite compareEq x y - | compareGt x y - | equality (compare x y) EQ h - = refl - -lte2LtEq : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x <= y) ≡ (x < y || x == y) -lte2LtEq x y - rewrite lt2LteNeq x y - | compareEq x y - with (x <= y) in h₁ | (compare x y) in h₂ -... | False | LT = refl -... | False | EQ = magic $ exFalso (reflexivity x) $ begin - (x <= x) ≡⟨ (cong (x <=_) (equality x y (begin - (x == y) ≡⟨ compareEq x y ⟩ - (compare x y == EQ) ≡⟨ equality' (compare x y) EQ h₂ ⟩ - True ∎ ) ) ) ⟩ - (x <= y) ≡⟨ h₁ ⟩ - False ∎ -... | False | GT = refl -... | True | LT = refl -... | True | EQ = refl -... | True | GT = refl - -gte2GtEq : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x >= y) ≡ (x > y || x == y) -gte2GtEq x y - rewrite sym $ lte2gte y x - | lte2LtEq y x - | eqSymmetry y x - | lt2gt y x - = refl - -gte2nlt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x >= y) ≡ not (x < y) -gte2nlt x y - rewrite gte2GtEq x y - | compareGt x y - | compareEq x y - | compareLt x y - with compare x y -... | GT = refl -... | EQ = refl -... | LT = refl - -gte2nLT : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x >= y) ≡ (compare x y /= LT) -gte2nLT x y - rewrite gte2nlt x y - | compareLt x y - = refl - -lte2ngt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x <= y) ≡ not (x > y) -lte2ngt x y - rewrite lte2LtEq x y - | compareLt x y - | compareEq x y - | compareGt x y - with compare x y -... | GT = refl -... | EQ = refl -... | LT = refl - -lte2nGT : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x <= y) ≡ (compare x y /= GT) -lte2nGT x y - rewrite lte2ngt x y - | compareGt x y - = refl - -eq2lte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x == y) ≡ True → (x <= y) ≡ True -eq2lte x y h - rewrite lte2ngt x y - | eq2ngt x y h - = refl - -lt2lte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x < y) ≡ True → (x <= y) ≡ True -lt2lte x y h = &&-rightTrue' (x < y) (x <= y) (x /= y) (lt2LteNeq x y) h - -eq2gte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x == y) ≡ True → (x >= y) ≡ True -eq2gte x y h - rewrite gte2nlt x y - | eq2nlt x y h - = refl - -gt2gte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x > y) ≡ True → (x >= y) ≡ True -gt2gte x y h - rewrite sym (lt2gt y x) - | sym (lt2lte y x h) - | lte2gte y x - = refl - --------------------------------------------------- --- Postulated instances - -postulate instance - iLawfulOrdNat : IsLawfulOrd Nat - - iLawfulOrdInteger : IsLawfulOrd Integer - - iLawfulOrdInt : IsLawfulOrd Int - - iLawfulOrdWord : IsLawfulOrd Word - - iLawfulOrdDouble : IsLawfulOrd Double - - iLawfulOrdChar : IsLawfulOrd Char - - iLawfulOrdUnit : IsLawfulOrd ⊤ - - iLawfulOrdTuple₂ : ⦃ iOrdA : Ord a ⦄ ⦃ iOrdB : Ord b ⦄ - → ⦃ IsLawfulOrd a ⦄ → ⦃ IsLawfulOrd b ⦄ - → IsLawfulOrd (a × b) - - iLawfulOrdTuple₃ : ⦃ iOrdA : Ord a ⦄ ⦃ iOrdB : Ord b ⦄ ⦃ iOrdC : Ord c ⦄ - → ⦃ IsLawfulOrd a ⦄ → ⦃ IsLawfulOrd b ⦄ → ⦃ IsLawfulOrd c ⦄ - → IsLawfulOrd (a × b × c) - - iLawfulOrdList : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → IsLawfulOrd (List a) - - iLawfulOrdEither : ⦃ iOrdA : Ord a ⦄ → ⦃ iOrdB : Ord b ⦄ → ⦃ IsLawfulOrd a ⦄ → ⦃ IsLawfulOrd b ⦄ → IsLawfulOrd (Either a b) diff --git a/lib/Haskell/Law/Ord/Maybe.agda b/lib/Haskell/Law/Ord/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Law/Ord/Maybe.agda +++ /dev/null @@ -1,150 +0,0 @@ -module Haskell.Law.Ord.Maybe where - -open import Haskell.Prim -open import Haskell.Prim.Bool -open import Haskell.Prim.Eq -open import Haskell.Prim.Maybe -open import Haskell.Prim.Ord - -open import Haskell.Law.Bool -open import Haskell.Law.Eq -open import Haskell.Law.Equality hiding ( trustMe ) -open import Haskell.Law.Maybe -open import Haskell.Law.Ord.Def - -compMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → (x <= y || y <= x) ≡ True -compMaybe Nothing Nothing = refl -compMaybe Nothing (Just _) = refl -compMaybe (Just _) Nothing = refl -compMaybe (Just x) (Just y) - rewrite sym (lte2nGT x y) - | sym (lte2nGT y x) - = comparability x y - -transMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ ( x y z : Maybe a ) → ((x <= y) && (y <= z)) ≡ True → (x <= z) ≡ True -transMaybe Nothing Nothing Nothing _ = refl -transMaybe Nothing Nothing (Just _) _ = refl -transMaybe Nothing (Just _) (Just _) _ = refl -transMaybe (Just x) (Just y) Nothing h - = magic ((nequality (GT /= GT) True refl) (&&-rightTrue (compare x y /= GT) (GT /= GT) h)) -transMaybe (Just x) (Just y) (Just z) h - rewrite sym (compareGt x z) - | sym (lte2nGT x y) - | sym (lte2nGT y z) - | sym (lte2ngt x z) -- not (x > z) → (x <= z) - = transitivity x y z h - -reflMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x : Maybe a) → (x <= x) ≡ True -reflMaybe Nothing = refl -reflMaybe (Just x) - rewrite (equality (compare x x) EQ (trans (sym (compareEq x x)) (eqReflexivity x))) - = refl - -antisymmetryMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → ((x <= y) && (y <= x)) ≡ True → (x == y) ≡ True -antisymmetryMaybe Nothing Nothing _ = refl -antisymmetryMaybe (Just x) (Just y) h - rewrite sym (lte2nGT x y) - | sym (lte2nGT y x) - = antisymmetry x y h - -lte2gteMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → (x <= y) ≡ (y >= x) -lte2gteMaybe Nothing Nothing = refl -lte2gteMaybe Nothing (Just _) = refl -lte2gteMaybe (Just _) Nothing = refl -lte2gteMaybe (Just x) (Just y) - rewrite sym (compareGt x y) - | sym (lte2ngt x y) - | lte2gte x y -- IH - | gte2nlt y x - | compareLt y x - = refl - -lt2LteNeqMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → (x < y) ≡ (x <= y && x /= y) -lt2LteNeqMaybe Nothing Nothing = refl -lt2LteNeqMaybe Nothing (Just _) = refl -lt2LteNeqMaybe (Just _) Nothing = refl -lt2LteNeqMaybe (Just x) (Just y) - rewrite sym (compareLt x y) - | lt2LteNeq x y -- IH - | lte2ngt x y - | compareGt x y - = refl - -lt2gtMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → (x < y) ≡ (y > x) -lt2gtMaybe Nothing Nothing = refl -lt2gtMaybe Nothing (Just _) = refl -lt2gtMaybe (Just _) Nothing = refl -lt2gtMaybe (Just x) (Just y) - rewrite sym (compareLt x y) - | lt2gt x y -- IH - | compareGt y x - = refl - -compareLtMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → (x < y) ≡ (compare x y == LT) -compareLtMaybe Nothing Nothing = refl -compareLtMaybe Nothing (Just _) = refl -compareLtMaybe (Just _) Nothing = refl -compareLtMaybe (Just _) (Just _) = refl - -compareGtMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → (x > y) ≡ (compare x y == GT) -compareGtMaybe Nothing Nothing = refl -compareGtMaybe Nothing (Just _) = refl -compareGtMaybe (Just _) Nothing = refl -compareGtMaybe (Just _) (Just _) = refl - -compareEqMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ iLawfulOrdA : IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → (x == y) ≡ (compare x y == EQ) -compareEqMaybe Nothing Nothing = refl -compareEqMaybe Nothing (Just y) = refl -compareEqMaybe (Just x) Nothing = refl -compareEqMaybe (Just x) (Just y) = compareEq x y - -min2ifMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → ((min x y) == (if (x <= y) then x else y)) ≡ True -min2ifMaybe Nothing Nothing = refl -min2ifMaybe Nothing (Just _) = refl -min2ifMaybe (Just _) Nothing = refl -min2ifMaybe (Just x) (Just y) - rewrite sym (ifFlip (compare x y == GT) (Just x) (Just y)) - = equality' - (if (compare x y /= GT) then Just x else Just y) - (if (compare x y /= GT) then Just x else Just y) - refl - -max2ifMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : Maybe a) → ((max x y) == (if (x >= y) then x else y)) ≡ True -max2ifMaybe Nothing Nothing = refl -max2ifMaybe Nothing (Just y) = eqReflexivity y -max2ifMaybe (Just x) Nothing = eqReflexivity x -max2ifMaybe (Just x) (Just y) - rewrite sym (ifFlip (compare x y == LT) (Just x) (Just y)) - = equality' - (if (compare x y /= LT) then Just x else Just y) - (if (compare x y /= LT) then Just x else Just y) - refl - -instance - iLawfulOrdMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → IsLawfulOrd (Maybe a) - iLawfulOrdMaybe = λ where - .comparability → compMaybe - .transitivity → transMaybe - .reflexivity → reflMaybe - .antisymmetry → antisymmetryMaybe - .lte2gte → lte2gteMaybe - .lt2LteNeq → lt2LteNeqMaybe - .lt2gt → lt2gtMaybe - .compareLt → compareLtMaybe - .compareGt → compareGtMaybe - .compareEq → compareEqMaybe - .min2if → min2ifMaybe - .max2if → max2ifMaybe - diff --git a/lib/Haskell/Law/Ord/Ordering.agda b/lib/Haskell/Law/Ord/Ordering.agda deleted file mode 100644 --- a/lib/Haskell/Law/Ord/Ordering.agda +++ /dev/null @@ -1,121 +0,0 @@ -module Haskell.Law.Ord.Ordering where - -open import Haskell.Prim -open import Haskell.Prim.Ord - -open import Haskell.Law.Eq -open import Haskell.Law.Equality -open import Haskell.Law.Ord.Def - -instance - iLawfulOrdOrdering : IsLawfulOrd Ordering - - iLawfulOrdOrdering .comparability LT LT = refl - iLawfulOrdOrdering .comparability LT EQ = refl - iLawfulOrdOrdering .comparability LT GT = refl - iLawfulOrdOrdering .comparability EQ LT = refl - iLawfulOrdOrdering .comparability EQ EQ = refl - iLawfulOrdOrdering .comparability EQ GT = refl - iLawfulOrdOrdering .comparability GT LT = refl - iLawfulOrdOrdering .comparability GT EQ = refl - iLawfulOrdOrdering .comparability GT GT = refl - - iLawfulOrdOrdering .transitivity LT LT LT _ = refl - iLawfulOrdOrdering .transitivity LT LT EQ _ = refl - iLawfulOrdOrdering .transitivity LT LT GT _ = refl - iLawfulOrdOrdering .transitivity LT EQ EQ _ = refl - iLawfulOrdOrdering .transitivity LT EQ GT _ = refl - iLawfulOrdOrdering .transitivity LT GT GT _ = refl - iLawfulOrdOrdering .transitivity EQ EQ EQ _ = refl - iLawfulOrdOrdering .transitivity EQ EQ GT _ = refl - iLawfulOrdOrdering .transitivity EQ GT GT _ = refl - iLawfulOrdOrdering .transitivity GT GT GT _ = refl - - iLawfulOrdOrdering .reflexivity LT = refl - iLawfulOrdOrdering .reflexivity EQ = refl - iLawfulOrdOrdering .reflexivity GT = refl - - iLawfulOrdOrdering .antisymmetry LT LT _ = refl - iLawfulOrdOrdering .antisymmetry EQ EQ _ = refl - iLawfulOrdOrdering .antisymmetry GT GT _ = refl - - iLawfulOrdOrdering .lte2gte LT LT = refl - iLawfulOrdOrdering .lte2gte LT EQ = refl - iLawfulOrdOrdering .lte2gte LT GT = refl - iLawfulOrdOrdering .lte2gte EQ LT = refl - iLawfulOrdOrdering .lte2gte EQ EQ = refl - iLawfulOrdOrdering .lte2gte EQ GT = refl - iLawfulOrdOrdering .lte2gte GT LT = refl - iLawfulOrdOrdering .lte2gte GT EQ = refl - iLawfulOrdOrdering .lte2gte GT GT = refl - - iLawfulOrdOrdering .lt2LteNeq LT LT = refl - iLawfulOrdOrdering .lt2LteNeq LT EQ = refl - iLawfulOrdOrdering .lt2LteNeq LT GT = refl - iLawfulOrdOrdering .lt2LteNeq EQ LT = refl - iLawfulOrdOrdering .lt2LteNeq EQ EQ = refl - iLawfulOrdOrdering .lt2LteNeq EQ GT = refl - iLawfulOrdOrdering .lt2LteNeq GT LT = refl - iLawfulOrdOrdering .lt2LteNeq GT EQ = refl - iLawfulOrdOrdering .lt2LteNeq GT GT = refl - - iLawfulOrdOrdering .lt2gt LT LT = refl - iLawfulOrdOrdering .lt2gt LT EQ = refl - iLawfulOrdOrdering .lt2gt LT GT = refl - iLawfulOrdOrdering .lt2gt EQ LT = refl - iLawfulOrdOrdering .lt2gt EQ EQ = refl - iLawfulOrdOrdering .lt2gt EQ GT = refl - iLawfulOrdOrdering .lt2gt GT LT = refl - iLawfulOrdOrdering .lt2gt GT EQ = refl - iLawfulOrdOrdering .lt2gt GT GT = refl - - iLawfulOrdOrdering .compareLt LT LT = refl - iLawfulOrdOrdering .compareLt LT EQ = refl - iLawfulOrdOrdering .compareLt LT GT = refl - iLawfulOrdOrdering .compareLt EQ LT = refl - iLawfulOrdOrdering .compareLt EQ EQ = refl - iLawfulOrdOrdering .compareLt EQ GT = refl - iLawfulOrdOrdering .compareLt GT LT = refl - iLawfulOrdOrdering .compareLt GT EQ = refl - iLawfulOrdOrdering .compareLt GT GT = refl - - iLawfulOrdOrdering .compareGt LT LT = refl - iLawfulOrdOrdering .compareGt LT EQ = refl - iLawfulOrdOrdering .compareGt LT GT = refl - iLawfulOrdOrdering .compareGt EQ LT = refl - iLawfulOrdOrdering .compareGt EQ EQ = refl - iLawfulOrdOrdering .compareGt EQ GT = refl - iLawfulOrdOrdering .compareGt GT LT = refl - iLawfulOrdOrdering .compareGt GT EQ = refl - iLawfulOrdOrdering .compareGt GT GT = refl - - iLawfulOrdOrdering .compareEq LT LT = refl - iLawfulOrdOrdering .compareEq LT EQ = refl - iLawfulOrdOrdering .compareEq LT GT = refl - iLawfulOrdOrdering .compareEq EQ LT = refl - iLawfulOrdOrdering .compareEq EQ EQ = refl - iLawfulOrdOrdering .compareEq EQ GT = refl - iLawfulOrdOrdering .compareEq GT LT = refl - iLawfulOrdOrdering .compareEq GT EQ = refl - iLawfulOrdOrdering .compareEq GT GT = refl - - iLawfulOrdOrdering .min2if LT LT = refl - iLawfulOrdOrdering .min2if LT EQ = refl - iLawfulOrdOrdering .min2if LT GT = refl - iLawfulOrdOrdering .min2if EQ LT = refl - iLawfulOrdOrdering .min2if EQ EQ = refl - iLawfulOrdOrdering .min2if EQ GT = refl - iLawfulOrdOrdering .min2if GT LT = refl - iLawfulOrdOrdering .min2if GT EQ = refl - iLawfulOrdOrdering .min2if GT GT = refl - - iLawfulOrdOrdering .max2if LT LT = refl - iLawfulOrdOrdering .max2if LT EQ = refl - iLawfulOrdOrdering .max2if LT GT = refl - iLawfulOrdOrdering .max2if EQ LT = refl - iLawfulOrdOrdering .max2if EQ EQ = refl - iLawfulOrdOrdering .max2if EQ GT = refl - iLawfulOrdOrdering .max2if GT LT = refl - iLawfulOrdOrdering .max2if GT EQ = refl - iLawfulOrdOrdering .max2if GT GT = refl - diff --git a/lib/Haskell/Law/Semigroup/Def.agda b/lib/Haskell/Law/Semigroup/Def.agda deleted file mode 100644 --- a/lib/Haskell/Law/Semigroup/Def.agda +++ /dev/null @@ -1,27 +0,0 @@ -module Haskell.Law.Semigroup.Def where - -open import Haskell.Prim -open import Haskell.Prim.Tuple - -open import Haskell.Prim.Monoid - -record IsLawfulSemigroup (a : Set) ⦃ iSemigroupA : Semigroup a ⦄ : Set₁ where - field - -- Associativity: x <> (y <> z) = (x <> y) <> z - associativity : (x y z : a) → x <> (y <> z) ≡ (x <> y) <> z - -open IsLawfulSemigroup ⦃ ... ⦄ public - -postulate instance - iLawfulSemigroupFun : ⦃ iSemB : Semigroup b ⦄ → ⦃ IsLawfulSemigroup b ⦄ → IsLawfulSemigroup (a → b) - - iLawfulSemigroupUnit : IsLawfulSemigroup ⊤ - - iLawfulSemigroupTuple₂ : ⦃ iSemA : Semigroup a ⦄ ⦃ iSemB : Semigroup b ⦄ - → ⦃ IsLawfulSemigroup a ⦄ → ⦃ IsLawfulSemigroup b ⦄ - → IsLawfulSemigroup (a × b) - - iLawfulSemigroupTuple₃ : ⦃ iSemA : Semigroup a ⦄ ⦃ iSemB : Semigroup b ⦄ ⦃ iSemC : Semigroup c ⦄ - → ⦃ IsLawfulSemigroup a ⦄ → ⦃ IsLawfulSemigroup b ⦄ → ⦃ IsLawfulSemigroup c ⦄ - → IsLawfulSemigroup (a × b × c) - diff --git a/lib/Haskell/Law/Semigroup/Either.agda b/lib/Haskell/Law/Semigroup/Either.agda deleted file mode 100644 --- a/lib/Haskell/Law/Semigroup/Either.agda +++ /dev/null @@ -1,13 +0,0 @@ -module Haskell.Law.Semigroup.Either where - -open import Haskell.Prim -open import Haskell.Prim.Either - -open import Haskell.Prim.Monoid - -open import Haskell.Law.Equality -open import Haskell.Law.Semigroup.Def - -instance - iLawfulSemigroupEither : IsLawfulSemigroup (Either a b) - iLawfulSemigroupEither .associativity = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } diff --git a/lib/Haskell/Law/Semigroup/List.agda b/lib/Haskell/Law/Semigroup/List.agda deleted file mode 100644 --- a/lib/Haskell/Law/Semigroup/List.agda +++ /dev/null @@ -1,17 +0,0 @@ -module Haskell.Law.Semigroup.List where - -open import Haskell.Prim -open import Haskell.Prim.List - -open import Haskell.Prim.Monoid - -open import Haskell.Law.Equality -open import Haskell.Law.List -open import Haskell.Law.Semigroup.Def - -instance - iLawfulSemigroupList : IsLawfulSemigroup (List a) - iLawfulSemigroupList .associativity [] _ _ = refl - iLawfulSemigroupList .associativity (x ∷ xs) ys zs - rewrite sym (++-assoc xs ys zs) - = refl diff --git a/lib/Haskell/Law/Semigroup/Maybe.agda b/lib/Haskell/Law/Semigroup/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Law/Semigroup/Maybe.agda +++ /dev/null @@ -1,18 +0,0 @@ -module Haskell.Law.Semigroup.Maybe where - -open import Haskell.Prim -open import Haskell.Prim.Maybe - -open import Haskell.Prim.Monoid - -open import Haskell.Law.Equality -open import Haskell.Law.Semigroup.Def - -instance - iLawfulSemigroupMaybe : ⦃ iSemA : Semigroup a ⦄ → ⦃ IsLawfulSemigroup a ⦄ → IsLawfulSemigroup (Maybe a) - iLawfulSemigroupMaybe .associativity Nothing _ _ = refl - iLawfulSemigroupMaybe .associativity (Just _) Nothing _ = refl - iLawfulSemigroupMaybe .associativity (Just _) (Just _) Nothing = refl - iLawfulSemigroupMaybe .associativity (Just x) (Just y) (Just z) - rewrite associativity x y z - = refl diff --git a/lib/Haskell/Prelude.agda b/lib/Haskell/Prelude.agda deleted file mode 100644 --- a/lib/Haskell/Prelude.agda +++ /dev/null @@ -1,142 +0,0 @@ -{-# OPTIONS --no-auto-inline #-} -module Haskell.Prelude where - -open import Haskell.Prim -open Haskell.Prim public using - ( Bool; True; False; Char; Integer; - List; []; _∷_; Nat; zero; suc; ⊤; tt; - TypeError; ⊥; iNumberNat; lengthNat; - IsTrue; IsFalse; NonEmpty; - All; allNil; allCons; - Any; anyHere; anyThere; - id; _∘_; _$_; flip; const; - if_then_else_; case_of_; - Number; fromNat; Negative; fromNeg; - IsString; fromString; - _≡_; refl; - a; b; c; d; e; f; m; s; t ) - -open import Haskell.Prim.Absurd public -open import Haskell.Prim.Applicative public -open import Haskell.Prim.Bool public -open import Haskell.Prim.Bounded public -open import Haskell.Prim.Char public -open import Haskell.Prim.Double public -open import Haskell.Prim.Either public -open import Haskell.Prim.Enum public -open import Haskell.Prim.Eq public -open import Haskell.Prim.Foldable public -open import Haskell.Prim.Functor public -open import Haskell.Prim.Int public -open import Haskell.Prim.Integer public -open import Haskell.Prim.IO public -open import Haskell.Prim.List public -open import Haskell.Prim.Maybe public -open import Haskell.Prim.Monad public -open import Haskell.Prim.Monoid public -open import Haskell.Prim.Num public -open import Haskell.Prim.Ord public -open import Haskell.Prim.Show public -open import Haskell.Prim.String public -open import Haskell.Prim.Traversable public -open import Haskell.Prim.Tuple public hiding (first; second; _***_) -open import Haskell.Prim.Word public - --- Problematic features --- - [Partial]: Could pass implicit/instance arguments to prove totality. --- - [Float]: Or Float (Agda floats are Doubles) --- - [Infinite]: Define colists and map to Haskell lists? - --- Missing from the Haskell Prelude: --- --- Float [Float] --- Rational --- --- Real(toRational), --- Integral(quot, rem, div, mod, quotRem, divMod, toInteger), --- Fractional((/), recip, fromRational), --- Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, --- asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), --- RealFrac(properFraction, truncate, round, ceiling, floor), --- RealFloat(floatRadix, floatDigits, floatRange, decodeFloat, --- encodeFloat, exponent, significand, scaleFloat, isNaN, --- isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2), --- --- subtract, even, odd, gcd, lcm, (^), (^^), --- fromIntegral, realToFrac, --- --- foldr1, foldl1, maximum, minimum [Partial] --- --- until [Partial] --- --- iterate, repeat, cycle [Infinite] --- --- ReadS, Read(readsPrec, readList), --- reads, readParen, read, lex, --- --- IO, putChar, putStr, putStrLn, print, --- getChar, getLine, getContents, interact, --- FilePath, readFile, writeFile, appendFile, readIO, readLn, --- IOError, ioError, userError, - - --------------------------------------------------- --- Functions - -infixr 0 _$!_ - -_$!_ : (a → b) → a → b -_$!_ = _$_ - -seq : a → b → b -seq = const id - -asTypeOf : a → a → a -asTypeOf x _ = x - -undefined : {@0 @(tactic absurd) i : ⊥} → a -undefined {i = ()} - -error : {@0 @(tactic absurd) i : ⊥} → String → a -error {i = ()} err - -errorWithoutStackTrace : {@0 @(tactic absurd) i : ⊥} → String → a -errorWithoutStackTrace {i = ()} err - -------------------------------------------------- --- More List functions --- These uses Eq, Ord, or Foldable, so can't go in Prim.List without --- turning those dependencies around. - -reverse : List a → List a -reverse = foldl (flip _∷_) [] - -infixl 9 _!!_ _!!ᴺ_ - -_!!ᴺ_ : (xs : List a) (n : Nat) → @0 ⦃ IsTrue (n < lengthNat xs) ⦄ → a -(x ∷ xs) !!ᴺ zero = x -(x ∷ xs) !!ᴺ suc n = xs !!ᴺ n - -_!!_ : (xs : List a) (n : Int) - → ⦃ @0 nn : IsNonNegativeInt n ⦄ - → ⦃ @0 _ : IsTrue (intToNat n {{nn}} < lengthNat xs) ⦄ → a -xs !! n = xs !!ᴺ intToNat n - -lookup : ⦃ Eq a ⦄ → a → List (a × b) → Maybe b -lookup x [] = Nothing -lookup x ((x₁ , y) ∷ xs) = if x == x₁ then Just y else lookup x xs - - -------------------------------------------------- --- Unsafe functions - -coerce : @0 a ≡ b → a → b -coerce refl x = x - -IsJust : Maybe a → Set -IsJust Nothing = ⊥ -IsJust (Just _) = ⊤ - -fromJust : (x : Maybe a) → @0 {IsJust x} → a -fromJust Nothing = error "fromJust Nothing" -fromJust (Just x) = x diff --git a/lib/Haskell/Prim.agda b/lib/Haskell/Prim.agda deleted file mode 100644 --- a/lib/Haskell/Prim.agda +++ /dev/null @@ -1,130 +0,0 @@ -{-# OPTIONS --no-auto-inline #-} - --- Basic things needed by other primitive modules. --- Note that this module exports types and functions that should not --- be used directly in Haskell definitions, so you probably want to --- import Haskell.Prelude instead. - -module Haskell.Prim where - -open import Agda.Primitive public -open import Agda.Builtin.Bool public renaming (true to True; false to False) -open import Agda.Builtin.Int public renaming (Int to Integer) -open import Agda.Builtin.Nat public renaming (_==_ to eqNat; _<_ to ltNat; _+_ to addNat; _-_ to monusNat; _*_ to mulNat) -open import Agda.Builtin.Char public renaming (primCharToNat to c2n) -open import Agda.Builtin.Unit public -open import Agda.Builtin.Equality public -open import Agda.Builtin.FromString public -open import Agda.Builtin.FromNat public -open import Agda.Builtin.FromNeg public -open import Agda.Builtin.String public renaming (String to AgdaString) -open import Agda.Builtin.Word public renaming (primWord64ToNat to w2n; primWord64FromNat to n2w) -open import Agda.Builtin.Strict public -open import Agda.Builtin.List public - -variable - @0 ℓ : Level - a b c d e : Set - f m s t : Set → Set - - --------------------------------------------------- --- Functions - -id : a → a -id x = x - -infixr 9 _∘_ -_∘_ : (b → c) → (a → b) → a → c -(f ∘ g) x = f (g x) - -flip : (a → b → c) → b → a → c -flip f x y = f y x - -const : a → b → a -const x _ = x - -infixr 0 _$_ -_$_ : (a → b) → a → b -f $ x = f x - - --------------------------------------------------- --- Language constructs - -infix -1 case_of_ -case_of_ : (a' : a) → ((a'' : a) → @0 {{ a' ≡ a'' }} → b) → b -case x of f = f x - -infix -2 if_then_else_ -if_then_else_ : {@0 a : Set ℓ} → (flg : Bool) → (@0 {{ flg ≡ True }} → a) → (@0 {{ flg ≡ False }} → a) → a -if False then x else y = y -if True then x else y = x - --- for explicit type signatures (e. g. `4 :: Integer` is `the Int 4`) -the : (@0 a : Set ℓ) -> a -> a -the _ x = x - --------------------------------------------------- --- Agda strings - -instance - iIsStringAgdaString : IsString AgdaString - iIsStringAgdaString .IsString.Constraint _ = ⊤ - iIsStringAgdaString .fromString s = s - - --------------------------------------------------- --- Numbers - -instance - iNumberNat : Number Nat - iNumberNat .Number.Constraint _ = ⊤ - iNumberNat .fromNat n = n - - --------------------------------------------------- --- Lists - -lengthNat : List a → Nat -lengthNat [] = 0 -lengthNat (_ ∷ xs) = addNat 1 (lengthNat xs) - - --------------------------------------------------- --- Proof things - -data ⊥ : Set where - -magic : {A : Set} → ⊥ → A -magic () - ---principle of explosion -exFalso : {x : Bool} → (x ≡ True) → (x ≡ False) → ⊥ -exFalso {False} () b -exFalso {True} a () - --- Use to bundle up constraints -data All {a b} {A : Set a} (B : A → Set b) : List A → Set (a ⊔ b) where - instance - allNil : All B [] - allCons : ∀ {x xs} ⦃ i : B x ⦄ ⦃ is : All B xs ⦄ → All B (x ∷ xs) - -data Any {a b} {A : Set a} (B : A → Set b) : List A → Set (a ⊔ b) where - instance - anyHere : ∀ {x xs} ⦃ i : B x ⦄ → Any B (x ∷ xs) - anyThere : ∀ {x xs} ⦃ is : Any B xs ⦄ → Any B (x ∷ xs) - -data IsTrue : Bool → Set where - instance itsTrue : IsTrue True - -data IsFalse : Bool → Set where - instance itsFalse : IsFalse False - -data NonEmpty {a : Set} : List a → Set where - instance itsNonEmpty : ∀ {x xs} → NonEmpty (x ∷ xs) - -data TypeError (err : AgdaString) : Set where - -it : ∀ {@0 ℓ} {@0 a : Set ℓ} → ⦃ a ⦄ → a -it ⦃ x ⦄ = x diff --git a/lib/Haskell/Prim/Absurd.agda b/lib/Haskell/Prim/Absurd.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Absurd.agda +++ /dev/null @@ -1,23 +0,0 @@ - -module Haskell.Prim.Absurd where - -open import Haskell.Prim - -open import Agda.Builtin.Reflection renaming (bindTC to _>>=_; absurd to absurdP) - -private - - pattern vArg x = arg (arg-info visible (modality relevant quantity-ω)) x - - refute : Nat → Term - refute i = def (quote _$_) ( vArg (pat-lam (absurd-clause [] (vArg (absurdP 0) ∷ []) ∷ []) []) - ∷ vArg (var i []) ∷ []) - - tryRefute : Nat → Term → TC ⊤ - tryRefute 0 _ = typeError (strErr "No variable of empty type found in the context" ∷ []) - tryRefute (suc n) hole = catchTC (unify hole (refute n)) (tryRefute n hole) - -absurd : Term → TC ⊤ -absurd hole = do - Γ ← getContext - tryRefute (lengthNat Γ) hole diff --git a/lib/Haskell/Prim/Applicative.agda b/lib/Haskell/Prim/Applicative.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Applicative.agda +++ /dev/null @@ -1,92 +0,0 @@ -module Haskell.Prim.Applicative where - -open import Haskell.Prim -open import Haskell.Prim.Either -open import Haskell.Prim.Foldable -open import Haskell.Prim.Functor -open import Haskell.Prim.IO -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Monoid -open import Haskell.Prim.Tuple - - --------------------------------------------------- --- Applicative - --- ** base -record Applicative (f : Set → Set) : Set₁ where - infixl 4 _<*>_ _<*_ _*>_ - field - pure : a → f a - _<*>_ : f (a → b) → f a → f b - overlap ⦃ super ⦄ : Functor f - _<*_ : f a → f b → f a - _*>_ : f a → f b → f b --- ** defaults -record DefaultApplicative (f : Set → Set) : Set₁ where - constructor mk - infixl 4 _<*>_ _<*_ _*>_ - field - pure : a → f a - _<*>_ : f (a → b) → f a → f b - overlap ⦃ super ⦄ : Functor f - - _<*_ : f a → f b → f a - x <* y = const <$> x <*> y - - _*>_ : f a → f b → f b - x *> y = const id <$> x <*> y --- ** export -open Applicative ⦃...⦄ public -{-# COMPILE AGDA2HS Applicative existing-class #-} --- ** instances -instance - open DefaultApplicative - - iDefaultApplicativeList : DefaultApplicative List - iDefaultApplicativeList .pure x = x ∷ [] - iDefaultApplicativeList ._<*>_ fs xs = concatMap (λ f → map f xs) fs - - iApplicativeList : Applicative List - iApplicativeList = record {DefaultApplicative iDefaultApplicativeList} - - iDefaultApplicativeMaybe : DefaultApplicative Maybe - iDefaultApplicativeMaybe .pure = Just - iDefaultApplicativeMaybe ._<*>_ (Just f) (Just x) = Just (f x) - iDefaultApplicativeMaybe ._<*>_ _ _ = Nothing - - iApplicativeMaybe : Applicative Maybe - iApplicativeMaybe = record {DefaultApplicative iDefaultApplicativeMaybe} - - iDefaultApplicativeEither : DefaultApplicative (Either a) - iDefaultApplicativeEither .pure = Right - iDefaultApplicativeEither ._<*>_ (Right f) (Right x) = Right (f x) - iDefaultApplicativeEither ._<*>_ (Left e) _ = Left e - iDefaultApplicativeEither ._<*>_ _ (Left e) = Left e - - iApplicativeEither : Applicative (Either a) - iApplicativeEither = record{DefaultApplicative iDefaultApplicativeEither} - - iDefaultApplicativeFun : DefaultApplicative (λ b → a → b) - iDefaultApplicativeFun .pure = const - iDefaultApplicativeFun ._<*>_ f g x = f x (g x) - - iApplicativeFun : Applicative (λ b → a → b) - iApplicativeFun = record{DefaultApplicative iDefaultApplicativeFun} - - iDefaultApplicativeTuple₂ : ⦃ Monoid a ⦄ → DefaultApplicative (a ×_) - iDefaultApplicativeTuple₂ .pure x = mempty , x - iDefaultApplicativeTuple₂ ._<*>_ (a , f) (b , x) = a <> b , f x - - iApplicativeTuple₂ : ⦃ Monoid a ⦄ → Applicative (a ×_) - iApplicativeTuple₂ = record{DefaultApplicative iDefaultApplicativeTuple₂} - - iDefaultApplicativeTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → DefaultApplicative (a × b ×_) - iDefaultApplicativeTuple₃ .pure x = mempty , mempty , x - iDefaultApplicativeTuple₃ ._<*>_ (a , u , f) (b , v , x) = a <> b , u <> v , f x - - iApplicativeTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Applicative (a × b ×_) - iApplicativeTuple₃ = record{DefaultApplicative iDefaultApplicativeTuple₃} - -instance postulate iApplicativeIO : Applicative IO diff --git a/lib/Haskell/Prim/Bool.agda b/lib/Haskell/Prim/Bool.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Bool.agda +++ /dev/null @@ -1,24 +0,0 @@ - -module Haskell.Prim.Bool where - -open import Haskell.Prim - --------------------------------------------------- --- Booleans - -infixr 3 _&&_ -_&&_ : Bool → Bool → Bool -False && _ = False -True && x = x - -infixr 2 _||_ -_||_ : Bool → Bool → Bool -False || x = x -True || _ = True - -not : Bool → Bool -not False = True -not True = False - -otherwise : Bool -otherwise = True diff --git a/lib/Haskell/Prim/Bounded.agda b/lib/Haskell/Prim/Bounded.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Bounded.agda +++ /dev/null @@ -1,94 +0,0 @@ - -module Haskell.Prim.Bounded where - -open import Haskell.Prim -open import Haskell.Prim.Eq -open import Haskell.Prim.Int -open import Haskell.Prim.Maybe -open import Haskell.Prim.Ord -open import Haskell.Prim.Tuple -open import Haskell.Prim.Word - --------------------------------------------------- --- Bounded - -record BoundedBelow (a : Set) : Set where - field - minBound : a - -record BoundedAbove (a : Set) : Set where - field - maxBound : a - -record Bounded (a : Set) : Set where - field - overlap ⦃ below ⦄ : BoundedBelow a - overlap ⦃ above ⦄ : BoundedAbove a - -{-# COMPILE AGDA2HS Bounded existing-class #-} - -open BoundedBelow ⦃...⦄ public -open BoundedAbove ⦃...⦄ public - -instance - iBounded : ⦃ BoundedBelow a ⦄ → ⦃ BoundedAbove a ⦄ → Bounded a - iBounded .Bounded.below = it - iBounded .Bounded.above = it - -instance - iBoundedBelowNat : BoundedBelow Nat - iBoundedBelowNat .minBound = 0 - - iBoundedBelowWord : BoundedBelow Word - iBoundedBelowWord .minBound = 0 - iBoundedAboveWord : BoundedAbove Word - iBoundedAboveWord .maxBound = 18446744073709551615 - - iBoundedBelowInt : BoundedBelow Int - iBoundedBelowInt .minBound = -9223372036854775808 - iBoundedAboveInt : BoundedAbove Int - iBoundedAboveInt .maxBound = 9223372036854775807 - - iBoundedBelowBool : BoundedBelow Bool - iBoundedBelowBool .minBound = False - iBoundedAboveBool : BoundedAbove Bool - iBoundedAboveBool .maxBound = True - - iBoundedBelowChar : BoundedBelow Char - iBoundedBelowChar .minBound = '\0' - iBoundedAboveChar : BoundedAbove Char - iBoundedAboveChar .maxBound = '\1114111' - - iBoundedBelowUnit : BoundedBelow ⊤ - iBoundedBelowUnit .minBound = tt - - iBoundedAboveUnit : BoundedAbove ⊤ - iBoundedAboveUnit .maxBound = tt - - iBoundedBelowTuple₂ : ⦃ BoundedBelow a ⦄ → ⦃ BoundedBelow b ⦄ - → BoundedBelow (a × b) - iBoundedBelowTuple₂ .minBound = minBound , minBound - iBoundedAboveTuple₂ : ⦃ BoundedAbove a ⦄ → ⦃ BoundedAbove b ⦄ - → BoundedAbove (a × b) - iBoundedAboveTuple₂ .maxBound = maxBound , maxBound - - iBoundedBelowTuple₃ : ⦃ BoundedBelow a ⦄ → ⦃ BoundedBelow b ⦄ → ⦃ BoundedBelow c ⦄ - → BoundedBelow (a × b × c) - iBoundedBelowTuple₃ .minBound = minBound , minBound , minBound - iBoundedAboveTuple₃ : ⦃ BoundedAbove a ⦄ → ⦃ BoundedAbove b ⦄ → ⦃ BoundedAbove c ⦄ - → BoundedAbove (a × b × c) - iBoundedAboveTuple₃ .maxBound = maxBound , maxBound , maxBound - - iBoundedBelowOrdering : BoundedBelow Ordering - iBoundedBelowOrdering .minBound = LT - iBoundedAboveOrdering : BoundedAbove Ordering - iBoundedAboveOrdering .maxBound = GT - --- Sanity checks - -private - _ : addWord maxBound 1 ≡ minBound - _ = refl - - _ : addInt maxBound 1 ≡ minBound - _ = refl diff --git a/lib/Haskell/Prim/Char.agda b/lib/Haskell/Prim/Char.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Char.agda +++ /dev/null @@ -1,9 +0,0 @@ -module Haskell.Prim.Char where - -open import Haskell.Prim - -import Agda.Builtin.Char -open Agda.Builtin.Char using (Char) - -eqChar : Char → Char → Bool -eqChar a b = eqNat (c2n a) (c2n b) diff --git a/lib/Haskell/Prim/Double.agda b/lib/Haskell/Prim/Double.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Double.agda +++ /dev/null @@ -1,15 +0,0 @@ - -module Haskell.Prim.Double where - -open import Agda.Builtin.Float public renaming (Float to Double) - -open import Haskell.Prim - -instance - iNumberDouble : Number Double - iNumberDouble .Number.Constraint _ = ⊤ - iNumberDouble .fromNat n = primNatToFloat n - - iNegativeDouble : Negative Double - iNegativeDouble .Negative.Constraint _ = ⊤ - iNegativeDouble .fromNeg n = primFloatMinus 0.0 (fromNat n) diff --git a/lib/Haskell/Prim/Either.agda b/lib/Haskell/Prim/Either.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Either.agda +++ /dev/null @@ -1,20 +0,0 @@ - -module Haskell.Prim.Either where - -open import Haskell.Prim -open import Haskell.Prim.Bool - --------------------------------------------------- --- Either - -data Either (a b : Set) : Set where - Left : a → Either a b - Right : b → Either a b - -either : (a → c) → (b → c) → Either a b → c -either f g (Left x) = f x -either f g (Right y) = g y - -testBool : (b : Bool) → Either (IsFalse b) (IsTrue b) -testBool False = Left itsFalse -testBool True = Right itsTrue diff --git a/lib/Haskell/Prim/Enum.agda b/lib/Haskell/Prim/Enum.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Enum.agda +++ /dev/null @@ -1,263 +0,0 @@ - -module Haskell.Prim.Enum where - -open import Haskell.Prim -open import Haskell.Prim.Bool -open import Haskell.Prim.Bounded -open import Haskell.Prim.Either -open import Haskell.Prim.Eq -open import Haskell.Prim.Functor -open import Haskell.Prim.Int -open import Haskell.Prim.Integer -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Num -open import Haskell.Prim.Ord -open import Haskell.Prim.Tuple -open import Haskell.Prim.Word - - --------------------------------------------------- --- Enum --- Assumptions: unbounded enums have no constraints on their --- operations and bounded enums should work on all values between --- minBound and maxBound. Unbounded enums do not support enumFrom --- and enumFromThen (since they return infinite lists). - -@0 IfBoundedBelow : Maybe (BoundedBelow a) → (⦃ BoundedBelow a ⦄ → Set) → Set -IfBoundedBelow Nothing k = ⊤ -IfBoundedBelow (Just i) k = k ⦃ i ⦄ - -@0 IfBoundedAbove : Maybe (BoundedAbove a) → (⦃ BoundedAbove a ⦄ → Set) → Set -IfBoundedAbove Nothing k = ⊤ -IfBoundedAbove (Just i) k = k ⦃ i ⦄ - -record Enum (a : Set) : Set₁ where - field - BoundedBelowEnum : Maybe (BoundedBelow a) - BoundedAboveEnum : Maybe (BoundedAbove a) - fromEnum : a → Int - - private - @0 IsBoundedBelow : Set - IsBoundedBelow = maybe ⊥ (λ _ → ⊤) BoundedBelowEnum - - @0 IsBoundedAbove : Set - IsBoundedAbove = maybe ⊥ (λ _ → ⊤) BoundedAboveEnum - - @0 TrueIfLB : (⦃ BoundedBelow a ⦄ → Bool) → Set - TrueIfLB C = IfBoundedBelow BoundedBelowEnum (IsTrue C) - - @0 TrueIfUB : (⦃ BoundedAbove a ⦄ → Bool) → Set - TrueIfUB C = IfBoundedAbove BoundedAboveEnum (IsTrue C) - - @0 FalseIfLB : (⦃ BoundedBelow a ⦄ → Bool) → Set - FalseIfLB C = IfBoundedBelow BoundedBelowEnum (IsFalse C) - - @0 FalseIfUB : (⦃ BoundedAbove a ⦄ → Bool) → Set - FalseIfUB C = IfBoundedAbove BoundedAboveEnum (IsFalse C) - - minInt : ⦃ BoundedBelow a ⦄ → Int - minInt ⦃ _ ⦄ = fromEnum minBound - - maxInt : ⦃ BoundedAbove a ⦄ → Int - maxInt ⦃ _ ⦄ = fromEnum maxBound - - field - toEnum : (n : Int) → @0 ⦃ TrueIfLB (minInt <= n) ⦄ → @0 ⦃ TrueIfUB (n <= maxInt) ⦄ → a - succ : (x : a) → @0 ⦃ FalseIfUB (fromEnum x == maxInt) ⦄ → a - pred : (x : a) → @0 ⦃ FalseIfLB (fromEnum x == minInt) ⦄ → a - - enumFrom : @0 ⦃ IsBoundedAbove ⦄ → a → List a - enumFromTo : a → a → List a - -- In the Prelude Enum instances `enumFromThenTo x x y` gives the - -- infinite list of `x`s. The constraint is a little bit stronger than it needs to be, - -- since it rules out different x and x₁ that maps to the same Int, but this saves us - -- requiring an Eq instance for `a`, and it's not a terrible limitation to not be able to - -- write [0, 2^64 .. 2^66]. - enumFromThenTo : (x x₁ : a) → @0 ⦃ IsFalse (fromEnum x == fromEnum x₁) ⦄ → a → List a - enumFromThen : @0 ⦃ IsBoundedBelow ⦄ → @0 ⦃ IsBoundedAbove ⦄ → (x x₁ : a) → @0 ⦃ IsFalse (fromEnum x == fromEnum x₁) ⦄ → List a - -open Enum ⦃...⦄ public - -{-# COMPILE AGDA2HS Enum existing-class #-} - -private - divNat : Nat → Nat → Nat - divNat a 0 = 0 - divNat a (suc b) = div-helper 0 b a b - - diff : Integer → Integer → Maybe Nat - diff a b = - case a - b of λ where - (pos n) → Just n - (negsuc _) → Nothing - - unsafeIntegerToNat : Integer → Nat - unsafeIntegerToNat (pos n) = n - unsafeIntegerToNat (negsuc _) = 0 - - integerFromCount : Integer → Integer → Nat → List Integer - integerFromCount a step 0 = [] - integerFromCount a step (suc n) = a ∷ integerFromCount (a + step) step n - - integerFromTo : Integer → Integer → List Integer - integerFromTo a b = maybe [] (integerFromCount a 1 ∘ suc) (diff b a) - - integerFromThenTo : (a a₁ : Integer) → @0 ⦃ IsFalse (integerToInt a == integerToInt a₁) ⦄ → Integer → List Integer - integerFromThenTo a a₁ b = - case compare a a₁ of λ where - LT → maybe [] (λ d → integerFromCount a (a₁ - a) (suc (divNat d (unsafeIntegerToNat (a₁ - a))))) (diff b a) - EQ → [] -- impossible - GT → maybe [] (λ d → integerFromCount a (a₁ - a) (suc (divNat d (unsafeIntegerToNat (a - a₁))))) (diff a b) - -instance - iEnumInteger : Enum Integer - iEnumInteger .BoundedBelowEnum = Nothing - iEnumInteger .BoundedAboveEnum = Nothing - iEnumInteger .fromEnum = integerToInt - iEnumInteger .toEnum n = intToInteger n - iEnumInteger .succ = _+ 1 - iEnumInteger .pred = _- 1 - iEnumInteger .enumFromTo = integerFromTo - iEnumInteger .enumFromThenTo = integerFromThenTo - -private - fromTo : (from : a → Integer) (to : Integer → a) - → a → a → List a - fromTo from to a b = map to (enumFromTo (from a) (from b)) - - fromThenTo : (from : a → Integer) (to : Integer → a) - → (x x₁ : a) → @0 ⦃ IsFalse (fromEnum (from x) == fromEnum (from x₁)) ⦄ → a → List a - fromThenTo from to a a₁ b = map to (enumFromThenTo (from a) (from a₁) (from b)) - - -instance - iEnumNat : Enum Nat - iEnumNat .BoundedBelowEnum = Just it - iEnumNat .BoundedAboveEnum = Nothing - iEnumNat .fromEnum = integerToInt ∘ pos - iEnumNat .toEnum n = unsafeIntegerToNat (intToInteger n) - iEnumNat .succ n = suc n - iEnumNat .pred (suc n) = n - iEnumNat .enumFromTo = fromTo pos unsafeIntegerToNat - iEnumNat .enumFromThenTo = fromThenTo pos unsafeIntegerToNat - - iEnumInt : Enum Int - iEnumInt .BoundedBelowEnum = Just it - iEnumInt .BoundedAboveEnum = Just it - iEnumInt .fromEnum = integerToInt ∘ intToInteger - iEnumInt .toEnum n = integerToInt (intToInteger n) - iEnumInt .succ x = integerToInt (intToInteger x + 1) - iEnumInt .pred x = integerToInt (intToInteger x - 1) - iEnumInt .enumFromTo a b = fromTo intToInteger integerToInt a b - iEnumInt .enumFromThenTo a a₁ b = fromThenTo intToInteger integerToInt a a₁ b - iEnumInt .enumFrom a = fromTo intToInteger integerToInt a maxBound - iEnumInt .enumFromThen a a₁ = - if a < a₁ then fromThenTo intToInteger integerToInt a a₁ maxBound - else fromThenTo intToInteger integerToInt a a₁ minBound - - iEnumWord : Enum Word - iEnumWord .BoundedBelowEnum = Just it - iEnumWord .BoundedAboveEnum = Just it - iEnumWord .fromEnum = integerToInt ∘ wordToInteger - iEnumWord .toEnum n = integerToWord (intToInteger n) - iEnumWord .succ x = integerToWord (wordToInteger x + 1) - iEnumWord .pred x = integerToWord (wordToInteger x - 1) - iEnumWord .enumFromTo a b = fromTo wordToInteger integerToWord a b - iEnumWord .enumFromThenTo a a₁ b = fromThenTo wordToInteger integerToWord a a₁ b - iEnumWord .enumFrom a = fromTo wordToInteger integerToWord a maxBound - iEnumWord .enumFromThen a a₁ = - if a < a₁ then fromThenTo wordToInteger integerToWord a a₁ maxBound - else fromThenTo wordToInteger integerToWord a a₁ minBound - -private - fromBool : Bool → Integer - fromBool = if_then 1 else 0 - - toBool : Integer → Bool - toBool = _/= 0 - -instance - iEnumBool : Enum Bool - iEnumBool .BoundedBelowEnum = Just it - iEnumBool .BoundedAboveEnum = Just it - iEnumBool .fromEnum = integerToInt ∘ fromBool - iEnumBool .toEnum n = toBool (intToInteger n) - iEnumBool .succ x = toBool (fromBool x + 1) - iEnumBool .pred x = toBool (fromBool x - 1) - iEnumBool .enumFromTo a b = fromTo fromBool toBool a b - iEnumBool .enumFromThenTo a a₁ b = fromThenTo fromBool toBool a a₁ b - iEnumBool .enumFrom a = fromTo fromBool toBool a maxBound - iEnumBool .enumFromThen a a₁ = - if a < a₁ then fromThenTo fromBool toBool a a₁ maxBound - else fromThenTo fromBool toBool a a₁ minBound - -private - fromOrdering : Ordering → Integer - fromOrdering = λ where LT → 0; EQ → 1; GT → 2 - - toOrdering : Integer → Ordering - toOrdering = λ where (pos 0) → LT; (pos 1) → EQ; _ → GT - -instance - iEnumOrdering : Enum Ordering - iEnumOrdering .BoundedBelowEnum = Just it - iEnumOrdering .BoundedAboveEnum = Just it - iEnumOrdering .fromEnum = integerToInt ∘ fromOrdering - iEnumOrdering .toEnum n = toOrdering (intToInteger n) - iEnumOrdering .succ x = toOrdering (fromOrdering x + 1) - iEnumOrdering .pred x = toOrdering (fromOrdering x - 1) - iEnumOrdering .enumFromTo a b = fromTo fromOrdering toOrdering a b - iEnumOrdering .enumFromThenTo a a₁ b = fromThenTo fromOrdering toOrdering a a₁ b - iEnumOrdering .enumFrom a = fromTo fromOrdering toOrdering a maxBound - iEnumOrdering .enumFromThen a a₁ = - if a < a₁ then fromThenTo fromOrdering toOrdering a a₁ maxBound - else fromThenTo fromOrdering toOrdering a a₁ minBound - -private - fromUnit : ⊤ → Integer - fromUnit _ = 0 - - toUnit : Integer → ⊤ - toUnit _ = tt - -instance - iEnumUnit : Enum ⊤ - iEnumUnit .BoundedBelowEnum = Just it - iEnumUnit .BoundedAboveEnum = Just it - iEnumUnit .fromEnum = integerToInt ∘ fromUnit - iEnumUnit .toEnum n = toUnit (intToInteger n) - iEnumUnit .succ x = toUnit (fromUnit x + 1) - iEnumUnit .pred x = toUnit (fromUnit x - 1) - iEnumUnit .enumFromTo a b = fromTo fromUnit toUnit a b - iEnumUnit .enumFromThenTo a a₁ b = fromThenTo fromUnit toUnit a a₁ b - iEnumUnit .enumFrom a = fromTo fromUnit toUnit a maxBound - iEnumUnit .enumFromThen a a₁ = - if a < a₁ then fromThenTo fromUnit toUnit a a₁ maxBound - else fromThenTo fromUnit toUnit a a₁ minBound - -private - fromChar : Char → Integer - fromChar = pos ∘ c2n - - toChar : Integer → Char - toChar = λ where (pos n) → primNatToChar n; _ → '_' - -instance - iEnumChar : Enum Char - iEnumChar .BoundedBelowEnum = Just it - iEnumChar .BoundedAboveEnum = Just it - iEnumChar .fromEnum = integerToInt ∘ fromChar - iEnumChar .toEnum n = toChar (intToInteger n) - iEnumChar .succ x = toChar (fromChar x + 1) - iEnumChar .pred x = toChar (fromChar x - 1) - iEnumChar .enumFromTo a b = fromTo fromChar toChar a b - iEnumChar .enumFromThenTo a a₁ b = fromThenTo fromChar toChar a a₁ b - iEnumChar .enumFrom a = fromTo fromChar toChar a maxBound - iEnumChar .enumFromThen a a₁ = - if a < a₁ then fromThenTo fromChar toChar a a₁ maxBound - else fromThenTo fromChar toChar a a₁ minBound - - -- Missing: - -- Enum Double (can't go via Integer) diff --git a/lib/Haskell/Prim/Eq.agda b/lib/Haskell/Prim/Eq.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Eq.agda +++ /dev/null @@ -1,82 +0,0 @@ - -module Haskell.Prim.Eq where - -open import Haskell.Prim -open import Haskell.Prim.Bool -open import Haskell.Prim.Char -open import Haskell.Prim.Integer -open import Haskell.Prim.Int -open import Haskell.Prim.Word -open import Haskell.Prim.Double -open import Haskell.Prim.Tuple -open import Haskell.Prim.Maybe -open import Haskell.Prim.Either - --------------------------------------------------- --- Eq - -record Eq (a : Set) : Set where - infix 4 _==_ - field - _==_ : a → a → Bool - -open Eq ⦃...⦄ public - -{-# COMPILE AGDA2HS Eq existing-class #-} - -_/=_ : {{Eq a}} → a → a → Bool -x /= y = not (x == y) - -infix 4 _/=_ - -instance - iEqNat : Eq Nat - iEqNat ._==_ = eqNat - - iEqInteger : Eq Integer - iEqInteger ._==_ = eqInteger - - iEqInt : Eq Int - iEqInt ._==_ = eqInt - - iEqWord : Eq Word - iEqWord ._==_ = eqWord - - iEqDouble : Eq Double - iEqDouble ._==_ = primFloatEquality - - iEqBool : Eq Bool - iEqBool ._==_ False False = True - iEqBool ._==_ True True = True - iEqBool ._==_ _ _ = False - - iEqChar : Eq Char - iEqChar ._==_ = eqChar - - iEqUnit : Eq ⊤ - iEqUnit ._==_ _ _ = True - - iEqTuple₂ : ⦃ Eq a ⦄ → ⦃ Eq b ⦄ → Eq (a × b) - iEqTuple₂ ._==_ (x₁ , y₁) (x₂ , y₂) = x₁ == x₂ && y₁ == y₂ - - iEqTuple₃ : ⦃ Eq a ⦄ → ⦃ Eq b ⦄ → ⦃ Eq c ⦄ → Eq (a × b × c) - iEqTuple₃ ._==_ (x₁ , y₁ , z₁) (x₂ , y₂ , z₂) = x₁ == x₂ && y₁ == y₂ && z₁ == z₂ - - iEqList : ⦃ Eq a ⦄ → Eq (List a) - iEqList {a} ._==_ = eqList - where - eqList : List a → List a → Bool - eqList [] [] = True - eqList (x ∷ xs) (y ∷ ys) = x == y && eqList xs ys - eqList _ _ = False - - - iEqMaybe : ⦃ Eq a ⦄ → Eq (Maybe a) - iEqMaybe ._==_ Nothing Nothing = True - iEqMaybe ._==_ (Just x) (Just y) = x == y - iEqMaybe ._==_ _ _ = False - - iEqEither : ⦃ Eq a ⦄ → ⦃ Eq b ⦄ → Eq (Either a b) - iEqEither ._==_ (Left x) (Left y) = x == y - iEqEither ._==_ (Right x) (Right y) = x == y - iEqEither ._==_ _ _ = False diff --git a/lib/Haskell/Prim/Foldable.agda b/lib/Haskell/Prim/Foldable.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Foldable.agda +++ /dev/null @@ -1,122 +0,0 @@ - -module Haskell.Prim.Foldable where - -open import Haskell.Prim -open import Haskell.Prim.Num hiding (abs) -open import Haskell.Prim.Eq -open import Haskell.Prim.List -open import Haskell.Prim.Int -open import Haskell.Prim.Bool -open import Haskell.Prim.Maybe -open import Haskell.Prim.Either -open import Haskell.Prim.Tuple -open import Haskell.Prim.Monoid - --------------------------------------------------- --- Foldable - --- ** base -record Foldable (t : Set → Set) : Set₁ where - field - foldMap : ⦃ Monoid b ⦄ → (a → b) → t a → b - foldr : (a → b → b) → b → t a → b - foldl : (b → a → b) → b → t a → b - any : (a → Bool) → t a → Bool - all : (a → Bool) → t a → Bool - and : t Bool → Bool - null : t a → Bool - or : t Bool → Bool - concat : t (List a) → List a - concatMap : (a → List b) → t a → List b - elem : ⦃ Eq a ⦄ → a → t a → Bool - notElem : ⦃ Eq a ⦄ → a → t a → Bool - toList : t a → List a - sum : ⦃ iNum : Num a ⦄ → t a → a - product : ⦃ iNum : Num a ⦄ → t a → a - length : t a → Int --- ** defaults -record DefaultFoldable (t : Set → Set) : Set₁ where - module M = Foldable {t = t} - field foldMap : ⦃ Monoid b ⦄ → (a → b) → t a → b - - foldr : (a → b → b) → b → t a → b - foldr f z t = foldMap ⦃ MonoidEndo ⦄ f t z - - foldl : (b → a → b) → b → t a → b - foldl f z t = foldMap ⦃ MonoidEndoᵒᵖ ⦄ (flip f) t z - - any : (a → Bool) → t a → Bool - any = foldMap ⦃ MonoidDisj ⦄ - - all : (a → Bool) → t a → Bool - all = foldMap ⦃ MonoidConj ⦄ - - and : t Bool → Bool - and = all id - - or : t Bool → Bool - or = any id - - null : t a → Bool - null = all (const False) - - concat : t (List a) → List a - concat = foldMap id - - concatMap : (a → List b) → t a → List b - concatMap = foldMap - - elem : ⦃ Eq a ⦄ → a → t a → Bool - elem x = foldMap ⦃ MonoidDisj ⦄ (x ==_) - - notElem : ⦃ Eq a ⦄ → a → t a → Bool - notElem x t = not (elem x t) - - toList : t a → List a - toList = foldr _∷_ [] - - sum : ⦃ iNum : Num a ⦄ → t a → a - sum = foldMap ⦃ MonoidSum ⦄ id - - product : ⦃ iNum : Num a ⦄ → t a → a - product = foldMap ⦃ MonoidProduct ⦄ id - - length : t a → Int - length = foldMap ⦃ MonoidSum ⦄ (const 1) --- ** export -open Foldable ⦃...⦄ public -{-# COMPILE AGDA2HS Foldable existing-class #-} - --- ** instances -instance - iDefaultFoldableList : DefaultFoldable List - iDefaultFoldableList .DefaultFoldable.foldMap = foldMapList - where - foldMapList : ⦃ Monoid b ⦄ → (a → b) → List a → b - foldMapList f [] = mempty - foldMapList f (x ∷ xs) = f x <> foldMapList f xs - - iFoldableList : Foldable List - iFoldableList = record {DefaultFoldable iDefaultFoldableList} - - iDefaultFoldableMaybe : DefaultFoldable Maybe - iDefaultFoldableMaybe .DefaultFoldable.foldMap = λ where - _ Nothing → mempty - f (Just x) → f x - - iFoldableMaybe : Foldable Maybe - iFoldableMaybe = record {DefaultFoldable iDefaultFoldableMaybe} - - iDefaultFoldableEither : DefaultFoldable (Either a) - iDefaultFoldableEither .DefaultFoldable.foldMap = λ where - _ (Left _) → mempty - f (Right x) → f x - - iFoldableEither : Foldable (Either a) - iFoldableEither = record {DefaultFoldable iDefaultFoldableEither} - - iDefaultFoldablePair : DefaultFoldable (a ×_) - iDefaultFoldablePair .DefaultFoldable.foldMap = λ f (_ , x) → f x - - iFoldablePair : Foldable (a ×_) - iFoldablePair = record {DefaultFoldable iDefaultFoldablePair} diff --git a/lib/Haskell/Prim/Functor.agda b/lib/Haskell/Prim/Functor.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Functor.agda +++ /dev/null @@ -1,89 +0,0 @@ - -module Haskell.Prim.Functor where - -open import Haskell.Prim -open import Haskell.Prim.Either -open import Haskell.Prim.IO -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Tuple - --------------------------------------------------- --- Functor - --- ** base -record Functor (f : Set → Set) : Set₁ where - infixl 4 _<$_ - field - fmap : (a → b) → f a → f b - _<$_ : (@0 {{ b }} → a) → f b → f a --- ** defaults -record DefaultFunctor (f : Set → Set) : Set₁ where - field fmap : (a → b) → f a → f b - - infixl 4 _<$_ - - _<$_ : (@0 {{ b }} → a) → f b → f a - x <$ m = fmap (λ b → x {{b}}) m - --- ** export -open Functor ⦃...⦄ public -{-# COMPILE AGDA2HS Functor existing-class #-} - -_<$>_ : {{Functor f}} → (a → b) → f a → f b -_<$>_ = fmap - -_<&>_ : {{Functor f}} → f a → (a → b) → f b -m <&> f = fmap f m - -_$>_ : {{Functor f}} → f a → (@0 {{ a }} → b) → f b -m $> x = x <$ m - -void : {{Functor f}} → f a → f ⊤ -void = tt <$_ - -infixl 1 _<&>_ -infixl 4 _<$>_ _$>_ - -instance - iDefaultFunctorList : DefaultFunctor List - iDefaultFunctorList .DefaultFunctor.fmap = map - - iFunctorList : Functor List - iFunctorList = record{DefaultFunctor iDefaultFunctorList} - - iDefaultFunctorMaybe : DefaultFunctor Maybe - iDefaultFunctorMaybe .DefaultFunctor.fmap = λ where - f Nothing → Nothing - f (Just x) → Just (f x) - - iFunctorMaybe : Functor Maybe - iFunctorMaybe = record{DefaultFunctor iDefaultFunctorMaybe} - - iDefaultFunctorEither : DefaultFunctor (Either a) - iDefaultFunctorEither .DefaultFunctor.fmap = λ where - f (Left x) → Left x - f (Right y) → Right (f y) - - iFunctorEither : Functor (Either a) - iFunctorEither = record{DefaultFunctor iDefaultFunctorEither} - - iDefaultFunctorFun : DefaultFunctor (λ b → a → b) - iDefaultFunctorFun .DefaultFunctor.fmap = _∘_ - - iFunctorFun : Functor (λ b → a → b) - iFunctorFun = record{DefaultFunctor iDefaultFunctorFun} - - iDefaultFunctorTuple₂ : DefaultFunctor (a ×_) - iDefaultFunctorTuple₂ .DefaultFunctor.fmap = λ f (x , y) → x , f y - - iFunctorTuple₂ : Functor (a ×_) - iFunctorTuple₂ = record{DefaultFunctor iDefaultFunctorTuple₂} - - iDefaultFunctorTuple₃ : DefaultFunctor (a × b ×_) - iDefaultFunctorTuple₃ .DefaultFunctor.fmap = λ where f (x , y , z) → x , y , f z - - iFunctorTuple₃ : Functor (a × b ×_) - iFunctorTuple₃ = record{DefaultFunctor iDefaultFunctorTuple₃} - -instance postulate iFunctorIO : Functor IO diff --git a/lib/Haskell/Prim/IO.agda b/lib/Haskell/Prim/IO.agda deleted file mode 100644 --- a/lib/Haskell/Prim/IO.agda +++ /dev/null @@ -1,27 +0,0 @@ -module Haskell.Prim.IO where - -open import Haskell.Prim -open import Haskell.Prim.Show -open import Haskell.Prim.String - -postulate IO : ∀{a} → Set a → Set a - -FilePath = String - -postulate - -- Input functions - interact : (String → String) → IO ⊤ - getContents : IO String - getLine : IO String - getChar : IO Char - - -- Output functions - print : ⦃ Show a ⦄ → a → IO ⊤ - putChar : Char → IO ⊤ - putStr : String → IO ⊤ - putStrLn : String → IO ⊤ - - -- Files - readFile : FilePath → IO String - writeFile : FilePath → String → IO ⊤ - appendFile : FilePath → String → IO ⊤ diff --git a/lib/Haskell/Prim/Int.agda b/lib/Haskell/Prim/Int.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Int.agda +++ /dev/null @@ -1,110 +0,0 @@ -{-# OPTIONS --no-auto-inline #-} - --- Agda doesn't have an Int type (only Word64). With some work we --- can represent signed ints using Word64. - -module Haskell.Prim.Int where - -open import Haskell.Prim -open import Haskell.Prim.Word -open import Haskell.Prim.Integer -open import Haskell.Prim.Bool - - --------------------------------------------------- --- Definition - -data Int : Set where - int64 : Word64 → Int - -intToWord : Int → Word64 -intToWord (int64 a) = a - -unsafeIntToNat : Int → Nat -unsafeIntToNat a = w2n (intToWord a) - - --------------------------------------------------- --- Literals - -private - 2⁶⁴ : Nat - 2⁶⁴ = 18446744073709551616 - - 2⁶³ : Nat - 2⁶³ = 9223372036854775808 - - maxInt : Nat - maxInt = monusNat 2⁶³ 1 - -instance - iNumberInt : Number Int - iNumberInt .Number.Constraint n = IsTrue (ltNat n 2⁶³) - iNumberInt .fromNat n = int64 (n2w n) - - iNegativeInt : Negative Int - iNegativeInt .Negative.Constraint n = IsTrue (ltNat n (addNat 1 2⁶³)) - iNegativeInt .fromNeg n = int64 (n2w (monusNat 2⁶⁴ n)) - - --------------------------------------------------- --- Arithmetic - -isNegativeInt : Int → Bool -isNegativeInt (int64 w) = ltNat maxInt (w2n w) - -eqInt : Int → Int → Bool -eqInt (int64 a) (int64 b) = eqNat (w2n a) (w2n b) - -negateInt : Int → Int -negateInt (int64 a) = int64 (n2w (monusNat 2⁶⁴ (w2n a))) - -intToInteger : Int → Integer -intToInteger a = if isNegativeInt a then negsuc (monusNat (unsafeIntToNat (negateInt a)) 1) - else pos (unsafeIntToNat a) - -integerToInt : Integer → Int -integerToInt (pos n) = int64 (n2w n) -integerToInt (negsuc n) = negateInt (int64 (n2w (suc n))) - -private - ltPosInt : Int → Int → Bool - ltPosInt (int64 a) (int64 b) = ltWord a b - -ltInt : Int → Int → Bool -ltInt a b with isNegativeInt a | isNegativeInt b -... | True | False = True -... | False | True = False -... | True | True = ltPosInt (negateInt b) (negateInt a) -... | False | False = ltPosInt a b - -addInt : Int → Int → Int -addInt (int64 a) (int64 b) = int64 (addWord a b) - -subInt : Int → Int → Int -subInt a b = addInt a (negateInt b) - -mulInt : Int → Int → Int -mulInt (int64 a) (int64 b) = int64 (mulWord a b) - -absInt : Int → Int -absInt a = if isNegativeInt a then negateInt a else a - -signInt : Int → Int -signInt a = if isNegativeInt a then -1 - else if eqInt a 0 then 0 else 1 - -showInt : Int → List Char -showInt a = showInteger (intToInteger a) - - --------------------------------------------------- --- Constraints - -@0 IsNonNegativeInt : Int → Set -IsNonNegativeInt a@(int64 _) = - if isNegativeInt a then TypeError (primStringAppend (primStringFromList (showInt a)) " is negative") - else ⊤ - -intToNat : (a : Int) → @0 ⦃ IsNonNegativeInt a ⦄ → Nat -intToNat a = unsafeIntToNat a diff --git a/lib/Haskell/Prim/Integer.agda b/lib/Haskell/Prim/Integer.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Integer.agda +++ /dev/null @@ -1,106 +0,0 @@ - -module Haskell.Prim.Integer where - -open import Haskell.Prim -open import Haskell.Prim.Bool - -{-| -This module contains functions that should not be used -within code that is supposed to be translated to Haskell. -Nevertheless, these functions must be accessible for -proofs (within the standard library). -Hence, these functions are not flagged as private but -instead are collected in a dedicated module that is not -opened by default. --} -module Internal where - negNat : Nat → Integer - negNat 0 = pos 0 - negNat (suc n) = negsuc n - - subNat : Nat → Nat → Integer - subNat n zero = pos n - subNat zero (suc m) = negsuc m - subNat (suc n) (suc m) = subNat n m -open Internal - --------------------------------------------------- --- Literals - - -instance - iNumberInteger : Number Integer - iNumberInteger .Number.Constraint _ = ⊤ - iNumberInteger .fromNat n = pos n - - iNegativeInteger : Negative Integer - iNegativeInteger .Negative.Constraint _ = ⊤ - iNegativeInteger .fromNeg n = negNat n - - --------------------------------------------------- --- Arithmetic - -negateInteger : Integer → Integer -negateInteger (pos 0) = pos 0 -negateInteger (pos (suc n)) = negsuc n -negateInteger (negsuc n) = pos (suc n) - -addInteger : Integer → Integer → Integer -addInteger (pos n) (pos m) = pos (addNat n m) -addInteger (pos n) (negsuc m) = subNat n (suc m) -addInteger (negsuc n) (pos m) = subNat m (suc n) -addInteger (negsuc n) (negsuc m) = negsuc (suc (addNat n m)) - -subInteger : Integer → Integer → Integer -subInteger n m = addInteger n (negateInteger m) - -mulInteger : Integer → Integer → Integer -mulInteger (pos n) (pos m) = pos (mulNat n m) -mulInteger (pos n) (negsuc m) = negNat (mulNat n (suc m)) -mulInteger (negsuc n) (pos m) = negNat (mulNat (suc n) m) -mulInteger (negsuc n) (negsuc m) = pos (mulNat (suc n) (suc m)) - -absInteger : Integer → Integer -absInteger (pos n) = pos n -absInteger (negsuc n) = pos (suc n) - -signInteger : Integer → Integer -signInteger (pos 0) = 0 -signInteger (pos (suc _)) = 1 -signInteger (negsuc _) = -1 - - --------------------------------------------------- --- Comparisons - -eqInteger : Integer → Integer → Bool -eqInteger (pos n) (pos m) = eqNat n m -eqInteger (negsuc n) (negsuc m) = eqNat n m -eqInteger _ _ = False - -ltInteger : Integer → Integer → Bool -ltInteger (pos n) (pos m) = ltNat n m -ltInteger (pos n) (negsuc _) = False -ltInteger (negsuc n) (pos _) = True -ltInteger (negsuc n) (negsuc m) = ltNat m n - - --------------------------------------------------- --- Show - -showInteger : Integer → List Char -showInteger n = primStringToList (primShowInteger n) - - --------------------------------------------------- --- Constraints - -isNegativeInteger : Integer → Bool -isNegativeInteger (pos _) = False -isNegativeInteger (negsuc _) = True - -@0 IsNonNegativeInteger : Integer → Set -IsNonNegativeInteger (pos _) = ⊤ -IsNonNegativeInteger n@(negsuc _) = - TypeError (primStringAppend (primShowInteger n) (" is negative")) diff --git a/lib/Haskell/Prim/List.agda b/lib/Haskell/Prim/List.agda deleted file mode 100644 --- a/lib/Haskell/Prim/List.agda +++ /dev/null @@ -1,128 +0,0 @@ - -module Haskell.Prim.List where - -open import Haskell.Prim -open import Haskell.Prim.Bool -open import Haskell.Prim.Tuple -open import Haskell.Prim.Int - - --------------------------------------------------- --- List - -map : (a → b) → List a → List b -map f [] = [] -map f (x ∷ xs) = f x ∷ map f xs - -infixr 5 _++_ -_++_ : ∀ {@0 ℓ} {@0 a : Set ℓ} → List a → List a → List a -[] ++ ys = ys -(x ∷ xs) ++ ys = x ∷ xs ++ ys - -filter : (a → Bool) → List a → List a -filter p [] = [] -filter p (x ∷ xs) = if p x then x ∷ filter p xs else filter p xs - -scanl : (b → a → b) → b → List a → List b -scanl f z [] = z ∷ [] -scanl f z (x ∷ xs) = z ∷ scanl f (f z x) xs - -scanr : (a → b → b) → b → List a → List b -scanr f z [] = z ∷ [] -scanr f z (x ∷ xs) = - case scanr f z xs of λ where - [] → [] -- impossible - qs@(q ∷ _) → f x q ∷ qs - -scanl1 : (a → a → a) → List a → List a -scanl1 f [] = [] -scanl1 f (x ∷ xs) = scanl f x xs - -scanr1 : (a → a → a) → List a → List a -scanr1 f [] = [] -scanr1 f (x ∷ []) = x ∷ [] -scanr1 f (x ∷ xs) = - case scanr1 f xs of λ where - [] → [] -- impossible - qs@(q ∷ _) → f x q ∷ qs - -takeWhile : (a → Bool) → List a → List a -takeWhile p [] = [] -takeWhile p (x ∷ xs) = if p x then x ∷ takeWhile p xs else [] - -dropWhile : (a → Bool) → List a → List a -dropWhile p [] = [] -dropWhile p (x ∷ xs) = if p x then dropWhile p xs else x ∷ xs - -span : (a → Bool) → List a → List a × List a -span p [] = [] , [] -span p (x ∷ xs) = if p x then first (x ∷_) (span p xs) - else ([] , x ∷ xs) - -break : (a → Bool) → List a → List a × List a -break p = span (not ∘ p) - -zipWith : (a → b → c) → List a → List b → List c -zipWith f [] _ = [] -zipWith f _ [] = [] -zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys - -zip : List a → List b → List (a × b) -zip = zipWith _,_ - -zipWith3 : (a → b → c → d) → List a → List b → List c → List d -zipWith3 f [] _ _ = [] -zipWith3 f _ [] _ = [] -zipWith3 f _ _ [] = [] -zipWith3 f (x ∷ xs) (y ∷ ys) (z ∷ zs) = f x y z ∷ zipWith3 f xs ys zs - -zip3 : List a → List b → List c → List (a × b × c) -zip3 = zipWith3 _,_,_ - -unzip : List (a × b) → List a × List b -unzip [] = [] , [] -unzip ((x , y) ∷ xys) = (x ∷_) *** (y ∷_) $ unzip xys - -unzip3 : List (a × b × c) → List a × List b × List c -unzip3 [] = [] , [] , [] -unzip3 ((x , y , z) ∷ xyzs) = - case unzip3 xyzs of λ where - (xs , ys , zs) → x ∷ xs , y ∷ ys , z ∷ zs - -takeNat : Nat → List a → List a -takeNat n [] = [] -takeNat zero xs = [] -takeNat (suc n) (x ∷ xs) = x ∷ takeNat n xs - -take : (n : Int) → @0 ⦃ IsNonNegativeInt n ⦄ → List a → List a -take n xs = takeNat (intToNat n) xs - -dropNat : Nat → List a → List a -dropNat n [] = [] -dropNat zero xs = xs -dropNat (suc n) (_ ∷ xs) = dropNat n xs - -drop : (n : Int) → @0 ⦃ IsNonNegativeInt n ⦄ → List a → List a -drop n xs = dropNat (intToNat n) xs - -splitAtNat : (n : Nat) → List a → List a × List a -splitAtNat _ [] = [] , [] -splitAtNat 0 xs = [] , xs -splitAtNat (suc n) (x ∷ xs) = first (x ∷_) (splitAtNat n xs) - -splitAt : (n : Int) → @0 ⦃ IsNonNegativeInt n ⦄ → List a → List a × List a -splitAt n xs = splitAtNat (intToNat n) xs - -head : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → a -head (x ∷ _) = x - -tail : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → List a -tail (_ ∷ xs) = xs - -last : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → a -last (x ∷ []) = x -last (_ ∷ xs@(_ ∷ _)) = last xs - -init : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → List a -init (x ∷ []) = [] -init (x ∷ xs@(_ ∷ _)) = x ∷ init xs diff --git a/lib/Haskell/Prim/Maybe.agda b/lib/Haskell/Prim/Maybe.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Maybe.agda +++ /dev/null @@ -1,17 +0,0 @@ - -module Haskell.Prim.Maybe where - --------------------------------------------------- --- Maybe - -data Maybe {@0 ℓ} (a : Set ℓ) : Set ℓ where - Nothing : Maybe a - Just : a -> Maybe a - -maybe : ∀ {@0 ℓ₁ ℓ₂} {@0 a : Set ℓ₁} {@0 b : Set ℓ₂} → b → (a → b) → Maybe a → b -maybe n j Nothing = n -maybe n j (Just x) = j x - -fromMaybe : {a : Set} → a → Maybe a → a -fromMaybe d Nothing = d -fromMaybe _ (Just x) = x diff --git a/lib/Haskell/Prim/Monad.agda b/lib/Haskell/Prim/Monad.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Monad.agda +++ /dev/null @@ -1,129 +0,0 @@ - -module Haskell.Prim.Monad where - -open import Haskell.Prim -open import Haskell.Prim.Applicative -open import Haskell.Prim.Either -open import Haskell.Prim.Foldable -open import Haskell.Prim.Functor -open import Haskell.Prim.IO -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Monoid -open import Haskell.Prim.String -open import Haskell.Prim.Tuple - --------------------------------------------------- --- Monad - -module Do where - - -- ** base - record Monad (m : Set → Set) : Set₁ where - field - _>>=_ : m a → (a → m b) → m b - overlap ⦃ super ⦄ : Applicative m - return : a → m a - _>>_ : m a → (@0 {{ a }} → m b) → m b - -- ** defaults - record DefaultMonad (m : Set → Set) : Set₁ where - field - _>>=_ : m a → (a → m b) → m b - overlap ⦃ super ⦄ : Applicative m - return : a → m a - return = pure - - _>>_ : m a → (@0 {{ a }} → m b) → m b - m >> m₁ = m >>= λ x → m₁ {{x}} - - -- ** export - open Monad ⦃...⦄ public - {-# COMPILE AGDA2HS Monad existing-class #-} - --- Use `Dont._>>=_` and `Dont._>>_` if you do not want agda2hs to use --- do-notation. -module Dont where - - open Do using (Monad) - - _>>=_ : ⦃ Monad m ⦄ → m a → (a → m b) → m b - _>>=_ = Do._>>=_ - - _>>_ : ⦃ Monad m ⦄ → m a → (@0 {{ a }} → m b) → m b - _>>_ = Do._>>_ - -open Do public - -_=<<_ : {{Monad m}} → (a → m b) → m a → m b -_=<<_ = flip _>>=_ - -mapM₋ : ⦃ Monad m ⦄ → ⦃ Foldable t ⦄ → (a → m b) → t a → m ⊤ -mapM₋ f = foldr (λ x k → f x >> k) (pure tt) - -sequence₋ : ⦃ Monad m ⦄ → ⦃ Foldable t ⦄ → t (m a) → m ⊤ -sequence₋ = foldr (λ mx my → mx >> my) (pure tt) - --- ** instances -private - mkMonad : DefaultMonad t → Monad t - mkMonad x = record {DefaultMonad x} - - infix 0 bind=_ - bind=_ : ⦃ Applicative m ⦄ → (∀ {a b} → m a → (a → m b) → m b) → Monad m - bind= x = record {DefaultMonad (record {_>>=_ = x})} -instance - iDefaultMonadList : DefaultMonad List - iDefaultMonadList .DefaultMonad._>>=_ = flip concatMap - - iMonadList : Monad List - iMonadList = record {DefaultMonad iDefaultMonadList} - - iDefaultMonadMaybe : DefaultMonad Maybe - iDefaultMonadMaybe .DefaultMonad._>>=_ = flip (maybe Nothing) - - iMonadMaybe : Monad Maybe - iMonadMaybe = record {DefaultMonad iDefaultMonadMaybe} - - iDefaultMonadEither : DefaultMonad (Either a) - iDefaultMonadEither .DefaultMonad._>>=_ = flip (either Left) - - iMonadEither : Monad (Either a) - iMonadEither = record {DefaultMonad iDefaultMonadEither} - - iDefaultMonadFun : DefaultMonad (λ b → a → b) - iDefaultMonadFun .DefaultMonad._>>=_ = λ f k r → k (f r) r - - iMonadFun : Monad (λ b → a → b) - iMonadFun = record {DefaultMonad iDefaultMonadFun} - - iDefaultMonadTuple₂ : ⦃ Monoid a ⦄ → DefaultMonad (a ×_) - iDefaultMonadTuple₂ .DefaultMonad._>>=_ = λ (a , x) k → first (a <>_) (k x) - - iMonadTuple₂ : ⦃ Monoid a ⦄ → Monad (a ×_) - iMonadTuple₂ = record {DefaultMonad iDefaultMonadTuple₂} - - iDefaultMonadTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → DefaultMonad (a × b ×_) - iDefaultMonadTuple₃ .DefaultMonad._>>=_ = λ where - (a , b , x) k → case k x of λ where - (a₁ , b₁ , y) → a <> a₁ , b <> b₁ , y - - iMonadTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Monad (a × b ×_) - iMonadTuple₃ = record {DefaultMonad iDefaultMonadTuple₃} - -instance postulate iMonadIO : Monad IO - -record MonadFail (m : Set → Set) : Set₁ where - field - fail : String → m a - overlap ⦃ super ⦄ : Monad m - -open MonadFail ⦃...⦄ public - -{-# COMPILE AGDA2HS MonadFail existing-class #-} - -instance - MonadFailList : MonadFail List - MonadFailList .fail _ = [] - - MonadFailMaybe : MonadFail Maybe - MonadFailMaybe .fail _ = Nothing diff --git a/lib/Haskell/Prim/Monoid.agda b/lib/Haskell/Prim/Monoid.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Monoid.agda +++ /dev/null @@ -1,130 +0,0 @@ - -module Haskell.Prim.Monoid where - -open import Haskell.Prim -open import Haskell.Prim.Bool -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Either -open import Haskell.Prim.Tuple - --------------------------------------------------- --- Semigroup - -record Semigroup (a : Set) : Set where - infixr 6 _<>_ - field _<>_ : a → a → a -open Semigroup ⦃...⦄ public -{-# COMPILE AGDA2HS Semigroup existing-class #-} - -instance - iSemigroupList : Semigroup (List a) - iSemigroupList ._<>_ = _++_ - - iSemigroupMaybe : ⦃ Semigroup a ⦄ → Semigroup (Maybe a) - iSemigroupMaybe ._<>_ Nothing m = m - iSemigroupMaybe ._<>_ m Nothing = m - iSemigroupMaybe ._<>_ (Just x) (Just y) = Just (x <> y) - - iSemigroupEither : Semigroup (Either a b) - iSemigroupEither ._<>_ (Left _) e = e - iSemigroupEither ._<>_ e _ = e - - iSemigroupFun : ⦃ Semigroup b ⦄ → Semigroup (a → b) - iSemigroupFun ._<>_ f g x = f x <> g x - - iSemigroupUnit : Semigroup ⊤ - iSemigroupUnit ._<>_ _ _ = tt - - - iSemigroupTuple₂ : ⦃ Semigroup a ⦄ → ⦃ Semigroup b ⦄ → Semigroup (a × b) - iSemigroupTuple₂ ._<>_ (x₁ , y₁) (x₂ , y₂) = x₁ <> x₂ , y₁ <> y₂ - - iSemigroupTuple₃ : ⦃ Semigroup a ⦄ → ⦃ Semigroup b ⦄ → ⦃ Semigroup c ⦄ → Semigroup (a × b × c) - iSemigroupTuple₃ ._<>_ (x₁ , y₁ , z₁) (x₂ , y₂ , z₂) = x₁ <> x₂ , y₁ <> y₂ , z₁ <> z₂ - - --------------------------------------------------- --- Monoid - --- ** base -record Monoid (a : Set) : Set where - field - mempty : a - overlap ⦃ super ⦄ : Semigroup a - mappend : a → a → a - mconcat : List a → a --- ** defaults -record DefaultMonoid (a : Set) : Set where - field - mempty : a - overlap ⦃ super ⦄ : Semigroup a - - mappend : a → a → a - mappend = _<>_ - - mconcat : List a → a - mconcat [] = mempty - mconcat (x ∷ xs) = x <> mconcat xs --- ** export -open Monoid ⦃...⦄ public -{-# COMPILE AGDA2HS Monoid existing-class #-} --- ** instances -instance - iDefaultMonoidList : DefaultMonoid (List a) - iDefaultMonoidList .DefaultMonoid.mempty = [] - - iMonoidList : Monoid (List a) - iMonoidList = record{DefaultMonoid iDefaultMonoidList} - - iDefaultMonoidMaybe : ⦃ Semigroup a ⦄ → DefaultMonoid (Maybe a) - iDefaultMonoidMaybe .DefaultMonoid.mempty = Nothing - - iMonoidMaybe : ⦃ Semigroup a ⦄ → Monoid (Maybe a) - iMonoidMaybe = record{DefaultMonoid iDefaultMonoidMaybe} - - iDefaultMonoidFun : ⦃ Monoid b ⦄ → DefaultMonoid (a → b) - iDefaultMonoidFun .DefaultMonoid.mempty = λ _ → mempty - - iMonoidFun : ⦃ Monoid b ⦄ → Monoid (a → b) - iMonoidFun = record{DefaultMonoid iDefaultMonoidFun} - - iDefaultMonoidUnit : DefaultMonoid ⊤ - iDefaultMonoidUnit .DefaultMonoid.mempty = tt - - iMonoidUnit : Monoid ⊤ - iMonoidUnit = record{DefaultMonoid iDefaultMonoidUnit} - - iDefaultMonoidTuple₂ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → DefaultMonoid (a × b) - iDefaultMonoidTuple₂ .DefaultMonoid.mempty = (mempty , mempty) - - iMonoidTuple₂ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Monoid (a × b) - iMonoidTuple₂ = record{DefaultMonoid iDefaultMonoidTuple₂} - - iDefaultMonoidTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → ⦃ Monoid c ⦄ → DefaultMonoid (a × b × c) - iDefaultMonoidTuple₃ .DefaultMonoid.mempty = (mempty , mempty , mempty) - - iMonoidTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → ⦃ Monoid c ⦄ → Monoid (a × b × c) - iMonoidTuple₃ = record{DefaultMonoid iDefaultMonoidTuple₃} - -open DefaultMonoid - -MonoidEndo : Monoid (a → a) -MonoidEndo = record {DefaultMonoid (λ where - .mempty → id - .super ._<>_ → _∘_)} - -MonoidEndoᵒᵖ : Monoid (a → a) -MonoidEndoᵒᵖ = record {DefaultMonoid (λ where - .mempty → id - .super ._<>_ → flip _∘_) } - -MonoidConj : Monoid Bool -MonoidConj = record {DefaultMonoid (λ where - .mempty → True - .super ._<>_ → _&&_)} - -MonoidDisj : Monoid Bool -MonoidDisj = record {DefaultMonoid (λ where - .mempty → False - .super ._<>_ → _||_)} diff --git a/lib/Haskell/Prim/Num.agda b/lib/Haskell/Prim/Num.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Num.agda +++ /dev/null @@ -1,120 +0,0 @@ -{-# OPTIONS --no-auto-inline #-} - -module Haskell.Prim.Num where - -open import Haskell.Prim -open import Haskell.Prim.Word -open import Haskell.Prim.Int -open import Haskell.Prim.Integer -open import Haskell.Prim.Double -open import Haskell.Prim.Eq -open import Haskell.Prim.Ord -open import Haskell.Prim.Monoid - --------------------------------------------------- --- Num - -record Num (a : Set) : Set₁ where - infixl 6 _+_ _-_ - infixl 7 _*_ - field - @0 MinusOK : a → a → Set - @0 NegateOK : a → Set - @0 FromIntegerOK : Integer → Set - _+_ : a → a → a - _-_ : (x y : a) → @0 ⦃ MinusOK x y ⦄ → a - _*_ : a → a → a - negate : (x : a) → @0 ⦃ NegateOK x ⦄ → a - abs : a → a - signum : a → a - fromInteger : (n : Integer) → @0 ⦃ FromIntegerOK n ⦄ → a - overlap ⦃ number ⦄ : Number a - overlap ⦃ numZero ⦄ : number .Number.Constraint 0 - overlap ⦃ numOne ⦄ : number .Number.Constraint 1 - -open Num ⦃...⦄ public hiding (FromIntegerOK; number) - -{-# COMPILE AGDA2HS Num existing-class #-} - -instance - iNumNat : Num Nat - iNumNat .MinusOK n m = IsFalse (ltNat n m) - iNumNat .NegateOK 0 = ⊤ - iNumNat .NegateOK (suc _) = ⊥ - iNumNat .Num.FromIntegerOK (negsuc _) = ⊥ - iNumNat .Num.FromIntegerOK (pos _) = ⊤ - iNumNat ._+_ n m = addNat n m - iNumNat ._-_ n m = monusNat n m - iNumNat ._*_ n m = mulNat n m - iNumNat .negate n = n - iNumNat .abs n = n - iNumNat .signum 0 = 0 - iNumNat .signum (suc n) = 1 - iNumNat .fromInteger (pos n) = n - iNumNat .fromInteger (negsuc _) ⦃ () ⦄ - - iNumInt : Num Int - iNumInt .MinusOK _ _ = ⊤ - iNumInt .NegateOK _ = ⊤ - iNumInt .Num.FromIntegerOK _ = ⊤ - iNumInt ._+_ x y = addInt x y - iNumInt ._-_ x y = subInt x y - iNumInt ._*_ x y = mulInt x y - iNumInt .negate x = negateInt x - iNumInt .abs x = absInt x - iNumInt .signum x = signInt x - iNumInt .fromInteger n = integerToInt n - - iNumInteger : Num Integer - iNumInteger .MinusOK _ _ = ⊤ - iNumInteger .NegateOK _ = ⊤ - iNumInteger .Num.FromIntegerOK _ = ⊤ - iNumInteger ._+_ x y = addInteger x y - iNumInteger ._-_ x y = subInteger x y - iNumInteger ._*_ x y = mulInteger x y - iNumInteger .negate x = negateInteger x - iNumInteger .abs x = absInteger x - iNumInteger .signum x = signInteger x - iNumInteger .fromInteger n = n - - iNumWord : Num Word - iNumWord .MinusOK _ _ = ⊤ - iNumWord .NegateOK _ = ⊤ - iNumWord .Num.FromIntegerOK _ = ⊤ - iNumWord ._+_ x y = addWord x y - iNumWord ._-_ x y = subWord x y - iNumWord ._*_ x y = mulWord x y - iNumWord .negate x = negateWord x - iNumWord .abs x = x - iNumWord .signum x = if x == 0 then 0 else 1 - iNumWord .fromInteger n = integerToWord n - - iNumDouble : Num Double - iNumDouble .MinusOK _ _ = ⊤ - iNumDouble .NegateOK _ = ⊤ - iNumDouble .Num.FromIntegerOK _ = ⊤ - iNumDouble ._+_ x y = primFloatPlus x y - iNumDouble ._-_ x y = primFloatMinus x y - iNumDouble ._*_ x y = primFloatTimes x y - iNumDouble .negate x = primFloatMinus 0.0 x - iNumDouble .abs x = if x < 0.0 then primFloatMinus 0.0 x else x - iNumDouble .signum x = case compare x 0.0 of λ where - LT → -1.0 - EQ → x - GT → 1.0 - iNumDouble .fromInteger (pos n) = fromNat n - iNumDouble .fromInteger (negsuc n) = fromNeg (suc n) - -open DefaultMonoid - -MonoidSum : ⦃ iNum : Num a ⦄ → Monoid a -MonoidSum = record {DefaultMonoid (λ where - .mempty → 0 - .super ._<>_ → _+_ - )} - -MonoidProduct : ⦃ iNum : Num a ⦄ → Monoid a -MonoidProduct = record {DefaultMonoid (λ where - .mempty → 1 - .super ._<>_ → _*_ - )} diff --git a/lib/Haskell/Prim/Ord.agda b/lib/Haskell/Prim/Ord.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Ord.agda +++ /dev/null @@ -1,234 +0,0 @@ - -module Haskell.Prim.Ord where - -open import Haskell.Prim -open import Haskell.Prim.Eq -open import Haskell.Prim.Bool -open import Haskell.Prim.Int -open import Haskell.Prim.Word -open import Haskell.Prim.Integer -open import Haskell.Prim.Double -open import Haskell.Prim.Tuple -open import Haskell.Prim.Monoid -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Either - --------------------------------------------------- --- Ordering - -data Ordering : Set where - LT EQ GT : Ordering - -instance - iEqOrdering : Eq Ordering - iEqOrdering ._==_ LT LT = True - iEqOrdering ._==_ EQ EQ = True - iEqOrdering ._==_ GT GT = True - iEqOrdering ._==_ _ _ = False - - iSemigroupOrdering : Semigroup Ordering - iSemigroupOrdering ._<>_ LT _ = LT - iSemigroupOrdering ._<>_ EQ o = o - iSemigroupOrdering ._<>_ GT _ = GT - - iMonoidOrdering : Monoid Ordering - iMonoidOrdering = record {DefaultMonoid (record {mempty = EQ})} - --------------------------------------------------- --- Ord - -record Ord (a : Set) : Set where - field - compare : a → a → Ordering - _<_ : a → a → Bool - _>_ : a → a → Bool - _>=_ : a → a → Bool - _<=_ : a → a → Bool - max : a → a → a - min : a → a → a - overlap ⦃ super ⦄ : Eq a - - infix 4 _<_ _>_ _<=_ _>=_ - -record OrdFromCompare (a : Set) : Set where - field - compare : a → a → Ordering - overlap ⦃ super ⦄ : Eq a - - _<_ : a → a → Bool - x < y = compare x y == LT - - _>_ : a → a → Bool - x > y = compare x y == GT - - _>=_ : a → a → Bool - x >= y = compare x y /= LT - - _<=_ : a → a → Bool - x <= y = compare x y /= GT - - max : a → a → a - max x y = if compare x y == LT then y else x - - min : a → a → a - min x y = if compare x y == GT then y else x - -record OrdFromLessThan (a : Set) : Set where - field - _<_ : a → a → Bool - overlap ⦃ super ⦄ : Eq a - - compare : a → a → Ordering - compare x y = if x < y then LT else if x == y then EQ else GT - - _>_ : a → a → Bool - x > y = y < x - - _>=_ : a → a → Bool - x >= y = y < x || x == y - - _<=_ : a → a → Bool - x <= y = x < y || x == y - - max : a → a → a - max x y = if x < y then y else x - - min : a → a → a - min x y = if y < x then y else x - - -open Ord ⦃...⦄ public - -{-# COMPILE AGDA2HS Ord existing-class #-} - -private - compareFromLt : ⦃ Eq a ⦄ → (a → a → Bool) → a → a → Ordering - compareFromLt _<_ x y = if x < y then LT else if x == y then EQ else GT - -private - maxNat : Nat → Nat → Nat - maxNat zero y = y - maxNat (suc x) zero = suc x - maxNat (suc x) (suc y) = suc (maxNat x y) - - minNat : Nat → Nat → Nat - minNat zero y = zero - minNat (suc x) zero = zero - minNat (suc x) (suc y) = suc (minNat x y) - -instance - iOrdFromLessThanNat : OrdFromLessThan Nat - iOrdFromLessThanNat .OrdFromLessThan._<_ = ltNat - - iOrdNat : Ord Nat - iOrdNat = record - { OrdFromLessThan iOrdFromLessThanNat - ; max = maxNat - ; min = minNat - } - - iOrdFromLessThanInteger : OrdFromLessThan Integer - iOrdFromLessThanInteger .OrdFromLessThan._<_ = ltInteger - - iOrdInteger : Ord Integer - iOrdInteger = record {OrdFromLessThan iOrdFromLessThanInteger} - - iOrdFromLessThanInt : OrdFromLessThan Int - iOrdFromLessThanInt .OrdFromLessThan._<_ = ltInt - - iOrdInt : Ord Int - iOrdInt = record {OrdFromLessThan iOrdFromLessThanInt} - - iOrdFromLessThanWord : OrdFromLessThan Word - iOrdFromLessThanWord .OrdFromLessThan._<_ = ltWord - - iOrdWord : Ord Word - iOrdWord = record {OrdFromLessThan iOrdFromLessThanWord} - - iOrdFromLessThanDouble : OrdFromLessThan Double - iOrdFromLessThanDouble .OrdFromLessThan._<_ = primFloatLess - - iOrdDouble : Ord Double - iOrdDouble = record {OrdFromLessThan iOrdFromLessThanDouble} - - iOrdFromLessThanChar : OrdFromLessThan Char - iOrdFromLessThanChar .OrdFromLessThan._<_ x y = c2n x < c2n y - - iOrdChar : Ord Char - iOrdChar = record {OrdFromLessThan iOrdFromLessThanChar} - - iOrdFromCompareBool : OrdFromCompare Bool - iOrdFromCompareBool .OrdFromCompare.compare = λ where - False True → LT - True False → GT - _ _ → EQ - - iOrdBool : Ord Bool - iOrdBool = record {OrdFromCompare iOrdFromCompareBool} - - iOrdFromCompareUnit : OrdFromCompare ⊤ - iOrdFromCompareUnit .OrdFromCompare.compare = λ _ _ → EQ - - iOrdUnit : Ord ⊤ - iOrdUnit = record {OrdFromCompare iOrdFromCompareUnit} - - iOrdFromCompareTuple₂ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → OrdFromCompare (a × b) - iOrdFromCompareTuple₂ .OrdFromCompare.compare = λ where - (x₁ , y₁) (x₂ , y₂) → compare x₁ x₂ <> compare y₁ y₂ - - iOrdTuple₂ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → Ord (a × b) - iOrdTuple₂ = record {OrdFromCompare iOrdFromCompareTuple₂} - - iOrdFromCompareTuple₃ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → ⦃ Ord c ⦄ → OrdFromCompare (a × b × c) - iOrdFromCompareTuple₃ .OrdFromCompare.compare = λ where - (x₁ , y₁ , z₁) (x₂ , y₂ , z₂) → compare x₁ x₂ <> compare y₁ y₂ <> compare z₁ z₂ - - iOrdTuple₃ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → ⦃ Ord c ⦄ → Ord (a × b × c) - iOrdTuple₃ = record {OrdFromCompare iOrdFromCompareTuple₃} - -compareList : ⦃ Ord a ⦄ → List a → List a → Ordering -compareList [] [] = EQ -compareList [] (_ ∷ _) = LT -compareList (_ ∷ _) [] = GT -compareList (x ∷ xs) (y ∷ ys) = compare x y <> compareList xs ys - -instance - iOrdFromCompareList : ⦃ Ord a ⦄ → OrdFromCompare (List a) - iOrdFromCompareList .OrdFromCompare.compare = compareList - - iOrdList : ⦃ Ord a ⦄ → Ord (List a) - iOrdList = record {OrdFromCompare iOrdFromCompareList} - - iOrdFromCompareMaybe : ⦃ Ord a ⦄ → OrdFromCompare (Maybe a) - iOrdFromCompareMaybe .OrdFromCompare.compare = λ where - Nothing Nothing → EQ - Nothing (Just _) → LT - (Just _) Nothing → GT - (Just x) (Just y) → compare x y - - iOrdMaybe : ⦃ Ord a ⦄ → Ord (Maybe a) - iOrdMaybe = record {OrdFromCompare iOrdFromCompareMaybe} - - iOrdFromCompareEither : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → OrdFromCompare (Either a b) - iOrdFromCompareEither .OrdFromCompare.compare = λ where - (Left x) (Left y) → compare x y - (Left _) (Right _) → LT - (Right _) (Left _) → GT - (Right x) (Right y) → compare x y - - iOrdEither : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → Ord (Either a b) - iOrdEither = record {OrdFromCompare iOrdFromCompareEither} - - iOrdFromCompareOrdering : OrdFromCompare Ordering - iOrdFromCompareOrdering .OrdFromCompare.compare = λ where - LT LT → EQ - LT _ → LT - _ LT → GT - EQ EQ → EQ - EQ GT → LT - GT EQ → GT - GT GT → EQ - - iOrdOrdering : Ord Ordering - iOrdOrdering = record {OrdFromCompare iOrdFromCompareOrdering} diff --git a/lib/Haskell/Prim/Show.agda b/lib/Haskell/Prim/Show.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Show.agda +++ /dev/null @@ -1,159 +0,0 @@ - -module Haskell.Prim.Show where - -open import Haskell.Prim -open import Haskell.Prim.String -open import Haskell.Prim.List -open import Haskell.Prim.Word -open import Haskell.Prim.Double -open import Haskell.Prim.Maybe -open import Haskell.Prim.Eq -open import Haskell.Prim.Tuple -open import Haskell.Prim.Ord -open import Haskell.Prim.Either -open import Haskell.Prim.Integer -open import Haskell.Prim.Bool -open import Haskell.Prim.Int -open import Haskell.Prim.Foldable - - --------------------------------------------------- --- Show - -ShowS : Set -ShowS = String → String - -showChar : Char → ShowS -showChar = _∷_ - -showString : String → ShowS -showString = _++_ - -showParen : Bool → ShowS → ShowS -showParen False s = s -showParen True s = showString "(" ∘ s ∘ showString ")" - -defaultShowList : (a → ShowS) → List a → ShowS -defaultShowList shows = λ where - [] → showString "[]" - (x ∷ xs) → showString "[" - ∘ foldl (λ s x → s ∘ showString "," ∘ shows x) (shows x) xs - ∘ showString "]" - --- ** base -record Show (a : Set) : Set where - field - showsPrec : Int → a → ShowS - showList : List a → ShowS - show : a → String --- ** export -record Show₁ (a : Set) : Set where - field showsPrec : Int → a → ShowS - - show : a → String - show x = showsPrec 0 x "" - - showList : List a → ShowS - showList = defaultShowList (showsPrec 0) -record Show₂ (a : Set) : Set where - field show : a → String - - showsPrec : Int → a → ShowS - showsPrec _ x s = show x ++ s - - showList : List a → ShowS - showList = defaultShowList (showsPrec 0) --- ** export -open Show ⦃...⦄ public - -shows : ⦃ Show a ⦄ → a → ShowS -shows = showsPrec 0 - -{-# COMPILE AGDA2HS Show existing-class #-} - --- ** instances -instance - iShow₂Nat : Show₂ Nat - iShow₂Nat .Show₂.show = primStringToList ∘ primShowNat - - iShowNat : Show Nat - iShowNat = record {Show₂ iShow₂Nat} - - iShow₂Integer : Show₂ Integer - iShow₂Integer .Show₂.show = showInteger - - iShowInteger : Show Integer - iShowInteger = record {Show₂ iShow₂Integer} - - iShow₂Int : Show₂ Int - iShow₂Int .Show₂.show = showInt - - iShowInt : Show Int - iShowInt = record{Show₂ iShow₂Int} - - iShow₂Word : Show₂ Word - iShow₂Word .Show₂.show = showWord - - iShowWord : Show Word - iShowWord = record{Show₂ iShow₂Word} - - iShow₂Double : Show₂ Double - iShow₂Double .Show₂.show = primStringToList ∘ primShowFloat - - iShowDouble : Show Double - iShowDouble = record{Show₂ iShow₂Double} - - iShow₂Bool : Show₂ Bool - iShow₂Bool .Show₂.show = λ where False → "False"; True → "True" - - iShowBool : Show Bool - iShowBool = record{Show₂ iShow₂Bool} - - iShow₁Char : Show₁ Char - iShow₁Char .Show₁.showsPrec _ = showString ∘ primStringToList ∘ primShowChar - - iShowChar : Show Char - iShowChar = record{Show₁ iShow₁Char} - - iShow₁List : ⦃ Show a ⦄ → Show₁ (List a) - iShow₁List .Show₁.showsPrec _ = showList - - iShowList : ⦃ Show a ⦄ → Show (List a) - iShowList = record{Show₁ iShow₁List} - -private - showApp₁ : ⦃ Show a ⦄ → Int → String → a → ShowS - showApp₁ p tag x = showParen (p > 10) $ - showString tag ∘ showString " " ∘ showsPrec 11 x - -instance - iShow₁Maybe : ⦃ Show a ⦄ → Show₁ (Maybe a) - iShow₁Maybe .Show₁.showsPrec = λ where - p Nothing → showString "Nothing" - p (Just x) → showApp₁ p "Just" x - - iShowMaybe : ⦃ Show a ⦄ → Show (Maybe a) - iShowMaybe = record{Show₁ iShow₁Maybe} - - iShow₁Either : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show₁ (Either a b) - iShow₁Either .Show₁.showsPrec = λ where - p (Left x) → showApp₁ p "Left" x - p (Right y) → showApp₁ p "Right" y - - iShowEither : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show (Either a b) - iShowEither = record{Show₁ iShow₁Either} - -instance - iShow₁Tuple₂ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show₁ (a × b) - iShow₁Tuple₂ .Show₁.showsPrec = λ _ → λ where - (x , y) → showString "(" ∘ shows x ∘ showString ", " ∘ shows y ∘ showString ")" - - iShowTuple₂ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show (a × b) - iShowTuple₂ = record{Show₁ iShow₁Tuple₂} - - iShow₁Tuple₃ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → ⦃ Show c ⦄ → Show₁ (a × b × c) - iShow₁Tuple₃ .Show₁.showsPrec = λ _ → λ where - (x , y , z) → showString "(" ∘ shows x ∘ showString ", " ∘ shows y ∘ showString ", " ∘ shows z ∘ showString ")" - - iShowTuple₃ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → ⦃ Show c ⦄ → Show (a × b × c) - iShowTuple₃ = record{Show₁ iShow₁Tuple₃} diff --git a/lib/Haskell/Prim/Strict.agda b/lib/Haskell/Prim/Strict.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Strict.agda +++ /dev/null @@ -1,12 +0,0 @@ - -module Haskell.Prim.Strict where - -open import Haskell.Prim - -record Strict (a : Set ℓ) : Set ℓ where - constructor !_ - field - force : a -open Strict public - -{-# COMPILE AGDA2HS Strict unboxed-strict #-} diff --git a/lib/Haskell/Prim/String.agda b/lib/Haskell/Prim/String.agda deleted file mode 100644 --- a/lib/Haskell/Prim/String.agda +++ /dev/null @@ -1,52 +0,0 @@ - -module Haskell.Prim.String where - -open import Haskell.Prim -open import Haskell.Prim.List -open import Haskell.Prim.Foldable - --------------------------------------------------- --- String --- This is _not_ the builtin String type of Agda --- which is defined by postulates. --- `fromString` can be used to convert back --- to builtin Agda strings. - -String = List Char - -instance - iIsStringString : IsString String - iIsStringString .IsString.Constraint _ = ⊤ - iIsStringString .fromString s = primStringToList s - -private - cons : Char → List String → List String - cons c [] = (c ∷ []) ∷ [] - cons c (s ∷ ss) = (c ∷ s) ∷ ss - -lines : String → List String -lines [] = [] -lines ('\n' ∷ s) = [] ∷ lines s -lines (c ∷ s) = cons c (lines s) - -private - mutual - space : String → List String - space [] = [] - space (c ∷ s) = if primIsSpace c then space s else cons c (word s) - - word : String → List String - word [] = [] - word (c ∷ s) = if primIsSpace c then [] ∷ space s else cons c (word s) - -words : String → List String -words [] = [] -words s@(c ∷ s₁) = if primIsSpace c then space s₁ else word s - -unlines : List String → String -unlines = concatMap (_++ "\n") - -unwords : List String → String -unwords [] = "" -unwords (w ∷ []) = w -unwords (w ∷ ws) = w ++ ' ' ∷ unwords ws diff --git a/lib/Haskell/Prim/Thunk.agda b/lib/Haskell/Prim/Thunk.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Thunk.agda +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS --sized-types #-} - -module Haskell.Prim.Thunk where - -open import Agda.Builtin.Size public - -open import Haskell.Prim - -record Thunk {ℓ} (a : @0 Size → Set ℓ) (@0 i : Size) : Set ℓ where - constructor delay - coinductive - field force : {@0 j : Size< i} → a j -open Thunk public - -{-# COMPILE AGDA2HS Thunk unboxed #-} diff --git a/lib/Haskell/Prim/Traversable.agda b/lib/Haskell/Prim/Traversable.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Traversable.agda +++ /dev/null @@ -1,78 +0,0 @@ - - -module Haskell.Prim.Traversable where - -open import Haskell.Prim -open import Haskell.Prim.Applicative -open import Haskell.Prim.Functor -open import Haskell.Prim.Foldable -open import Haskell.Prim.Monad -open import Haskell.Prim.List -open import Haskell.Prim.Maybe -open import Haskell.Prim.Either -open import Haskell.Prim.Tuple - --------------------------------------------------- --- Traversable - --- ** base -record Traversable (t : Set → Set) : Set₁ where - field - traverse : ⦃ Applicative f ⦄ → (a → f b) → t a → f (t b) - overlap ⦃ functor ⦄ : Functor t - overlap ⦃ foldable ⦄ : Foldable t - - sequenceA : ⦃ Applicative f ⦄ → t (f a) → f (t a) - mapM : ⦃ Monad m ⦄ → (a → m b) → t a → m (t b) - sequence : ⦃ Monad m ⦄ → t (m a) → m (t a) --- ** defaults -record DefaultTraversable (t : Set → Set) : Set₁ where - field - traverse : ⦃ Applicative f ⦄ → (a → f b) → t a → f (t b) - overlap ⦃ functor ⦄ : Functor t - overlap ⦃ foldable ⦄ : Foldable t - - sequenceA : ⦃ Applicative f ⦄ → t (f a) → f (t a) - sequenceA = traverse id - - mapM : ⦃ Monad m ⦄ → (a → m b) → t a → m (t b) - mapM = traverse - - sequence : ⦃ Monad m ⦄ → t (m a) → m (t a) - sequence = sequenceA --- ** export -open Traversable ⦃...⦄ public -{-# COMPILE AGDA2HS Traversable existing-class #-} --- ** instances -private - mkTraversable : DefaultTraversable t → Traversable t - mkTraversable x = record {DefaultTraversable x} - - infix 0 traverse=_ - traverse=_ : ⦃ Functor t ⦄ → ⦃ Foldable t ⦄ - → (∀ {f a b} → ⦃ Applicative f ⦄ → (a → f b) → t a → f (t b)) - → Traversable t - traverse= x = record {DefaultTraversable (record {traverse = x})} -instance - open DefaultTraversable - - iTraversableList : Traversable List - iTraversableList = traverse= traverseList - where - traverseList : ⦃ Applicative f ⦄ → (a → f b) → List a → f (List b) - traverseList f [] = pure [] - traverseList f (x ∷ xs) = ⦇ f x ∷ traverseList f xs ⦈ - - iTraversableMaybe : Traversable Maybe - iTraversableMaybe = traverse= λ where - f Nothing → pure Nothing - f (Just x) → Just <$> f x - - iTraversableEither : Traversable (Either a) - iTraversableEither = traverse= λ where - f (Left x) → pure (Left x) - f (Right y) → Right <$> f y - - iTraversablePair : Traversable (a ×_) - iTraversablePair = traverse= λ - f (x , y) → (x ,_) <$> f y diff --git a/lib/Haskell/Prim/Tuple.agda b/lib/Haskell/Prim/Tuple.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Tuple.agda +++ /dev/null @@ -1,45 +0,0 @@ - -module Haskell.Prim.Tuple where - -open import Haskell.Prim - --------------------------------------------------- --- Tuples - -infix 3 _×_ _×_×_ - -infix -1 _,_ _,_,_ - -record _×_ (a b : Set) : Set where - constructor _,_ - field - fst : a - snd : b -open _×_ public - -{-# COMPILE AGDA2HS _×_ tuple #-} - -record _×_×_ (a b c : Set) : Set where - no-eta-equality; pattern - constructor _,_,_ - field - fst3 : a - snd3 : b - thd3 : c - -{-# COMPILE AGDA2HS _×_×_ tuple #-} - -uncurry : (a → b → c) → a × b → c -uncurry f (x , y) = f x y - -curry : (a × b → c) → a → b → c -curry f x y = f (x , y) - -first : (a → b) → a × c → b × c -first f (x , y) = f x , y - -second : (a → b) → c × a → c × b -second f (x , y) = x , f y - -_***_ : (a → b) → (c → d) → a × c → b × d -(f *** g) (x , y) = f x , g y diff --git a/lib/Haskell/Prim/Word.agda b/lib/Haskell/Prim/Word.agda deleted file mode 100644 --- a/lib/Haskell/Prim/Word.agda +++ /dev/null @@ -1,54 +0,0 @@ - -module Haskell.Prim.Word where - -open import Haskell.Prim -open import Haskell.Prim.Integer - -import Agda.Builtin.Word renaming (Word64 to Word) -open Agda.Builtin.Word public using (Word) - - --------------------------------------------------- --- Literals - -module WordInternal where - 2⁶⁴ : Nat - 2⁶⁴ = 18446744073709551616 -open WordInternal - -instance - iNumberWord : Number Word - iNumberWord .Number.Constraint n = IsTrue (ltNat n 2⁶⁴) - iNumberWord .fromNat n = n2w n - - --------------------------------------------------- --- Arithmetic - -negateWord : Word → Word -negateWord a = n2w (monusNat 2⁶⁴ (w2n a)) - -addWord : Word → Word → Word -addWord a b = n2w (addNat (w2n a) (w2n b)) - -subWord : Word → Word → Word -subWord a b = addWord a (negateWord b) - -mulWord : Word → Word → Word -mulWord a b = n2w (mulNat (w2n a) (w2n b)) - -eqWord : Word → Word → Bool -eqWord a b = eqNat (w2n a) (w2n b) - -ltWord : Word → Word → Bool -ltWord a b = ltNat (w2n a) (w2n b) - -showWord : Word → List Char -showWord a = primStringToList (primShowNat (w2n a)) - -integerToWord : Integer → Word -integerToWord (pos n) = n2w n -integerToWord (negsuc n) = negateWord (n2w (suc n)) - -wordToInteger : Word → Integer -wordToInteger n = pos (w2n n) diff --git a/lib/base/Haskell/Control/Exception.agda b/lib/base/Haskell/Control/Exception.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Control/Exception.agda @@ -0,0 +1,11 @@ +module Haskell.Control.Exception where + +open import Haskell.Prim + +open import Haskell.Extra.Dec +open import Haskell.Extra.Refinement + +assert : (@0 b : Type ℓ) → {{Dec b}} → (@0 {{b}} → a) → a +assert _ {{True ⟨ p ⟩}} x = x {{p}} +assert _ {{False ⟨ _ ⟩}} x = oops + where postulate oops : _ diff --git a/lib/base/Haskell/Control/Monad.agda b/lib/base/Haskell/Control/Monad.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Control/Monad.agda @@ -0,0 +1,11 @@ +module Haskell.Control.Monad where + +open import Haskell.Prim +open import Haskell.Prim.Bool +open import Haskell.Prim.Monad +open import Haskell.Prim.String +open import Haskell.Extra.Erase + +guard : {{ MonadFail m }} → (b : Bool) → m (Erase (b ≡ True)) +guard True = return (Erased refl) +guard False = fail "Guard was not True" diff --git a/lib/base/Haskell/Data/List.agda b/lib/base/Haskell/Data/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Data/List.agda @@ -0,0 +1,90 @@ +module Haskell.Data.List where + +open import Haskell.Prelude + +open import Haskell.Data.Ord using (comparing) + +open import Haskell.Law.Eq +open import Haskell.Law.Equality + +{----------------------------------------------------------------------------- + Operations +------------------------------------------------------------------------------} + +partition : (a → Bool) → List a → (List a × List a) +partition p xs = (filter p xs , filter (not ∘ p) xs) + +-- | Delete all occurrences of an item. +-- Not part of 'Data.List'. +deleteAll : ⦃ _ : Eq a ⦄ → @0 ⦃ IsLawfulEq a ⦄ → a → List a → List a +deleteAll x = filter (not ∘ (x ==_)) + +-- | These semantics of 'nub' assume that the 'Eq' instance +-- is lawful. +-- These semantics are inefficient, but good for proofs. +nub : ⦃ _ : Eq a ⦄ → @0 ⦃ IsLawfulEq a ⦄ → List a → List a +nub [] = [] +nub (x ∷ xs) = x ∷ deleteAll x (nub xs) + +postulate + sortBy : (a → a → Ordering) → List a → List a + +sort : ⦃ Ord a ⦄ → List a → List a +sort = sortBy compare + +sortOn : ⦃ Ord b ⦄ → (a → b) → List a → List a +sortOn f = + map snd + ∘ sortBy (comparing fst) + ∘ map (λ x → let y = f x in seq y (y , x)) + +{----------------------------------------------------------------------------- + Properties +------------------------------------------------------------------------------} + +-- | A deleted item is no longer an element. +-- +prop-elem-deleteAll + : ∀ ⦃ _ : Eq a ⦄ ⦃ _ : IsLawfulEq a ⦄ + (x y : a) (zs : List a) + → elem x (deleteAll y zs) + ≡ (if x == y then False else elem x zs) +-- +prop-elem-deleteAll x y [] + with x == y +... | False = refl +... | True = refl +prop-elem-deleteAll x y (z ∷ zs) + with recurse ← prop-elem-deleteAll x y zs + with y == z in eqyz +... | True + with x == z in eqxz +... | True + rewrite equality' _ _ (trans (equality x z eqxz) (sym (equality y z eqyz))) + = recurse +... | False + = recurse +prop-elem-deleteAll x y (z ∷ zs) + | False + with x == z in eqxz +... | True + rewrite equality x z eqxz | eqSymmetry y z | eqyz + = refl +... | False + = recurse + +-- | An item is an element of the 'nub' iff it is +-- an element of the original list. +-- +prop-elem-nub + : ∀ ⦃ _ : Eq a ⦄ ⦃ _ : IsLawfulEq a ⦄ + (x : a) (ys : List a) + → elem x (nub ys) + ≡ elem x ys +-- +prop-elem-nub x [] = refl +prop-elem-nub x (y ∷ ys) + rewrite prop-elem-deleteAll x y (nub ys) + with x == y +... | True = refl +... | False = prop-elem-nub x ys diff --git a/lib/base/Haskell/Data/Maybe.agda b/lib/base/Haskell/Data/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Data/Maybe.agda @@ -0,0 +1,34 @@ +module Haskell.Data.Maybe where + +open import Haskell.Prelude + +isJust : Maybe a → Bool +isJust Nothing = False +isJust (Just _) = True + +isNothing : Maybe a → Bool +isNothing Nothing = True +isNothing (Just _) = False + +fromJust : (x : Maybe a) → @0 {IsJust x} → a +fromJust Nothing = error "fromJust Nothing" +fromJust (Just x) = x + +fromMaybe : {a : Type} → a → Maybe a → a +fromMaybe d Nothing = d +fromMaybe _ (Just x) = x + +listToMaybe : List a → Maybe a +listToMaybe [] = Nothing +listToMaybe (x ∷ _) = Just x + +maybeToList : Maybe a → List a +maybeToList Nothing = [] +maybeToList (Just x) = x ∷ [] + +mapMaybe : (a → Maybe b) → List a → List b +mapMaybe f [] = [] +mapMaybe f (x ∷ xs) = maybe id _∷_ (f x) (mapMaybe f xs) + +catMaybes : List (Maybe a) → List a +catMaybes = mapMaybe id diff --git a/lib/base/Haskell/Data/Ord.agda b/lib/base/Haskell/Data/Ord.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Data/Ord.agda @@ -0,0 +1,9 @@ +module Haskell.Data.Ord where + +open import Haskell.Prelude + +comparing : ⦃ Ord a ⦄ → (b → a) → b → b → Ordering +comparing p x y = compare (p x) (p y) + +clamp : ⦃ Ord a ⦄ → (a × a) → a → a +clamp (low , high) a = min high (max a low) diff --git a/lib/base/Haskell/Extra/Dec.agda b/lib/base/Haskell/Extra/Dec.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Extra/Dec.agda @@ -0,0 +1,65 @@ +module Haskell.Extra.Dec where + +open import Haskell.Prelude +open import Haskell.Extra.Refinement +open import Agda.Primitive + +private variable + ℓ : Level + P : Type + +@0 Reflects : Type ℓ → Bool → Type ℓ +Reflects P True = P +Reflects P False = P → ⊥ + +of : {b : Bool} → if b then P else (P → ⊥) → Reflects P b +of {b = False} np = np +of {b = True} p = p + +invert : ∀ {b} → Reflects P b → if b then P else (P → ⊥) +invert {b = False} np = np +invert {b = True} p = p + +extractTrue : ∀ { b } → ⦃ true : b ≡ True ⦄ → Reflects P b → P +extractTrue {b = True} p = p + +extractFalse : ∀ { b } → ⦃ true : b ≡ False ⦄ → Reflects P b → (P → ⊥) +extractFalse {b = False} np = np + +mapReflects : ∀ {cond} → (a → b) → (b → a) + → Reflects a cond → Reflects b cond +mapReflects {cond = False} f g x = x ∘ g +mapReflects {cond = True} f g x = f x + +Dec : ∀ {ℓ} → @0 Type ℓ → Type ℓ +Dec P = ∃ Bool (Reflects P) +{-# COMPILE AGDA2HS Dec inline #-} + +mapDec : {@0 a b : Type} + → @0 (a → b) + → @0 (b → a) + → Dec a → Dec b +mapDec f g (True ⟨ x ⟩) = True ⟨ f x ⟩ +mapDec f g (False ⟨ h ⟩) = False ⟨ h ∘ g ⟩ +{-# COMPILE AGDA2HS mapDec transparent #-} + +ifDec : Dec a → (@0 {{a}} → b) → (@0 {{a → ⊥}} → b) → b +ifDec (b ⟨ p ⟩) x y = if b then (λ where {{refl}} → x {{p}}) else (λ where {{refl}} → y {{p}}) +{-# COMPILE AGDA2HS ifDec inline #-} + +instance + iDecIsTrue : {b : Bool} → Dec (IsTrue b) + iDecIsTrue {False} = False ⟨ (λ ()) ⟩ + iDecIsTrue {True} = True ⟨ IsTrue.itsTrue ⟩ + {-# COMPILE AGDA2HS iDecIsTrue transparent #-} + + iDecIsFalse : {b : Bool} → Dec (IsFalse b) + iDecIsFalse {b} = mapDec isTrueNotIsFalse isFalseIsTrueNot (iDecIsTrue {not b}) + where + @0 isTrueNotIsFalse : {b : Bool} → IsTrue (not b) → IsFalse b + isTrueNotIsFalse {False} IsTrue.itsTrue = IsFalse.itsFalse + + @0 isFalseIsTrueNot : {b : Bool} → IsFalse b → IsTrue (not b) + isFalseIsTrueNot {False} IsFalse.itsFalse = IsTrue.itsTrue + {-# COMPILE AGDA2HS iDecIsFalse inline #-} + diff --git a/lib/base/Haskell/Extra/Delay.agda b/lib/base/Haskell/Extra/Delay.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Extra/Delay.agda @@ -0,0 +1,41 @@ +{-# OPTIONS --sized-types #-} + +module Haskell.Extra.Delay where + +open import Agda.Builtin.Size public + +open import Haskell.Prelude + +open import Haskell.Data.Maybe +open import Haskell.Extra.Refinement +open import Haskell.Prim.Thunk + +private variable + x y z : a + @0 i : Size + +data Delay (a : Type) (@0 i : Size) : Type where + now : a → Delay a i + later : Thunk (Delay a) i → Delay a i + +data HasResult (x : a) : Delay a i → Type where + now : HasResult x (now x) + later : HasResult x (y .force) → HasResult x (later y) + +runDelay : {@0 x : a} (y : Delay a ∞) → @0 HasResult x y → a +runDelay (now x) now = x +runDelay (later y) (later p) = runDelay (y .force) p + +runDelaySound : {@0 x : a} (y : Delay a ∞) → (@0 hr : HasResult x y) → runDelay y hr ≡ x +runDelaySound (now x) now = refl +runDelaySound (later y) (later hr) = runDelaySound (y .force) hr + +-- tryDelay and unDelay cannot and should not be compiled to Haskell, +-- so they are marked as erased. +@0 tryDelay : (y : Delay a ∞) → Nat → Maybe (∃ a (λ x → HasResult x y)) +tryDelay (now x) _ = Just (x ⟨ now ⟩) +tryDelay (later y) zero = Nothing +tryDelay (later y) (suc n) = fmap (mapRefine later) (tryDelay (y .force) n) + +@0 unDelay : (y : Delay a ∞) (n : Nat) → @0 {IsJust (tryDelay y n)} → a +unDelay y n {p} = fromJust (tryDelay y n) {p} .value diff --git a/lib/base/Haskell/Extra/Erase.agda b/lib/base/Haskell/Extra/Erase.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Extra/Erase.agda @@ -0,0 +1,82 @@ +module Haskell.Extra.Erase where + + open import Agda.Primitive + open import Agda.Builtin.Sigma + open import Agda.Builtin.Equality + + open import Haskell.Prim + open import Haskell.Prim.List + open import Haskell.Extra.Refinement + open import Haskell.Law.Equality + + private variable + @0 x y : a + @0 xs : List a + + record Erase (@0 a : Type ℓ) : Type ℓ where + instance constructor iErased + field @0 {{get}} : a + open Erase public + {-# COMPILE AGDA2HS Erase tuple #-} + + pattern Erased x = iErased {{x}} + + infixr 4 ⟨_⟩_ + record Σ0 (@0 a : Type) (b : @0 a → Type) : Type where + constructor ⟨_⟩_ + field + @0 proj₁ : a + proj₂ : b proj₁ + open Σ0 public + {-# COMPILE AGDA2HS Σ0 unboxed #-} + + pattern <_> x = record { proj₁ = _ ; proj₂ = x } + + -- Resurrection of erased values + Singleton : (@0 x : a) → Type + Singleton x = ∃ _ (x ≡_) + + {-# COMPILE AGDA2HS Singleton inline #-} + + pattern sing x = x ⟨ refl ⟩ + + instance + sing-id : {x : a} → Singleton x + sing-id = sing _ + {-# COMPILE AGDA2HS sing-id inline #-} + + singCong : {@0 a : Type} {@0 x : a} (f : a → b) → Singleton x → Singleton (f x) + singCong f (x ⟨ p ⟩) = f x ⟨ cong f p ⟩ + {-# COMPILE AGDA2HS singCong inline #-} + + singCong2 : (f : a → b → c) → Singleton x → Singleton y → Singleton (f x y) + singCong2 f (x ⟨ p ⟩) (y ⟨ q ⟩) = f x y ⟨ cong₂ f p q ⟩ + {-# COMPILE AGDA2HS singCong2 inline #-} + + singHead : Singleton (x ∷ xs) → Singleton x + singHead {x = x} (ys ⟨ p ⟩) = + head ys + ⟨ subst (λ ys → ⦃ @0 _ : NonEmpty ys ⦄ → x ≡ head ys) + p refl ⟩ + where instance @0 ne : NonEmpty ys + ne = subst NonEmpty p itsNonEmpty + {-# COMPILE AGDA2HS singHead inline #-} + + singTail : Singleton (x ∷ xs) → Singleton xs + singTail {xs = xs} (ys ⟨ p ⟩) = + tail ys + ⟨ subst (λ ys → ⦃ @0 _ : NonEmpty ys ⦄ → xs ≡ tail ys) + p refl ⟩ + where instance @0 ne : NonEmpty ys + ne = subst NonEmpty p itsNonEmpty + {-# COMPILE AGDA2HS singTail inline #-} + + singErase : {@0 a : Type} {@0 x : a} → Singleton (Erased x) + singErase {x = x} = Erased x ⟨ refl ⟩ + {-# COMPILE AGDA2HS singErase inline #-} + + erase-injective : Erased x ≡ Erased y → x ≡ y + erase-injective refl = refl + + inspect_by_ : (x : a) → (Singleton x → b) → b + inspect x by f = f (sing x) diff --git a/lib/base/Haskell/Extra/Refinement.agda b/lib/base/Haskell/Extra/Refinement.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Extra/Refinement.agda @@ -0,0 +1,28 @@ +module Haskell.Extra.Refinement where + +open import Haskell.Prelude +open import Agda.Primitive + +private variable + ℓ ℓ′ : Level + +record ∃ (a : Type ℓ) (@0 P : a → Type ℓ′) : Type (ℓ ⊔ ℓ′) where + constructor _⟨_⟩ + field + value : a + @0 proof : P value +open ∃ public +{-# COMPILE AGDA2HS ∃ unboxed #-} + +mapRefine : {@0 P Q : a → Type ℓ} (@0 f : ∀ {x} → P x → Q x) → ∃ a P → ∃ a Q +mapRefine f (x ⟨ p ⟩) = x ⟨ f p ⟩ + +{-# COMPILE AGDA2HS mapRefine transparent #-} + +refineMaybe : {@0 P : a → Type ℓ} + → (mx : Maybe a) → @0 (∀ {x} → mx ≡ Just x → P x) + → Maybe (∃ a P) +refineMaybe Nothing f = Nothing +refineMaybe (Just x) f = Just (x ⟨ f refl ⟩) + +{-# COMPILE AGDA2HS refineMaybe transparent #-} diff --git a/lib/base/Haskell/Extra/Sigma.agda b/lib/base/Haskell/Extra/Sigma.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Extra/Sigma.agda @@ -0,0 +1,19 @@ +module Haskell.Extra.Sigma where + +open import Haskell.Prelude + +record Σ (a : Type) (b : @0 a → Type) : Type where + constructor _,_ + field + fst : a + snd : b fst +open Σ public +{-# COMPILE AGDA2HS Σ tuple #-} + +infix 2 Σ-syntax + +Σ-syntax : (a : Type) → (@0 a → Type) → Type +Σ-syntax = Σ +{-# COMPILE AGDA2HS Σ-syntax inline #-} + +syntax Σ-syntax a (λ x → b) = Σ[ x ∈ a ] b diff --git a/lib/base/Haskell/Law.agda b/lib/base/Haskell/Law.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law.agda @@ -0,0 +1,20 @@ +module Haskell.Law where + +open import Haskell.Prim +open import Haskell.Prim.Bool + +open import Haskell.Law.Def public +open import Haskell.Law.Applicative public +open import Haskell.Law.Bool public +open import Haskell.Law.Either public +open import Haskell.Law.Eq public +open import Haskell.Law.Equality public +open import Haskell.Law.Functor public +open import Haskell.Law.Int public +open import Haskell.Law.Integer public +open import Haskell.Law.List public +open import Haskell.Law.Maybe public +open import Haskell.Law.Monad public +open import Haskell.Law.Monoid public +open import Haskell.Law.Nat public +open import Haskell.Law.Ord public diff --git a/lib/base/Haskell/Law/Applicative.agda b/lib/base/Haskell/Law/Applicative.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Applicative.agda @@ -0,0 +1,7 @@ +module Haskell.Law.Applicative where + +open import Haskell.Law.Applicative.Def public +open import Haskell.Law.Applicative.Either public +open import Haskell.Law.Applicative.IO public +open import Haskell.Law.Applicative.List public +open import Haskell.Law.Applicative.Maybe public diff --git a/lib/base/Haskell/Law/Applicative/Def.agda b/lib/base/Haskell/Law/Applicative/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Applicative/Def.agda @@ -0,0 +1,41 @@ +module Haskell.Law.Applicative.Def where + +open import Haskell.Prim +open import Haskell.Prim.Functor + +open import Haskell.Prim.Applicative +open import Haskell.Prim.Monoid +open import Haskell.Prim.Tuple + +open import Haskell.Law.Functor + +record IsLawfulApplicative (F : Type → Type) ⦃ iAppF : Applicative F ⦄ : Type₁ where + field + overlap ⦃ super ⦄ : IsLawfulFunctor F + + -- Identity: pure id <*> v = v + identity : (v : F a) → (pure id <*> v) ≡ v + + -- Composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w) + composition : {a b c : Type} → (u : F (b → c)) (v : F (a → b)) (w : F a) + → (pure _∘_ <*> u <*> v <*> w) ≡ (u <*> (v <*> w)) + + -- Homomorphism: pure f <*> pure x = pure (f x) + homomorphism : {a b : Type} → (f : a → b) (x : a) + → (Applicative._<*>_ iAppF (pure f) (pure x)) ≡ (pure (f x)) + + -- Interchange: u <*> pure y = pure ($ y) <*> u + interchange : {a b : Type} → (u : F (a → b)) (y : a) + → (u <*> (pure y)) ≡ (pure (_$ y) <*> u) + + -- fmap f x = pure f <*> x + functor : (f : a → b) (x : F a) → (fmap f x) ≡ ((pure f) <*> x) + +open IsLawfulApplicative ⦃ ... ⦄ public + +instance postulate + iLawfulApplicativeFun : IsLawfulApplicative (λ b → a → b) + + iLawfulApplicativeTuple₂ : ⦃ Monoid a ⦄ → Applicative (a ×_) + + iLawfulApplicativeTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Applicative (a × b ×_) diff --git a/lib/base/Haskell/Law/Applicative/Either.agda b/lib/base/Haskell/Law/Applicative/Either.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Applicative/Either.agda @@ -0,0 +1,29 @@ +module Haskell.Law.Applicative.Either where + +open import Haskell.Prim +open import Haskell.Prim.Either + +open import Haskell.Prim.Applicative + +open import Haskell.Law.Applicative.Def + +open import Haskell.Law.Functor.Either + +instance + iLawfulApplicativeEither : IsLawfulApplicative (Either a) + -- (λ { true → true ; false → false }) + + iLawfulApplicativeEither .identity = λ { (Left _) → refl; (Right _) → refl } + + iLawfulApplicativeEither .composition = + λ { (Left _) _ _ → refl + ; (Right _) (Left _) _ → refl + ; (Right _) (Right _) (Left _) → refl + ; (Right _) (Right _) (Right _) → refl + } + + iLawfulApplicativeEither .homomorphism _ _ = refl + + iLawfulApplicativeEither .interchange = λ { (Left _) _ → refl; (Right _) _ → refl } + + iLawfulApplicativeEither .functor = λ { _ (Left _) → refl; _ (Right _) → refl } diff --git a/lib/base/Haskell/Law/Applicative/FromMonad.agda b/lib/base/Haskell/Law/Applicative/FromMonad.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Applicative/FromMonad.agda @@ -0,0 +1,129 @@ +module Haskell.Law.Applicative.FromMonad where + +open import Haskell.Prim + +open import Haskell.Prim.Applicative +open import Haskell.Prim.Functor +open import Haskell.Prim.Monad + +open import Haskell.Law.Applicative.Def +open import Haskell.Law.Monad.Def as Monad +open import Haskell.Law.Equality +open import Haskell.Law.Functor +open import Haskell.Law.Functor.FromMonad + +------------------------------------------------------------------------------- +-- Prove the Applicative laws from the Monad laws + +-- +prop-PreLawfulMonad→IsLawfulApplicative + : ∀ ⦃ _ : Monad m ⦄ ⦃ _ : PreLawfulMonad m ⦄ + → IsLawfulApplicative m +-- +prop-PreLawfulMonad→IsLawfulApplicative {m} = record + { super = prop-PreLawfulMonad→IsLawfulFunctor + ; identity = midentity + ; composition = mcomposition + ; homomorphism = mhomomorphism + ; interchange = minterchange + ; functor = mfunctor + } + where + midentity : ∀ {a} (ma : m a) → (pure id <*> ma) ≡ ma + midentity {a} ma + rewrite def-pure-return (id {a}) + | def-<*>->>= (return id) ma + = begin + return id >>= (λ f → ma >>= (λ x → return (f x))) + ≡⟨ Monad.leftIdentity _ _ ⟩ + ma >>= (λ x → return (id x)) + ≡⟨ Monad.rightIdentity _ ⟩ + ma + ∎ + + mfunctor : ∀ {a b} (f : a → b) (u : m a) → fmap f u ≡ (pure f <*> u) + mfunctor f u = begin + fmap f u + ≡⟨ Monad.def-fmap->>= _ _ ⟩ + (do x ← u; return (f x)) + ≡⟨ sym (Monad.leftIdentity _ _) ⟩ + (do f' ← return f; x ← u; return (f' x)) + ≡⟨ cong (λ o → o >>= _) (sym (def-pure-return _)) ⟩ + (do f' ← pure f; x ← u; return (f' x)) + ≡⟨ sym (def-<*>->>= _ _) ⟩ + pure f <*> u + ∎ + + mcomposition + : ∀ {a b c} (u : m (b → c)) (v : m (a → b)) (w : m a) + → (pure _∘_ <*> u <*> v <*> w) ≡ (u <*> (v <*> w)) + mcomposition u v w + = begin + pure _∘_ <*> u <*> v <*> w + ≡⟨ cong (λ o → o <*> u <*> v <*> w) (def-pure-return _∘_) ⟩ + return _∘_ <*> u <*> v <*> w + ≡⟨ cong (λ o → o <*> v <*> w) (def-<*>->>= _ _ ) ⟩ + (do comp ← return _∘_; g ← u; return (comp g)) <*> v <*> w + ≡⟨ cong (λ o → o <*> v <*> w) (Monad.leftIdentity _ _) ⟩ + (do g ← u; return (_∘_ g)) <*> v <*> w + ≡⟨ cong (λ o → o <*> w) (def-<*>->>= _ _ ) ⟩ + (do g' ← (do g ← u; return (_∘_ g)); f ← v; return (g' f)) <*> w + ≡⟨ cong (λ o → o <*> w) (sym (Monad.associativity u _ _)) ⟩ + (do g ← u; g' ← return (_∘_ g); f ← v; return (g' f)) <*> w + ≡⟨ cong (λ o → o <*> w) (cong-monad u (λ g → Monad.leftIdentity _ _)) ⟩ + (do g ← u; f ← v; return (g ∘ f)) <*> w + ≡⟨ def-<*>->>= _ _ ⟩ + (do gf ← (do g ← u; f ← v; return (g ∘ f)); x ← w; return (gf x)) + ≡⟨ sym (Monad.associativity u _ _) ⟩ + (do g ← u; gf ← (do f ← v; return (g ∘ f)); x ← w; return (gf x)) + ≡⟨ cong-monad u (λ g → sym (Monad.associativity v _ _)) ⟩ + (do g ← u; do f ← v; gf ← return (g ∘ f); x ← w; return (gf x)) + ≡⟨ cong-monad u (λ g → cong-monad v (λ f → Monad.leftIdentity _ _)) ⟩ + (do g ← u; f ← v; x ← w; return (g (f x))) + ≡⟨ cong-monad u (λ g → cong-monad v λ f → cong-monad w (λ x → sym (Monad.leftIdentity _ _))) ⟩ + (do g ← u; f ← v; x ← w; y ← return (f x); return (g y)) + ≡⟨ cong-monad u (λ g → cong-monad v λ x → Monad.associativity _ _ _) ⟩ + (do g ← u; f ← v; y ← (do x ← w; return (f x)); return (g y)) + ≡⟨ cong-monad u (λ g → Monad.associativity _ _ _) ⟩ + (do g ← u; y ← (do f ← v; x ← w; return (f x)); return (g y)) + ≡⟨ sym (def-<*>->>= _ _) ⟩ + u <*> (do f ← v; x ← w; return (f x)) + ≡⟨ cong (λ o → u <*> o) (sym (def-<*>->>= _ _)) ⟩ + u <*> (v <*> w) + ∎ + + mhomomorphism + : ∀ {a b} (f : a → b) (x : a) + → (pure {m} f <*> pure x) ≡ pure (f x) + mhomomorphism f x = begin + pure {m} f <*> pure x + ≡⟨ cong₂ (_<*>_) (def-pure-return f) (def-pure-return x) ⟩ + return {m} f <*> return x + ≡⟨ def-<*>->>= _ _ ⟩ + (do f' ← return f; x' ← return x; return (f' x')) + ≡⟨ Monad.leftIdentity _ _ ⟩ + (do x' ← return x; return (f x')) + ≡⟨ Monad.leftIdentity _ _ ⟩ + return (f x) + ≡⟨ sym (def-pure-return _) ⟩ + pure (f x) + ∎ + + minterchange + : ∀ {a b} (u : m (a → b)) (y : a) + → (u <*> pure y) ≡ (pure (_$ y) <*> u) + minterchange u y = begin + u <*> pure y + ≡⟨ cong (u <*>_) (def-pure-return _) ⟩ + u <*> return y + ≡⟨ def-<*>->>= _ _ ⟩ + (do f ← u; y' ← return y; return (f y')) + ≡⟨ cong-monad u (λ f → Monad.leftIdentity y _) ⟩ + (do f ← u; return (f y)) + ≡⟨ sym (Monad.leftIdentity _ _) ⟩ + (do y'' ← return (_$ y); f ← u; return (y'' f)) + ≡⟨ sym (def-<*>->>= _ _) ⟩ + return (_$ y) <*> u + ≡⟨ sym (cong (_<*> u) (def-pure-return _)) ⟩ + pure (_$ y) <*> u + ∎ diff --git a/lib/base/Haskell/Law/Applicative/IO.agda b/lib/base/Haskell/Law/Applicative/IO.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Applicative/IO.agda @@ -0,0 +1,12 @@ +module Haskell.Law.Applicative.IO where + +open import Haskell.Prim +open import Haskell.Prim.IO + +open import Haskell.Prim.Applicative + +open import Haskell.Law.Applicative.Def + +open import Haskell.Law.Functor.IO + +instance postulate iLawfulApplicativeIO : IsLawfulApplicative IO diff --git a/lib/base/Haskell/Law/Applicative/List.agda b/lib/base/Haskell/Law/Applicative/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Applicative/List.agda @@ -0,0 +1,54 @@ +module Haskell.Law.Applicative.List where + +open import Haskell.Prim +open import Haskell.Prim.List + +open import Haskell.Prim.Applicative +open import Haskell.Prim.Functor + +open import Haskell.Law.Applicative.Def + +open import Haskell.Law.Equality +open import Haskell.Law.Functor.List +open import Haskell.Law.List + +private + identityList : {a : Type} → (v : List a) → (pure id <*> v) ≡ v + identityList [] = refl + identityList (x ∷ xs) + rewrite identityList xs + = refl + + compositionList : {a b c : Type} → (u : List (b → c)) (v : List (a → b)) (w : List a) + → ((((pure _∘_) <*> u) <*> v) <*> w) ≡ (u <*> (v <*> w)) + compositionList [] _ _ = refl + compositionList (u ∷ us) v w + rewrite sym $ concatMap-++-distr (map (u ∘_) v) (((pure _∘_) <*> us) <*> v) (λ f → map f w) + | sym $ map-<*>-recomp v w u + | compositionList us v w + = refl + + interchangeList : {a b : Type} → (u : List (a → b)) → (y : a) + → (u <*> (pure y)) ≡ (pure (_$ y) <*> u) + interchangeList [] _ = refl + interchangeList (x ∷ xs) y + rewrite interchangeList xs y + = refl + + functorList : {a b : Type} → (f : a → b) → (x : List a) + → (fmap f x) ≡ ((pure f) <*> x) + functorList _ [] = refl + functorList f (x ∷ xs) + rewrite functorList f xs + | ++-[] (map f xs) + | ++-[] (f x ∷ map f xs) + = refl + +instance + iLawfulApplicativeList : IsLawfulApplicative List + iLawfulApplicativeList = λ where + .identity → identityList + .composition → compositionList + .homomorphism _ x → refl + .interchange → interchangeList + .functor → functorList diff --git a/lib/base/Haskell/Law/Applicative/Maybe.agda b/lib/base/Haskell/Law/Applicative/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Applicative/Maybe.agda @@ -0,0 +1,27 @@ +module Haskell.Law.Applicative.Maybe where + +open import Haskell.Prim +open import Haskell.Prim.Maybe + +open import Haskell.Prim.Applicative + +open import Haskell.Law.Applicative.Def + +open import Haskell.Law.Functor.Maybe + +instance + iLawfulApplicativeMaybe : IsLawfulApplicative Maybe + iLawfulApplicativeMaybe .identity = λ { Nothing → refl; (Just _) → refl } + + iLawfulApplicativeMaybe .composition = + λ { Nothing _ _ → refl + ; (Just _) Nothing _ → refl + ; (Just _) (Just _) Nothing → refl + ; (Just _) (Just _) (Just _) → refl + } + + iLawfulApplicativeMaybe .homomorphism _ _ = refl + + iLawfulApplicativeMaybe .interchange = λ { Nothing _ → refl; (Just _) _ → refl } + + iLawfulApplicativeMaybe .functor = λ { _ Nothing → refl; _ (Just _) → refl } diff --git a/lib/base/Haskell/Law/Bool.agda b/lib/base/Haskell/Law/Bool.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Bool.agda @@ -0,0 +1,264 @@ +module Haskell.Law.Bool where + +open import Haskell.Prim +open import Haskell.Prim.Bool + +open import Haskell.Law.Equality + +{----------------------------------------------------------------------------- + Properties + Logical operations and constants +------------------------------------------------------------------------------} +-- +prop-x-&&-True + : ∀ (x : Bool) + → (x && True) ≡ x +-- +prop-x-&&-True True = refl +prop-x-&&-True False = refl + +-- +prop-x-&&-False + : ∀ (x : Bool) + → (x && False) ≡ False +-- +prop-x-&&-False True = refl +prop-x-&&-False False = refl + +-- +prop-x-||-True + : ∀ (x : Bool) + → (x || True) ≡ True +-- +prop-x-||-True True = refl +prop-x-||-True False = refl + +-- +prop-x-||-False + : ∀ (x : Bool) + → (x || False) ≡ x +-- +prop-x-||-False True = refl +prop-x-||-False False = refl + +{----------------------------------------------------------------------------- + Properties + Boolean algebra + https://en.wikipedia.org/wiki/Boolean_algebra_(structure) +------------------------------------------------------------------------------} +-- +prop-||-idem + : ∀ (a : Bool) + → (a || a) ≡ a +-- +prop-||-idem False = refl +prop-||-idem True = refl + +-- +prop-||-assoc + : ∀ (a b c : Bool) + → ((a || b) || c) ≡ (a || (b || c)) +-- +prop-||-assoc False b c = refl +prop-||-assoc True b c = refl + +-- +prop-||-sym + : ∀ (a b : Bool) + → (a || b) ≡ (b || a) +-- +prop-||-sym False False = refl +prop-||-sym False True = refl +prop-||-sym True False = refl +prop-||-sym True True = refl + +-- +prop-||-absorb + : ∀ (a b : Bool) + → (a || (a && b)) ≡ a +-- +prop-||-absorb False b = refl +prop-||-absorb True b = refl + +-- +prop-||-identity + : ∀ (a : Bool) + → (a || False) ≡ a +-- +prop-||-identity False = refl +prop-||-identity True = refl + +-- +prop-||-&&-distribute + : ∀ (a b c : Bool) + → (a || (b && c)) ≡ ((a || b) && (a || c)) +-- +prop-||-&&-distribute False b c = refl +prop-||-&&-distribute True b c = refl + +-- +prop-||-complement + : ∀ (a : Bool) + → (a || not a) ≡ True +-- +prop-||-complement False = refl +prop-||-complement True = refl + +-- +prop-&&-idem + : ∀ (a : Bool) + → (a && a) ≡ a +-- +prop-&&-idem False = refl +prop-&&-idem True = refl + +-- +prop-&&-assoc + : ∀ (a b c : Bool) + → ((a && b) && c) ≡ (a && (b && c)) +-- +prop-&&-assoc False b c = refl +prop-&&-assoc True b c = refl + +-- +prop-&&-sym + : ∀ (a b : Bool) + → (a && b) ≡ (b && a) +-- +prop-&&-sym False False = refl +prop-&&-sym False True = refl +prop-&&-sym True False = refl +prop-&&-sym True True = refl + +-- +prop-&&-absorb + : ∀ (a b : Bool) + → (a && (a || b)) ≡ a +-- +prop-&&-absorb False b = refl +prop-&&-absorb True b = refl + +-- +prop-&&-identity + : ∀ (a : Bool) + → (a && True) ≡ a +-- +prop-&&-identity False = refl +prop-&&-identity True = refl + +-- +prop-&&-||-distribute + : ∀ (a b c : Bool) + → (a && (b || c)) ≡ ((a && b) || (a && c)) +-- +prop-&&-||-distribute False b c = refl +prop-&&-||-distribute True b c = refl + +-- +prop-&&-complement + : ∀ (a : Bool) + → (a && not a) ≡ False +-- +prop-&&-complement False = refl +prop-&&-complement True = refl + +-- +prop-deMorgan-not-&& + : ∀ (a b : Bool) + → not (a && b) ≡ (not a || not b) +-- +prop-deMorgan-not-&& False b = refl +prop-deMorgan-not-&& True b = refl + +-- +prop-deMorgan-not-|| + : ∀ (a b : Bool) + → not (a || b) ≡ (not a && not b) +-- +prop-deMorgan-not-|| False b = refl +prop-deMorgan-not-|| True b = refl + +{----------------------------------------------------------------------------- + Properties + Other +------------------------------------------------------------------------------} + +-------------------------------------------------- +-- && + +&&-sym : ∀ (a b : Bool) → (a && b) ≡ (b && a) +&&-sym False False = refl +&&-sym False True = refl +&&-sym True False = refl +&&-sym True True = refl + +&&-semantics : ∀ (a b : Bool) → a ≡ True → b ≡ True → (a && b) ≡ True +&&-semantics True True _ _ = refl + +&&-leftAssoc : ∀ (a b c : Bool) → (a && b && c) ≡ True → ((a && b) && c) ≡ True +&&-leftAssoc True True True _ = refl + +&&-leftAssoc' : ∀ (a b c : Bool) → (a && b && c) ≡ ((a && b) && c) +&&-leftAssoc' False b c = refl +&&-leftAssoc' True b c = refl + +&&-leftTrue : ∀ (a b : Bool) → (a && b) ≡ True → a ≡ True +&&-leftTrue True True _ = refl + +&&-leftTrue' : ∀ (a b c : Bool) → a ≡ (b && c) → a ≡ True → c ≡ True +&&-leftTrue' .True True True _ refl = refl + +&&-rightTrue : ∀ (a b : Bool) → (a && b) ≡ True → b ≡ True +&&-rightTrue True True _ = refl + +&&-rightTrue' : ∀ (a b c : Bool) → a ≡ (b && c) → a ≡ True → b ≡ True +&&-rightTrue' .True True True _ refl = refl + +-------------------------------------------------- +-- || + +-- if a then True else b + +||-excludedMiddle : ∀ (a b : Bool) → (a || not a) ≡ True +||-excludedMiddle False _ = refl +||-excludedMiddle True _ = refl + +||-leftTrue : ∀ (a b : Bool) → a ≡ True → (a || b) ≡ True +||-leftTrue .True b refl = refl + +||-rightTrue : ∀ (a b : Bool) → b ≡ True → (a || b) ≡ True +||-rightTrue False .True refl = refl +||-rightTrue True .True refl = refl + +-------------------------------------------------- +-- not + +not-not : ∀ (a : Bool) → not (not a) ≡ a +not-not False = refl +not-not True = refl + +not-involution : ∀ (a b : Bool) → a ≡ not b → not a ≡ b +not-involution .(not b) b refl = not-not b + +-------------------------------------------------- +-- if_then_else_ + +ifFlip : ∀ (b) + → (t : {{not b ≡ True}} → a) + → (e : {{not b ≡ False}} → a) + → (if not b then t else e) ≡ + (if b then (e {{not-involution _ _ it}}) else t {{not-involution _ _ it}}) +ifFlip False _ _ = refl +ifFlip True _ _ = refl + +ifTrueEqThen : ∀ (b : Bool) + → {thn : {{b ≡ True}} → a} + → {els : {{b ≡ False}} → a} + → (pf : b ≡ True) → (if b then thn else els) ≡ thn {{pf}} +ifTrueEqThen .True refl = refl + +ifFalseEqElse : ∀ (b : Bool) + → {thn : {{b ≡ True}} → a} + → {els : {{b ≡ False}} → a} + → (pf : b ≡ False) → (if b then thn else els) ≡ els {{pf}} +ifFalseEqElse .False refl = refl diff --git a/lib/base/Haskell/Law/Def.agda b/lib/base/Haskell/Law/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Def.agda @@ -0,0 +1,6 @@ +module Haskell.Law.Def where + +open import Haskell.Prim + +Injective : (a → b) → Type _ +Injective f = ∀ {x y} → f x ≡ f y → x ≡ y diff --git a/lib/base/Haskell/Law/Either.agda b/lib/base/Haskell/Law/Either.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Either.agda @@ -0,0 +1,12 @@ +module Haskell.Law.Either where + +open import Haskell.Prim +open import Haskell.Prim.Either + +open import Haskell.Law.Def + +Left-injective : Injective (Left {a}{b}) +Left-injective refl = refl + +Right-injective : Injective (Right {a}{b}) +Right-injective refl = refl diff --git a/lib/base/Haskell/Law/Eq.agda b/lib/base/Haskell/Law/Eq.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Eq.agda @@ -0,0 +1,4 @@ +module Haskell.Law.Eq where + +open import Haskell.Law.Eq.Def public +open import Haskell.Law.Eq.Instances public diff --git a/lib/base/Haskell/Law/Eq/Def.agda b/lib/base/Haskell/Law/Eq/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Eq/Def.agda @@ -0,0 +1,75 @@ +module Haskell.Law.Eq.Def where + +open import Haskell.Prim +open import Haskell.Prim.Bool +open import Haskell.Prim.Double + +open import Haskell.Prim.Eq + +open import Haskell.Extra.Dec +open import Haskell.Extra.Refinement + +open import Haskell.Law.Bool +open import Haskell.Law.Equality + +record IsLawfulEq (e : Type) ⦃ iEq : Eq e ⦄ : Type₁ where + field + isEquality : ∀ (x y : e) → Reflects (x ≡ y) (x == y) + + equality : ∀ (x y : e) → (x == y) ≡ True → x ≡ y + equality x y h = extractTrue ⦃ h ⦄ (isEquality x y) + + nequality : ∀ (x y : e) → (x == y) ≡ False → (x ≡ y → ⊥) + nequality x y h = extractFalse ⦃ h ⦄ (isEquality x y) + + -- contrapositive of nequality + equality' : ∀ (x y : e) → x ≡ y → (x == y) ≡ True + equality' x y h with x == y in eq + ... | False = magic (nequality x y eq h) + ... | True = refl + + -- contrapositive of equality + nequality' : ∀ (x y : e) → (x ≡ y → ⊥) → (x == y) ≡ False + nequality' x y h with x == y in eq + ... | True = magic (h (equality x y eq)) + ... | False = refl + +open IsLawfulEq ⦃ ... ⦄ public + +-- Types with a lawful Eq instance have decidable equality +_≟_ : {{_ : Eq a}} {{_ : IsLawfulEq a}} → (x y : a) → Dec (x ≡ y) +x ≟ y = (x == y) ⟨ isEquality x y ⟩ + +{-# COMPILE AGDA2HS _≟_ inline #-} + +-- Reflexivity: x == x = True +eqReflexivity : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ + → ∀ (x : e) → (x == x) ≡ True +eqReflexivity x = equality' x x refl + +-- Symmetry: x == y = y == x +eqSymmetry : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ + → ∀ (x y : e) → (x == y) ≡ (y == x) +eqSymmetry x y with x == y in eq +... | True = sym (equality' y x (sym (equality x y eq))) +... | False = sym (nequality' y x (λ qe → (nequality x y eq) (sym qe))) + +-- Transitivity: if x == y && y == z = True, then x == z = True +eqTransitivity : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ + → ∀ (x y z : e) → ((x == y) && (y == z)) ≡ True → (x == z) ≡ True +eqTransitivity x y z h + = equality' x z (trans + (equality x y (&&-leftTrue (x == y) (y == z) h)) + (equality y z (&&-rightTrue (x == y) (y == z) h))) + +-- Extensionality: if x == y = True and f is a function whose return type is an instance of Eq, then f x == f y = True +eqExtensionality : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ + → ⦃ iEq : Eq a ⦄ → ⦃ iLawfulEq : IsLawfulEq a ⦄ + → ∀ ( x y : e ) ( f : e → a ) → (x == y) ≡ True → (f x == f y) ≡ True +eqExtensionality x y f h = equality' (f x) (f y) (cong f (equality x y h)) + +-- Negation: x /= y = not (x == y) +eqNegation : ⦃ iEq : Eq e ⦄ → ⦃ IsLawfulEq e ⦄ + → ∀ { x y : e } → (x /= y) ≡ not (x == y) +eqNegation = refl + diff --git a/lib/base/Haskell/Law/Eq/Instances.agda b/lib/base/Haskell/Law/Eq/Instances.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Eq/Instances.agda @@ -0,0 +1,138 @@ +module Haskell.Law.Eq.Instances where + +open import Agda.Builtin.Char.Properties renaming (primCharToNatInjective to c2n-injective) +open import Agda.Builtin.Word.Properties renaming (primWord64ToNatInjective to w2n-injective) + +open import Haskell.Prim +open import Haskell.Prim.Eq + +open import Haskell.Prim.Either using ( Either; Left; Right ) +open import Haskell.Prim.Int using ( Int; int64 ) +open import Haskell.Prim.Maybe +open import Haskell.Prim.Ord using ( Ordering; LT; GT; EQ ) +open import Haskell.Prim.Tuple +open import Haskell.Prim.Word using ( Word ) + +open import Haskell.Extra.Dec using ( mapReflects ) + +open import Haskell.Law.Eq.Def +open import Haskell.Law.Equality + +open import Haskell.Law.Either +open import Haskell.Law.Int +open import Haskell.Law.Integer +open import Haskell.Law.List using ( ∷-injective-left; ∷-injective-right ) +open import Haskell.Law.Maybe +open import Haskell.Law.Nat + +open _×_×_ + +instance + iLawfulEqNat : IsLawfulEq Nat + iLawfulEqNat .isEquality zero zero = refl + iLawfulEqNat .isEquality zero (suc _) = λ () + iLawfulEqNat .isEquality (suc _) zero = λ () + iLawfulEqNat .isEquality (suc x) (suc y) = mapReflects + (cong suc) + suc-injective + (isEquality x y) + + iLawfulEqWord : IsLawfulEq Word + iLawfulEqWord .isEquality x y + with (w2n x) in h₁ | (w2n y) in h₂ + ... | a | b = mapReflects + (λ h → w2n-injective x y $ sym $ trans (trans h₂ $ sym h) (sym h₁)) + (λ h → trans (sym $ trans (cong w2n (sym h)) h₁) h₂) + (isEquality a b) + + iLawfulEqBool : IsLawfulEq Bool + iLawfulEqBool .isEquality False False = refl + iLawfulEqBool .isEquality False True = λ() + iLawfulEqBool .isEquality True False = λ() + iLawfulEqBool .isEquality True True = refl + + iLawfulEqChar : IsLawfulEq Char + iLawfulEqChar .isEquality x y + with (c2n x) in h₁ | (c2n y) in h₂ + ... | a | b = mapReflects { a ≡ b } { x ≡ y } { eqNat a b } + (λ h → c2n-injective x y $ sym $ trans (trans h₂ $ sym h) (sym h₁)) + (λ h → trans (sym $ trans (cong c2n (sym h)) h₁) h₂) + (isEquality a b) + + iLawfulEqEither : ⦃ iEqA : Eq a ⦄ → ⦃ iEqB : Eq b ⦄ + → ⦃ IsLawfulEq a ⦄ → ⦃ IsLawfulEq b ⦄ + → IsLawfulEq (Either a b) + iLawfulEqEither .isEquality (Left _) (Right _) = λ () + iLawfulEqEither .isEquality (Right _) (Left _) = λ () + iLawfulEqEither .isEquality (Left x) (Left y) = mapReflects + (cong Left) (Left-injective) (isEquality x y) + iLawfulEqEither .isEquality (Right x) (Right y) = mapReflects + (cong Right) (Right-injective) (isEquality x y) + + iLawfulEqInt : IsLawfulEq Int + iLawfulEqInt .isEquality (int64 x) (int64 y) = mapReflects + (cong int64) int64-injective (isEquality x y) + + iLawfulEqInteger : IsLawfulEq Integer + iLawfulEqInteger .isEquality (pos n) (pos m) = mapReflects + (cong pos) pos-injective (isEquality n m) + iLawfulEqInteger .isEquality (pos _) (negsuc _) = λ () + iLawfulEqInteger .isEquality (negsuc _) (pos _) = λ () + iLawfulEqInteger .isEquality (negsuc n) (negsuc m) = mapReflects + (cong negsuc) neg-injective (isEquality n m) + + iLawfulEqList : ⦃ iEqA : Eq a ⦄ → ⦃ IsLawfulEq a ⦄ → IsLawfulEq (List a) + iLawfulEqList .isEquality [] [] = refl + iLawfulEqList .isEquality [] (_ ∷ _) = λ () + iLawfulEqList .isEquality (_ ∷ _) [] = λ () + iLawfulEqList .isEquality (x ∷ xs) (y ∷ ys) + with (x == y) in h₁ + ... | True = mapReflects + (λ h → cong₂ (_∷_) (equality x y h₁) h) + ∷-injective-right + (isEquality xs ys) + ... | False = λ h → (nequality x y h₁) (∷-injective-left h) + + iLawfulEqMaybe : ⦃ iEqA : Eq a ⦄ → ⦃ IsLawfulEq a ⦄ → IsLawfulEq (Maybe a) + iLawfulEqMaybe .isEquality Nothing Nothing = refl + iLawfulEqMaybe .isEquality Nothing (Just _) = λ() + iLawfulEqMaybe .isEquality (Just _) Nothing = λ() + iLawfulEqMaybe .isEquality (Just x) (Just y) = mapReflects + (cong Just) Just-injective (isEquality x y) + + iLawfulEqOrdering : IsLawfulEq Ordering + iLawfulEqOrdering .isEquality LT LT = refl + iLawfulEqOrdering .isEquality LT EQ = λ() + iLawfulEqOrdering .isEquality LT GT = λ() + iLawfulEqOrdering .isEquality EQ LT = λ() + iLawfulEqOrdering .isEquality EQ EQ = refl + iLawfulEqOrdering .isEquality EQ GT = λ() + iLawfulEqOrdering .isEquality GT LT = λ() + iLawfulEqOrdering .isEquality GT EQ = λ() + iLawfulEqOrdering .isEquality GT GT = refl + + iLawfulEqTuple₂ : ⦃ iEqA : Eq a ⦄ ⦃ iEqB : Eq b ⦄ + → ⦃ IsLawfulEq a ⦄ → ⦃ IsLawfulEq b ⦄ + → IsLawfulEq (a × b) + iLawfulEqTuple₂ .isEquality (x₁ , x₂) (y₁ , y₂) + with (x₁ == y₁) in h₁ + ... | True = mapReflects + (λ h → cong₂ _,_ (equality x₁ y₁ h₁) h) + (cong snd) + (isEquality x₂ y₂) + ... | False = λ h → exFalso (equality' x₁ y₁ (cong fst h)) h₁ + + iLawfulEqTuple₃ : ⦃ iEqA : Eq a ⦄ ⦃ iEqB : Eq b ⦄ ⦃ iEqC : Eq c ⦄ + → ⦃ IsLawfulEq a ⦄ → ⦃ IsLawfulEq b ⦄ → ⦃ IsLawfulEq c ⦄ + → IsLawfulEq (a × b × c) + iLawfulEqTuple₃ .isEquality (x₁ , x₂ , x₃) (y₁ , y₂ , y₃) + with (x₁ == y₁) in h₁ + ... | True = mapReflects + (λ h → cong₂ (λ a (b , c) → a , b , c) (equality x₁ y₁ h₁) h) + (cong λ h → snd3 h , thd3 h) + (isEquality (x₂ , x₃) (y₂ , y₃)) + ... | False = λ h → exFalso (equality' x₁ y₁ (cong fst3 h)) h₁ + + + iLawfulEqUnit : IsLawfulEq ⊤ + iLawfulEqUnit .isEquality tt tt = refl diff --git a/lib/base/Haskell/Law/Equality.agda b/lib/base/Haskell/Law/Equality.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Equality.agda @@ -0,0 +1,67 @@ +module Haskell.Law.Equality where + +open import Haskell.Prim + +open import Agda.Builtin.TrustMe + +_≠_ : {A : Type} → A → A → Type +_≠_ a b = a ≡ b → ⊥ + +infix 4 _≠_ + +-------------------------------------------------- +-- Basic Laws + +cong : {A B : Type} → ∀ (f : A → B) {x y} → x ≡ y → f x ≡ f y +cong f refl = refl + +cong₂ : ∀ (f : a → b → c) {x y u v} → x ≡ y → u ≡ v → f x u ≡ f y v +cong₂ f refl refl = refl + +sym : ∀ {A : Type} {x y : A} → x ≡ y → y ≡ x +sym refl = refl + +trans : ∀ {A : Type} {x y z : A} → x ≡ y → y ≡ z → x ≡ z +trans refl refl = refl + +subst : ∀ {A : Type} (P : A → Type) {x y : A} → x ≡ y → P x → P y +subst P refl z = z + +-------------------------------------------------- +-- Scary Things + +trustMe : ∀ {a} {A : Type a} {x y : A} → x ≡ y +trustMe = primTrustMe + +-------------------------------------------------- +-- ≡-Reasoning + +infix 1 begin_ +infixr 2 _≡⟨⟩_ step-≡ step-≡˘ +infix 3 _∎ + +begin_ : ∀{x y : a} → x ≡ y → x ≡ y +begin_ x≡y = x≡y + +_≡⟨⟩_ : ∀ (x {y} : a) → x ≡ y → x ≡ y +_ ≡⟨⟩ x≡y = x≡y + +step-≡ : ∀ (x {y z} : a) → y ≡ z → x ≡ y → x ≡ z +step-≡ _ y≡z x≡y = trans x≡y y≡z + +step-≡˘ : ∀ (x {y z} : a) → y ≡ z → y ≡ x → x ≡ z +step-≡˘ _ y≡z y≡x = trans (sym y≡x) y≡z + +_∎ : ∀ (x : a) → x ≡ x +_∎ _ = refl + +syntax step-≡ x y≡z x≡y = x ≡⟨ x≡y ⟩ y≡z +syntax step-≡˘ x y≡z y≡x = x ≡˘⟨ y≡x ⟩ y≡z + + +------------------------------------------------- +-- Utility Functions + +subst0 : {@0 a : Type} (@0 p : @0 a → Type) {@0 x y : a} → @0 x ≡ y → p x → p y +subst0 p refl z = z +{-# COMPILE AGDA2HS subst0 transparent #-} diff --git a/lib/base/Haskell/Law/Extensionality.agda b/lib/base/Haskell/Law/Extensionality.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Extensionality.agda @@ -0,0 +1,12 @@ +module Haskell.Law.Extensionality where + +open import Haskell.Prim + +------------------------------------------------------------------------------- +-- Axiom: Functions are equal if they agree on all arguments. +-- +-- This axiom is sometimes needed for proving properties of higher-order +-- functions, such as 'filter', 'fmap', or '(>>=)'. + +postulate + ext : ∀ {f g : a → b} → (∀ x → f x ≡ g x) → f ≡ g diff --git a/lib/base/Haskell/Law/Function.agda b/lib/base/Haskell/Law/Function.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Function.agda @@ -0,0 +1,171 @@ +module Haskell.Law.Function where + +open import Haskell.Prim +open import Haskell.Law.Equality + + +{-| +Pointwise equality on functions. +This says that two functions produce the same +result for all input values. +-} +infix 4 _≗_ +_≗_ : ∀ {A B : Type} (f g : A → B) → Type +f ≗ g = ∀ a → f a ≡ g a + +Commutative : {a : Type} → (a → a → a) → Type +Commutative _+_ = ∀ x y → x + y ≡ y + x + +Associative : {a : Type} → (a → a → a) → Type +Associative _+_ = ∀ x y z → (x + y) + z ≡ x + (y + z) + +Identityˡ : {a : Type} → (a → a → a) → a → Type +Identityˡ _+_ 𝟘 = ∀ x → 𝟘 + x ≡ x + +Identityʳ : {a : Type} → (a → a → a) → a → Type +Identityʳ _+_ 𝟘 = ∀ x → x + 𝟘 ≡ x + +Distributiveˡ : {a : Type} → (_+_ : a → a → a) → (_*_ : a → a → a) → Type +Distributiveˡ _+_ _*_ = ∀ x y z → x * (y + z) ≡ (x * y) + (x * z) + +Distributiveʳ : {a : Type} → (_+_ : a → a → a) → (_*_ : a → a → a) → Type +Distributiveʳ _+_ _*_ = ∀ x y z → (y + z) * x ≡ (y * x) + (z * x) + +{-| +Definition of homomorphism over unary functions. +A function φ is homomorphic w.r.t. some function or structure f +when it preserves this structure in its target domain b +(where this structure is called g). +-} +Homomorphism₁ : ∀ {a b : Type} (f : a → a) (g : b → b) + → (φ : a → b) → Type +Homomorphism₁ f g φ = φ ∘ f ≗ g ∘ φ + +{-| +Definition of homomorphism over binary functions. +A function φ is homomorphic w.r.t. some structure _+ᵃ_ +when it preserves this structure in its target domain b +(where this structure is called _+ᵇ_). +-} +Homomorphism₂ : ∀ {a b : Type} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) + → (φ : a → b) → Type +Homomorphism₂ _+ᵃ_ _+ᵇ_ φ = ∀ x y → φ (x +ᵃ y) ≡ φ x +ᵇ φ y + +record Embedding₂ {a b : Type} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) : Type where + field + hom : Homomorphism₂ _+ᵃ_ _+ᵇ_ φ + embed : φ⁻¹ ∘ φ ≗ id + +record MonoidEmbedding₂ {a b : Type} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) (0ᵃ : a) (0ᵇ : b) : Type where + field + embedding : Embedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ + 0-hom : φ 0ᵃ ≡ 0ᵇ + +map-comm : ∀ {a b : Type} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) + → Embedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ + → Commutative _+ᵇ_ + → Commutative _+ᵃ_ +map-comm _+ᵃ_ _+ᵇ_ φ φ⁻¹ proj comm x y = + begin + x +ᵃ y + ≡˘⟨ embed (x +ᵃ y) ⟩ + φ⁻¹ (φ (x +ᵃ y)) + ≡⟨ cong φ⁻¹ (hom x y) ⟩ + φ⁻¹ (φ x +ᵇ φ y) + ≡⟨ cong φ⁻¹ (comm (φ x) (φ y)) ⟩ + φ⁻¹ (φ y +ᵇ φ x) + ≡˘⟨ cong φ⁻¹ (hom y x) ⟩ + φ⁻¹ (φ (y +ᵃ x)) + ≡⟨ embed (y +ᵃ x) ⟩ + y +ᵃ x + ∎ + where + open Embedding₂ proj + +map-assoc : ∀ {a b : Type} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) + → Embedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ + → Associative _+ᵇ_ + → Associative _+ᵃ_ +map-assoc _+ᵃ_ _+ᵇ_ φ φ⁻¹ proj assoc x y z = + begin + (x +ᵃ y) +ᵃ z + ≡⟨ sym (embed ((x +ᵃ y) +ᵃ z)) ⟩ + φ⁻¹ (φ ((x +ᵃ y) +ᵃ z)) + ≡⟨ cong φ⁻¹ (hom (x +ᵃ y) z) ⟩ + φ⁻¹ (φ (x +ᵃ y) +ᵇ φ z) + ≡⟨ cong φ⁻¹ (cong (_+ᵇ φ z) (hom x y)) ⟩ + φ⁻¹ ((φ x +ᵇ φ y) +ᵇ φ z) + ≡⟨ cong φ⁻¹ (assoc (φ x) (φ y) (φ z)) ⟩ + φ⁻¹ (φ x +ᵇ (φ y +ᵇ φ z)) + ≡⟨ cong φ⁻¹ (cong (φ x +ᵇ_) (sym (hom y z))) ⟩ + φ⁻¹ (φ x +ᵇ φ (y +ᵃ z)) + ≡⟨ cong φ⁻¹ (sym (hom x (y +ᵃ z))) ⟩ + φ⁻¹ (φ (x +ᵃ (y +ᵃ z))) + ≡⟨ embed (x +ᵃ (y +ᵃ z)) ⟩ + x +ᵃ (y +ᵃ z) + ∎ + where + open Embedding₂ proj + +map-idˡ : ∀ {a b : Type} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) (0ᵃ : a) (0ᵇ : b) + → MonoidEmbedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ 0ᵃ 0ᵇ + → Identityˡ _+ᵇ_ 0ᵇ + → Identityˡ _+ᵃ_ 0ᵃ +map-idˡ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ membed idˡ x = + 0ᵃ +ᵃ x ≡⟨ sym (embed (0ᵃ +ᵃ x)) ⟩ + g (f (0ᵃ +ᵃ x)) ≡⟨ cong g (hom 0ᵃ x) ⟩ + g (f 0ᵃ +ᵇ f x) ≡⟨ cong g (cong (_+ᵇ f x) 0-hom) ⟩ + g (0ᵇ +ᵇ f x) ≡⟨ cong g (idˡ (f x)) ⟩ + g (f x) ≡⟨ embed x ⟩ + x ∎ + where + open MonoidEmbedding₂ membed + open Embedding₂ embedding + +map-idʳ : ∀ {a b : Type} (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) (φ : a → b) (φ⁻¹ : b → a) (0ᵃ : a) (0ᵇ : b) + → MonoidEmbedding₂ _+ᵃ_ _+ᵇ_ φ φ⁻¹ 0ᵃ 0ᵇ + → Identityʳ _+ᵇ_ 0ᵇ + → Identityʳ _+ᵃ_ 0ᵃ +map-idʳ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ membed idʳ x = + x +ᵃ 0ᵃ ≡⟨ sym (embed (x +ᵃ 0ᵃ)) ⟩ + g (f (x +ᵃ 0ᵃ)) ≡⟨ cong g (hom x 0ᵃ) ⟩ + g (f x +ᵇ f 0ᵃ) ≡⟨ cong g (cong (f x +ᵇ_) 0-hom) ⟩ + g (f x +ᵇ 0ᵇ) ≡⟨ cong g (idʳ (f x)) ⟩ + g (f x) ≡⟨ embed x ⟩ + x ∎ + where + open MonoidEmbedding₂ membed + open Embedding₂ embedding + +module _ {a b : Type} + (_+ᵃ_ : a → a → a) (_+ᵇ_ : b → b → b) + (_*ᵃ_ : a → a → a) (_*ᵇ_ : b → b → b) + (f : a → b) (g : b → a) + (embed : g ∘ f ≗ id) + (+-hom : Homomorphism₂ _+ᵃ_ _+ᵇ_ f) + (*-hom : Homomorphism₂ _*ᵃ_ _*ᵇ_ f) + where + + map-distributeˡ : Distributiveˡ _+ᵇ_ _*ᵇ_ → Distributiveˡ _+ᵃ_ _*ᵃ_ + map-distributeˡ distributeˡ-b x y z = + x *ᵃ (y +ᵃ z) ≡˘⟨ embed (x *ᵃ (y +ᵃ z)) ⟩ + g (f (x *ᵃ (y +ᵃ z))) ≡⟨ cong g (*-hom x (y +ᵃ z)) ⟩ + g (f x *ᵇ f (y +ᵃ z)) ≡⟨ cong g (cong (f x *ᵇ_) (+-hom y z)) ⟩ + g (f x *ᵇ (f y +ᵇ f z)) ≡⟨ cong g (distributeˡ-b (f x) (f y) (f z)) ⟩ + g ((f x *ᵇ f y) +ᵇ (f x *ᵇ f z)) ≡˘⟨ cong g (cong (_+ᵇ (f x *ᵇ f z)) (*-hom x y)) ⟩ + g (f (x *ᵃ y) +ᵇ (f x *ᵇ f z)) ≡˘⟨ cong g (cong (f (x *ᵃ y) +ᵇ_) (*-hom x z)) ⟩ + g (f (x *ᵃ y) +ᵇ f (x *ᵃ z)) ≡˘⟨ cong g (+-hom (x *ᵃ y) (x *ᵃ z)) ⟩ + g (f ((x *ᵃ y) +ᵃ (x *ᵃ z))) ≡⟨ embed ((x *ᵃ y) +ᵃ (x *ᵃ z)) ⟩ + (x *ᵃ y) +ᵃ (x *ᵃ z) ∎ + + map-distributeʳ : Distributiveʳ _+ᵇ_ _*ᵇ_ → Distributiveʳ _+ᵃ_ _*ᵃ_ + map-distributeʳ distributeʳ-b x y z = + (y +ᵃ z) *ᵃ x ≡˘⟨ embed ((y +ᵃ z) *ᵃ x) ⟩ + g (f ((y +ᵃ z) *ᵃ x)) ≡⟨ cong g (*-hom (y +ᵃ z) x) ⟩ + g (f (y +ᵃ z) *ᵇ f x) ≡⟨ cong g (cong (_*ᵇ f x) (+-hom y z)) ⟩ + g ((f y +ᵇ f z) *ᵇ f x) ≡⟨ cong g (distributeʳ-b (f x) (f y) (f z)) ⟩ + g ((f y *ᵇ f x) +ᵇ (f z *ᵇ f x)) ≡˘⟨ cong g (cong (_+ᵇ (f z *ᵇ f x)) (*-hom y x)) ⟩ + g (f (y *ᵃ x) +ᵇ (f z *ᵇ f x)) ≡˘⟨ cong g (cong (f (y *ᵃ x) +ᵇ_) (*-hom z x)) ⟩ + g (f (y *ᵃ x) +ᵇ f (z *ᵃ x)) ≡˘⟨ cong g (+-hom (y *ᵃ x) (z *ᵃ x)) ⟩ + g (f ((y *ᵃ x) +ᵃ (z *ᵃ x))) ≡⟨ embed ((y *ᵃ x) +ᵃ (z *ᵃ x)) ⟩ + (y *ᵃ x) +ᵃ (z *ᵃ x) ∎ diff --git a/lib/base/Haskell/Law/Functor.agda b/lib/base/Haskell/Law/Functor.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Functor.agda @@ -0,0 +1,7 @@ +module Haskell.Law.Functor where + +open import Haskell.Law.Functor.Def public +open import Haskell.Law.Functor.Either public +open import Haskell.Law.Functor.IO public +open import Haskell.Law.Functor.List public +open import Haskell.Law.Functor.Maybe public diff --git a/lib/base/Haskell/Law/Functor/Def.agda b/lib/base/Haskell/Law/Functor/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Functor/Def.agda @@ -0,0 +1,24 @@ +module Haskell.Law.Functor.Def where + +open import Haskell.Prim +open import Haskell.Prim.Tuple + +open import Haskell.Prim.Functor + +record IsLawfulFunctor (F : Type → Type) ⦃ iFuncF : Functor F ⦄ : Type₁ where + field + -- Identity: fmap id == id + identity : (fa : F a) → (fmap id) fa ≡ id fa + + -- Composition: fmap (f . g) == fmap f . fmap g + composition : (fa : F a) (f : a → b) (g : b → c) + → fmap (g ∘ f) fa ≡ (fmap g ∘ fmap f) fa + +open IsLawfulFunctor ⦃ ... ⦄ public + +instance postulate + iLawfulFunctorFun : IsLawfulFunctor (λ b → a → b) + + iLawfulFunctorTuple₂ : IsLawfulFunctor (a ×_) + + iLawfulFunctorTuple₃ : IsLawfulFunctor (a × b ×_) diff --git a/lib/base/Haskell/Law/Functor/Either.agda b/lib/base/Haskell/Law/Functor/Either.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Functor/Either.agda @@ -0,0 +1,14 @@ +module Haskell.Law.Functor.Either where + +open import Haskell.Prim +open import Haskell.Prim.Either + +open import Haskell.Prim.Functor + +open import Haskell.Law.Functor.Def + +instance + iLawfulFunctorEither : IsLawfulFunctor (Either a) + iLawfulFunctorEither .identity = λ { (Left _) → refl; (Right _) → refl } + + iLawfulFunctorEither .composition = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } diff --git a/lib/base/Haskell/Law/Functor/FromMonad.agda b/lib/base/Haskell/Law/Functor/FromMonad.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Functor/FromMonad.agda @@ -0,0 +1,33 @@ +module Haskell.Law.Functor.FromMonad where + +open import Haskell.Prim + +open import Haskell.Prim.Functor +open import Haskell.Prim.Monad + +open import Haskell.Law.Monad.Def as Monad +open import Haskell.Law.Equality +open import Haskell.Law.Functor + +------------------------------------------------------------------------------- +-- Prove the Functor laws from the Monad laws + +-- +prop-PreLawfulMonad→IsLawfulFunctor + : ∀ ⦃ _ : Monad m ⦄ ⦃ _ : PreLawfulMonad m ⦄ + → IsLawfulFunctor m +-- +prop-PreLawfulMonad→IsLawfulFunctor .identity fa + rewrite Monad.def-fmap->>= id fa + = Monad.rightIdentity fa +prop-PreLawfulMonad→IsLawfulFunctor .composition fa f g + rewrite Monad.def-fmap->>= g (fmap f fa) + | Monad.def-fmap->>= f fa + | Monad.def-fmap->>= (g ∘ f) fa + = begin + fa >>= (return ∘ g ∘ f) + ≡⟨ cong-monad fa (λ x → sym (Monad.leftIdentity (f x) _)) ⟩ + fa >>= (λ x → return (f x) >>= (return ∘ g)) + ≡⟨ Monad.associativity _ _ _ ⟩ + (fa >>= (return ∘ f)) >>= (return ∘ g) + ∎ diff --git a/lib/base/Haskell/Law/Functor/IO.agda b/lib/base/Haskell/Law/Functor/IO.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Functor/IO.agda @@ -0,0 +1,10 @@ +module Haskell.Law.Functor.IO where + +open import Haskell.Prim +open import Haskell.Prim.IO + +open import Haskell.Prim.Functor + +open import Haskell.Law.Functor.Def + +instance postulate isLawFulFunctorIO : IsLawfulFunctor IO diff --git a/lib/base/Haskell/Law/Functor/List.agda b/lib/base/Haskell/Law/Functor/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Functor/List.agda @@ -0,0 +1,25 @@ +module Haskell.Law.Functor.List where + +open import Haskell.Prim +open import Haskell.Prim.List + +open import Haskell.Prim.Functor + +open import Haskell.Law.Equality +open import Haskell.Law.Functor.Def + +private + identityList : (fa : List a) → (fmap id) fa ≡ id fa + identityList [] = refl + identityList (x ∷ xs) rewrite identityList xs = refl + + compositionList : (fa : List a) → (f : a → b) → (g : b → c) + → fmap (g ∘ f) fa ≡ (fmap g ∘ fmap f) fa + compositionList [] _ _ = refl + compositionList (x ∷ xs) f g rewrite compositionList xs f g = refl + +instance + iLawfulFunctorList : IsLawfulFunctor List + iLawfulFunctorList = λ where + .identity → identityList + .composition → compositionList diff --git a/lib/base/Haskell/Law/Functor/Maybe.agda b/lib/base/Haskell/Law/Functor/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Functor/Maybe.agda @@ -0,0 +1,14 @@ +module Haskell.Law.Functor.Maybe where + +open import Haskell.Prim +open import Haskell.Prim.Maybe + +open import Haskell.Prim.Functor + +open import Haskell.Law.Functor.Def + +instance + iLawfulFunctorMaybe : IsLawfulFunctor Maybe + iLawfulFunctorMaybe .identity = λ { Nothing → refl; (Just _) → refl } + + iLawfulFunctorMaybe .composition = λ { Nothing _ _ → refl; (Just _) _ _ → refl } diff --git a/lib/base/Haskell/Law/Int.agda b/lib/base/Haskell/Law/Int.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Int.agda @@ -0,0 +1,9 @@ +module Haskell.Law.Int where + +open import Haskell.Prim +open import Haskell.Prim.Int using ( int64 ) + +open import Haskell.Law.Def + +int64-injective : Injective int64 +int64-injective refl = refl diff --git a/lib/base/Haskell/Law/Integer.agda b/lib/base/Haskell/Law/Integer.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Integer.agda @@ -0,0 +1,11 @@ +module Haskell.Law.Integer where + +open import Haskell.Prim + +open import Haskell.Law.Def + +pos-injective : Injective pos +pos-injective refl = refl + +neg-injective : Injective negsuc +neg-injective refl = refl diff --git a/lib/base/Haskell/Law/List.agda b/lib/base/Haskell/Law/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/List.agda @@ -0,0 +1,145 @@ +module Haskell.Law.List where + +open import Haskell.Law.Equality +open import Haskell.Prim renaming (addNat to _+ₙ_) +open import Haskell.Prim.Foldable +open import Haskell.Prim.List +open import Haskell.Prim.Applicative + +[]≠∷ : ∀ x (xs : List a) → [] ≠ x ∷ xs +[]≠∷ x xs () + +-------------------------------------------------- +-- _∷_ + +module _ {x y : a} {xs ys : List a} where + ∷-injective-left : x ∷ xs ≡ y ∷ ys → x ≡ y + ∷-injective-left refl = refl + + ∷-injective-right : x ∷ xs ≡ y ∷ ys → xs ≡ ys + ∷-injective-right refl = refl + +-------------------------------------------------- +-- map + +map-id : (xs : List a) → map id xs ≡ xs +map-id [] = refl +map-id (x ∷ xs) = cong (x ∷_) (map-id xs) + +map-++ : ∀ (f : a → b) xs ys → map f (xs ++ ys) ≡ map f xs ++ map f ys +map-++ f [] ys = refl +map-++ f (x ∷ xs) ys = cong (f x ∷_) (map-++ f xs ys) + +lengthMap : ∀ (f : a → b) xs → lengthNat (map f xs) ≡ lengthNat xs +lengthMap f [] = refl +lengthMap f (x ∷ xs) = cong suc (lengthMap f xs) + +map-∘ : ∀ (g : b → c) (f : a → b) xs → map (g ∘ f) xs ≡ (map g ∘ map f) xs +map-∘ g f [] = refl +map-∘ g f (x ∷ xs) = cong (_ ∷_) (map-∘ g f xs) + +map-concatMap : ∀ (f : a → b) (xs : List a) → (map f xs) ≡ concatMap (λ g → f g ∷ []) xs +map-concatMap f [] = refl +map-concatMap f (x ∷ xs) + rewrite map-concatMap f xs + = refl + +map-<*>-recomp : {a b c : Type} → (xs : List (a → b)) → (ys : List a) → (u : (b → c)) + → ((map (u ∘_) xs) <*> ys) ≡ map u (xs <*> ys) +map-<*>-recomp [] _ _ = refl +map-<*>-recomp (x ∷ xs) ys u + rewrite map-∘ u x ys + | map-++ u (map x ys) (xs <*> ys) + | map-<*>-recomp xs ys u + = refl + +-------------------------------------------------- +-- _++_ + +lengthNat-++ : ∀ (xs : List a) {ys} → + lengthNat (xs ++ ys) ≡ lengthNat xs +ₙ lengthNat ys +lengthNat-++ [] = refl +lengthNat-++ (x ∷ xs) = cong suc (lengthNat-++ xs) + +++-[] : ∀ (xs : List a) → xs ++ [] ≡ xs +++-[] [] = refl +++-[] (x ∷ xs) rewrite ++-[] xs = refl + +[]-++ : ∀ (xs : List a) → [] ++ xs ≡ xs +[]-++ xs = refl + +++-assoc : ∀ (xs ys zs : List a) → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs) +++-assoc [] ys zs = refl +++-assoc (x ∷ xs) ys zs rewrite ++-assoc xs ys zs = refl + +++-∷-assoc : ∀ xs y (ys : List a) → xs ++ y ∷ ys ≡ (xs ++ y ∷ []) ++ ys +++-∷-assoc [] y ys = refl +++-∷-assoc (x ∷ xs) y ys = cong (x ∷_) (++-∷-assoc xs y ys) + +∷-++-assoc : ∀ x xs (ys : List a) → (x ∷ xs) ++ ys ≡ x ∷ (xs ++ ys) +∷-++-assoc x xs ys = refl + +++-identity-right-unique : ∀ (xs : List a) {ys} → xs ≡ xs ++ ys → ys ≡ [] +++-identity-right-unique [] refl = refl +++-identity-right-unique (x ∷ xs) eq = + ++-identity-right-unique xs (∷-injective-right eq) + +++-identity-left-unique : ∀ {xs} (ys : List a) → xs ≡ ys ++ xs → ys ≡ [] +++-identity-left-unique [] _ = refl +++-identity-left-unique {xs = x ∷ xs} (y ∷ ys) eq + with ++-identity-left-unique (ys ++ (x ∷ [])) (begin + xs ≡⟨ ∷-injective-right eq ⟩ + ys ++ x ∷ xs ≡⟨ sym (++-assoc ys (x ∷ []) xs) ⟩ + (ys ++ x ∷ []) ++ xs ∎) +++-identity-left-unique {xs = x ∷ xs} (y ∷ [] ) eq | () +++-identity-left-unique {xs = x ∷ xs} (y ∷ _ ∷ _) eq | () + +++-cancel-left : ∀ (xs ys : List a) {zs} → xs ++ ys ≡ xs ++ zs → ys ≡ zs +++-cancel-left [] ys eq = eq +++-cancel-left (x ∷ xs) ys eq = ++-cancel-left xs ys (∷-injective-right eq) + +++-cancel-right : ∀ (xs ys : List a) {zs} → xs ++ zs ≡ ys ++ zs → xs ≡ ys +++-cancel-right [] [] eq = refl +++-cancel-right (x ∷ xs) [] eq = ++-identity-left-unique (x ∷ xs) (sym eq) +++-cancel-right [] (y ∷ ys) eq = sym $ ++-identity-left-unique (y ∷ ys) eq +++-cancel-right (x ∷ xs) (y ∷ ys) eq + rewrite ∷-injective-left eq = cong (y ∷_) $ ++-cancel-right xs ys (∷-injective-right eq) + +++-conical-left : (xs ys : List a) → xs ++ ys ≡ [] → xs ≡ [] +++-conical-left [] _ refl = refl + +++-conical-right : (xs ys : List a) → xs ++ ys ≡ [] → ys ≡ [] +++-conical-right [] _ refl = refl + +∷-not-identity : ∀ x (xs ys : List a) → (x ∷ xs) ++ ys ≡ ys → ⊥ +∷-not-identity x xs ys eq = []≠∷ x xs (sym $ ++-identity-left-unique (x ∷ xs) (sym eq)) + +concatMap-++-distr : ∀ (xs ys : List a) (f : a → List b) → + ((concatMap f xs) ++ (concatMap f ys)) ≡ (concatMap f (xs ++ ys)) +concatMap-++-distr [] ys f = refl +concatMap-++-distr (x ∷ xs) ys f + rewrite ++-assoc (f x) (concatMap f xs) (concatMap f ys) + | concatMap-++-distr xs ys f + = refl + +-------------------------------------------------- +-- foldr + +foldr-universal : ∀ (h : List a → b) f e → (h [] ≡ e) → + (∀ x xs → h (x ∷ xs) ≡ f x (h xs)) → + ∀ xs → h xs ≡ foldr f e xs +foldr-universal h f e base step [] = base +foldr-universal h f e base step (x ∷ xs) rewrite step x xs = cong (f x) (foldr-universal h f e base step xs) + +foldr-cong : ∀ {f g : a → b → b} {d e : b} → + (∀ x y → f x y ≡ g x y) → d ≡ e → + ∀ (xs : List a) → foldr f d xs ≡ foldr g e xs +foldr-cong f≡g d≡e [] = d≡e +foldr-cong f≡g d≡e (x ∷ xs) rewrite foldr-cong f≡g d≡e xs = f≡g x _ + +foldr-fusion : (h : b → c) {f : a → b → b} {g : a → c → c} (e : b) → + (∀ x y → h (f x y) ≡ g x (h y)) → + ∀ (xs : List a) → h (foldr f e xs) ≡ foldr g (h e) xs +foldr-fusion h {f} {g} e fuse = + foldr-universal (h ∘ foldr f e) g (h e) refl + (λ x xs → fuse x (foldr f e xs)) diff --git a/lib/base/Haskell/Law/Maybe.agda b/lib/base/Haskell/Law/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Maybe.agda @@ -0,0 +1,9 @@ +module Haskell.Law.Maybe where + +open import Haskell.Prim +open import Haskell.Prim.Maybe + +open import Haskell.Law.Def + +Just-injective : Injective (Just {a = a}) +Just-injective refl = refl diff --git a/lib/base/Haskell/Law/Monad.agda b/lib/base/Haskell/Law/Monad.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monad.agda @@ -0,0 +1,7 @@ +module Haskell.Law.Monad where + +open import Haskell.Law.Monad.Def public +open import Haskell.Law.Monad.Either public +open import Haskell.Law.Monad.IO public +open import Haskell.Law.Monad.List public +open import Haskell.Law.Monad.Maybe public diff --git a/lib/base/Haskell/Law/Monad/Def.agda b/lib/base/Haskell/Law/Monad/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monad/Def.agda @@ -0,0 +1,75 @@ +module Haskell.Law.Monad.Def where + +open import Haskell.Prim + +open import Haskell.Prim.Applicative +open import Haskell.Prim.Functor +open import Haskell.Prim.Monad +open import Haskell.Prim.Monoid +open import Haskell.Prim.Tuple + +open import Haskell.Law.Applicative +open import Haskell.Law.Equality +open import Haskell.Law.Extensionality + +-- Helper function: Substitution in the second argument of '(>>=)'. +cong-monad + : ∀ ⦃ _ : Monad m ⦄ (mx : m a) {f g : a → m b} + → (∀ x → f x ≡ g x) + → (do x ← mx; f x) ≡ (do x ← mx; g x) +-- +cong-monad mx {f} {g} eq = cong (mx >>=_) (ext eq) + +------------------------------------------------------------------------------- +-- Monad laws +-- +-- `PreLawfulMonad` contains all laws that we expect a 'Monad' to satisfy, +-- except that we do not yet require that the superclasses are themselves +-- lawful, this is deferred to `IsLawfulMonad`. +-- The lawfulness of the superclasses can be proven from `PreLawfulMonad`. + +record PreLawfulMonad (m : Type → Type) ⦃ _ : Monad m ⦄ : Type₁ where + field + -- The three monad laws + leftIdentity : ∀ {a} (x : a) (k : a → m b) + → (return x >>= k) ≡ k x + + rightIdentity : ∀ {a} (ma : m a) + → (ma >>= return) ≡ ma + + associativity : ∀ {a b c} (ma : m a) (f : a → m b) (g : b → m c) + → (ma >>= (λ x → f x >>= g)) ≡ ((ma >>= f) >>= g) + + -- Default functions + def->>->>= : ∀ {a b} (ma : m a) (mb : m b) + → ma >> mb ≡ ma >>= (λ x → mb) + + def-pure-return : ∀ {a} (x : a) + → pure {m} x ≡ return x + + -- Superclass functions + def-fmap->>= : ∀ {a b} (f : a → b) (ma : m a) + → fmap f ma ≡ ma >>= (return ∘ f) + + def-<*>->>= : ∀ {a b} (mab : m (a → b)) (ma : m a) + → (mab <*> ma) ≡ (mab >>= (λ f → (ma >>= (λ x → return (f x))))) + +open PreLawfulMonad ⦃ ... ⦄ public + +-- All laws together +record IsLawfulMonad (m : Type → Type) ⦃ _ : Monad m ⦄ : Type₁ where + field + overlap ⦃ applicative ⦄ : IsLawfulApplicative m + overlap ⦃ monad ⦄ : PreLawfulMonad m + +open IsLawfulMonad ⦃ ... ⦄ public + +------------------------------------------------------------------------------- +-- postulated monad laws, to be proven + +instance postulate + iLawfulMonadFun : IsLawfulMonad (λ b → a → b) + + iLawfulMonadTuple₂ : ⦃ Monoid a ⦄ → Monad (a ×_) + + iLawfulMonadTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Monad (a × b ×_) diff --git a/lib/base/Haskell/Law/Monad/Either.agda b/lib/base/Haskell/Law/Monad/Either.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monad/Either.agda @@ -0,0 +1,31 @@ +module Haskell.Law.Monad.Either where + +open import Haskell.Prim +open import Haskell.Prim.Either + +open import Haskell.Prim.Monad + +open import Haskell.Law.Monad.Def + +open import Haskell.Law.Applicative.Either + +instance + iPreLawfulMonadEither : PreLawfulMonad (Either a) + iPreLawfulMonadEither = λ where + .leftIdentity _ _ → refl + .rightIdentity (Left x) → refl + .rightIdentity (Right x) → refl + .associativity (Left x) _ _ → refl + .associativity (Right x) _ _ → refl + .def->>->>= _ _ → refl + .def-pure-return _ → refl + .def-fmap->>= _ → λ where + (Left x) → refl + (Right x) → refl + .def-<*>->>= → λ where + (Left _) _ → refl + (Right _) (Left _) → refl + (Right _) (Right _) → refl + + iIsLawfulMonadEither : IsLawfulMonad (Either a) + iIsLawfulMonadEither = record {} diff --git a/lib/base/Haskell/Law/Monad/IO.agda b/lib/base/Haskell/Law/Monad/IO.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monad/IO.agda @@ -0,0 +1,17 @@ +module Haskell.Law.Monad.IO where + +open import Haskell.Prim +open import Haskell.Prim.IO + +open import Haskell.Prim.Monad + +open import Haskell.Law.Monad.Def + +open import Haskell.Law.Applicative.IO using (iLawfulApplicativeIO) + +instance + postulate + iPreLawfulMonadIO : PreLawfulMonad IO + + iIsLawfulMonadIO : IsLawfulMonad IO + iIsLawfulMonadIO = record { applicative = iLawfulApplicativeIO } diff --git a/lib/base/Haskell/Law/Monad/List.agda b/lib/base/Haskell/Law/Monad/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monad/List.agda @@ -0,0 +1,43 @@ +module Haskell.Law.Monad.List where + +open import Haskell.Prim +open import Haskell.Prim.List + +open import Haskell.Prim.Monad + +open import Haskell.Law.Monad.Def +open import Haskell.Law.List + +open import Haskell.Law.Applicative.List + +instance + iPreLawfulMonadList : PreLawfulMonad List + iPreLawfulMonadList .leftIdentity _ _ = ++-[] _ + + iPreLawfulMonadList .rightIdentity [] = refl + iPreLawfulMonadList .rightIdentity (x ∷ xs) + rewrite iPreLawfulMonadList .PreLawfulMonad.rightIdentity xs + = refl + + iPreLawfulMonadList .associativity [] f g = refl + iPreLawfulMonadList .associativity (x ∷ xs) f g + rewrite associativity xs f g + | concatMap-++-distr (f x) (xs >>= f) g + = refl + + iPreLawfulMonadList .def->>->>= _ _ = refl + iPreLawfulMonadList .def-pure-return _ = refl + + iPreLawfulMonadList .def-fmap->>= _ [] = refl + iPreLawfulMonadList .def-fmap->>= f (x ∷ xs) + rewrite iPreLawfulMonadList .PreLawfulMonad.def-fmap->>= f xs + = refl + + iPreLawfulMonadList .def-<*>->>= [] xs = refl + iPreLawfulMonadList .def-<*>->>= (f ∷ fs) xs + rewrite iPreLawfulMonadList .PreLawfulMonad.def-<*>->>= fs xs + | map-concatMap f xs + = refl + + iIsLawfulMonadList : IsLawfulMonad List + iIsLawfulMonadList = record {} diff --git a/lib/base/Haskell/Law/Monad/Maybe.agda b/lib/base/Haskell/Law/Monad/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monad/Maybe.agda @@ -0,0 +1,35 @@ +module Haskell.Law.Monad.Maybe where + +open import Haskell.Prim +open import Haskell.Prim.Maybe + +open import Haskell.Prim.Monad + +open import Haskell.Law.Monad.Def + +open import Haskell.Law.Applicative.Maybe + +instance + iPreLawfulMonadMaybe : PreLawfulMonad Maybe + iPreLawfulMonadMaybe = λ where + .leftIdentity _ _ → refl + .rightIdentity → λ where + Nothing → refl + (Just _) → refl + .associativity → λ where + Nothing _ _ → refl + (Just _) _ _ → refl + + .def->>->>= _ _ → refl + .def-pure-return _ → refl + + .def-fmap->>= _ → λ where + Nothing → refl + (Just _) → refl + .def-<*>->>= → λ where + Nothing _ → refl + (Just _) Nothing → refl + (Just _) (Just _) → refl + + iIsLawfulMonadMaybe : IsLawfulMonad Maybe + iIsLawfulMonadMaybe = record {} diff --git a/lib/base/Haskell/Law/Monoid.agda b/lib/base/Haskell/Law/Monoid.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monoid.agda @@ -0,0 +1,10 @@ +module Haskell.Law.Monoid where + +open import Haskell.Law.Semigroup.Def public +open import Haskell.Law.Semigroup.Either public +open import Haskell.Law.Semigroup.List public +open import Haskell.Law.Semigroup.Maybe public + +open import Haskell.Law.Monoid.Def public +open import Haskell.Law.Monoid.List public +open import Haskell.Law.Monoid.Maybe public diff --git a/lib/base/Haskell/Law/Monoid/Def.agda b/lib/base/Haskell/Law/Monoid/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monoid/Def.agda @@ -0,0 +1,38 @@ +module Haskell.Law.Monoid.Def where + +open import Haskell.Prim +open import Haskell.Prim.Tuple + +open import Haskell.Prim.Foldable +open import Haskell.Prim.Monoid + +open import Haskell.Law.Semigroup.Def + +record IsLawfulMonoid (a : Type) ⦃ iMonoidA : Monoid a ⦄ : Type₁ where + field + overlap ⦃ super ⦄ : IsLawfulSemigroup a + + -- Right identity: x <> mempty = x + rightIdentity : (x : a) → x <> mempty ≡ x + + -- Left identity: mempty <> x = x + leftIdentity : (x : a) → mempty <> x ≡ x + + -- Concatenation: mconcat = foldr (<>) mempty + concatenation : (xs : List a) → mconcat xs ≡ foldr _<>_ mempty xs + +open IsLawfulMonoid ⦃ ... ⦄ public + +postulate instance + iLawfulMonoidFun : ⦃ iSemB : Monoid b ⦄ → ⦃ IsLawfulMonoid b ⦄ → IsLawfulMonoid (a → b) + + iLawfulMonoidUnit : IsLawfulMonoid ⊤ + + iLawfulMonoidTuple₂ : ⦃ iSemA : Monoid a ⦄ ⦃ iSemB : Monoid b ⦄ + → ⦃ IsLawfulMonoid a ⦄ → ⦃ IsLawfulMonoid b ⦄ + → IsLawfulMonoid (a × b) + + iLawfulMonoidTuple₃ : ⦃ iSemA : Monoid a ⦄ ⦃ iSemB : Monoid b ⦄ ⦃ iSemC : Monoid c ⦄ + → ⦃ IsLawfulMonoid a ⦄ → ⦃ IsLawfulMonoid b ⦄ → ⦃ IsLawfulMonoid c ⦄ + → IsLawfulMonoid (a × b × c) + diff --git a/lib/base/Haskell/Law/Monoid/List.agda b/lib/base/Haskell/Law/Monoid/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monoid/List.agda @@ -0,0 +1,26 @@ +module Haskell.Law.Monoid.List where + +open import Haskell.Prim +open import Haskell.Prim.List + +open import Haskell.Prim.Monoid + +open import Haskell.Law.List +open import Haskell.Law.Monoid.Def +open import Haskell.Law.Semigroup.Def +open import Haskell.Law.Semigroup.List + +instance + iLawfulMonoidList : IsLawfulMonoid (List a) + iLawfulMonoidList .rightIdentity [] = refl + iLawfulMonoidList .rightIdentity (x ∷ xs) + rewrite ++-[] (x ∷ xs) + = refl + + iLawfulMonoidList .leftIdentity [] = refl + iLawfulMonoidList .leftIdentity (x ∷ xs) = refl + + iLawfulMonoidList .concatenation [] = refl + iLawfulMonoidList .concatenation (x ∷ xs) + rewrite concatenation xs + = refl diff --git a/lib/base/Haskell/Law/Monoid/Maybe.agda b/lib/base/Haskell/Law/Monoid/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Monoid/Maybe.agda @@ -0,0 +1,21 @@ +module Haskell.Law.Monoid.Maybe where + +open import Haskell.Prim +open import Haskell.Prim.Maybe + +open import Haskell.Prim.Monoid + +open import Haskell.Law.Monoid.Def +open import Haskell.Law.Semigroup.Def +open import Haskell.Law.Semigroup.Maybe + +instance + iLawfulMonoidMaybe : ⦃ iMonoidA : Monoid a ⦄ → ⦃ iLawfulMonoidA : IsLawfulMonoid a ⦄ → IsLawfulMonoid (Maybe a) + iLawfulMonoidMaybe .rightIdentity = λ { Nothing → refl; (Just _) → refl } + + iLawfulMonoidMaybe .leftIdentity = λ { Nothing → refl; (Just _) → refl } + + iLawfulMonoidMaybe .concatenation [] = refl + iLawfulMonoidMaybe .concatenation (x ∷ xs) + rewrite (concatenation xs) + = refl diff --git a/lib/base/Haskell/Law/Nat.agda b/lib/base/Haskell/Law/Nat.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Nat.agda @@ -0,0 +1,51 @@ +module Haskell.Law.Nat where + +open import Haskell.Prim +open import Haskell.Prim.Num + +open import Haskell.Law.Def +open import Haskell.Law.Equality + +suc-injective : Injective suc +suc-injective refl = refl + +{-| +The canonical formalization of the +less-than-or-equal-to relation for natural numbers. +-} +data _≤_ : Nat → Nat → Type where + z≤n : ∀ {n} → zero ≤ n + s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n + +≤-refl : ∀ (x : Nat) → x ≤ x +≤-refl zero = z≤n +≤-refl (suc x) = s≤s (≤-refl x) + +≤-antisym : ∀ {x y : Nat} + → x ≤ y + → y ≤ x + ----- + → x ≡ y +≤-antisym z≤n z≤n = refl +≤-antisym (s≤s x≤y) (s≤s y≤x) = cong suc (≤-antisym x≤y y≤x) + +≤-trans : ∀ {x y z : Nat} + → x ≤ y + → y ≤ z + ----- + → x ≤ z +≤-trans z≤n y≤z = z≤n +≤-trans (s≤s x≤y) (s≤s y≤z) = s≤s (≤-trans x≤y y≤z) + +x≤x+1 : ∀ (x : Nat) → x ≤ suc x +x≤x+1 zero = z≤n +x≤x+1 (suc x) = s≤s (x≤x+1 x) + +x+[y-x]≡y : ∀ (x y : Nat) → x ≤ y → x + monusNat y x ≡ y +x+[y-x]≡y zero y x≤y = refl +x+[y-x]≡y (suc x) (suc y) (s≤s x≤y) = cong suc (x+[y-x]≡y x y x≤y) + +y-x≤y : ∀ (x y : Nat) → monusNat y x ≤ y +y-x≤y zero y = ≤-refl y +y-x≤y (suc x) zero = z≤n +y-x≤y (suc x) (suc y) = ≤-trans (y-x≤y x y) (x≤x+1 y) diff --git a/lib/base/Haskell/Law/Num.agda b/lib/base/Haskell/Law/Num.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Num.agda @@ -0,0 +1,7 @@ +module Haskell.Law.Num where + +open import Haskell.Law.Num.Def public +open import Haskell.Law.Num.Int public +open import Haskell.Law.Num.Integer public +open import Haskell.Law.Num.Nat public +open import Haskell.Law.Num.Word public diff --git a/lib/base/Haskell/Law/Num/Def.agda b/lib/base/Haskell/Law/Num/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Num/Def.agda @@ -0,0 +1,125 @@ +module Haskell.Law.Num.Def where + +open import Haskell.Prim +open import Haskell.Prim.Num +open import Haskell.Prim.Integer + +record IsLawfulNum (a : Type) ⦃ iNum : Num a ⦄ : Type₁ where + field + +-assoc : ∀ (x y z : a) → (x + y) + z ≡ x + (y + z) + + +-comm : ∀ (x y : a) → x + y ≡ y + x + + +-idˡ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 0}} + → fromInteger 0 + x ≡ x + +-idʳ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 0}} + → x + fromInteger 0 ≡ x + + neg-inv : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 0}} {{@0 _ : Num.NegateOK iNum x}} + → x + negate x ≡ fromInteger 0 + + *-assoc : ∀ (x y z : a) → (x * y) * z ≡ x * (y * z) + + *-idˡ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 1}} + → fromInteger 1 * x ≡ x + *-idʳ : ∀ (x : a) {{@0 _ : Num.FromIntegerOK iNum 1}} + → x * fromInteger 1 ≡ x + + distributeˡ : ∀ (x y z : a) → x * (y + z) ≡ (x * y) + (x * z) + distributeʳ : ∀ (x y z : a) → (y + z) * x ≡ (y * x) + (z * x) + + -- We are currently missing the following because toInteger is missing in our Prelude. + -- "if the type also implements Integral, then fromInteger is a left inverse for toInteger, i.e. fromInteger (toInteger i) == i" +open IsLawfulNum ⦃ ... ⦄ public + +open import Haskell.Law.Equality +open import Haskell.Law.Function + +{-| +A number homomorphism establishes a homomorphism from one Num type a to another one b. +In particular, zero and one are mapped to zero and one in the other Num type, +and addition, multiplication, and negation are homorphic. +-} +record NumHomomorphism (a b : Type) ⦃ iNuma : Num a ⦄ ⦃ iNumb : Num b ⦄ (φ : a → b) : Type where + 0ᵃ = Num.fromInteger iNuma (pos 0) + 0ᵇ = Num.fromInteger iNumb (pos 0) + 1ᵃ = Num.fromInteger iNuma (pos 1) + 1ᵇ = Num.fromInteger iNumb (pos 1) + + field + +-hom : Homomorphism₂ _+_ _+_ φ + *-hom : Homomorphism₂ _*_ _*_ φ + ⦃ minus-ok ⦄ : ∀ {x y : a} → ⦃ MinusOK x y ⦄ → MinusOK (φ x) (φ y) + ⦃ negate-ok ⦄ : ∀ {x : a} → ⦃ NegateOK x ⦄ → NegateOK (φ x) + ⦃ fromInteger-ok ⦄ : ∀ {i : Integer} → ⦃ Num.FromIntegerOK iNuma i ⦄ → Num.FromIntegerOK iNumb i + 0-hom : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 0) ⦄ → φ 0ᵃ ≡ 0ᵇ + 1-hom : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 1) ⦄ → φ 1ᵃ ≡ 1ᵇ + negate-hom : ∀ (x : a) → ⦃ @0 _ : Num.NegateOK iNuma x ⦄ → φ (negate x) ≡ negate (φ x) --Homomorphism₁ inlined for type instances + +{-| +A number embedding is an invertible number homomorphism. +-} +record NumEmbedding (a b : Type) ⦃ iNuma : Num a ⦄ ⦃ iNumb : Num b ⦄ (φ : a → b) (φ⁻¹ : b → a) : Type where + field + hom : NumHomomorphism a b φ + embed : φ⁻¹ ∘ φ ≗ id + + open NumHomomorphism hom + + +-Embedding₂ : Embedding₂ _+_ _+_ φ φ⁻¹ + Embedding₂.hom +-Embedding₂ = +-hom + Embedding₂.embed +-Embedding₂ = embed + + *-Embedding₂ : Embedding₂ _*_ _*_ φ φ⁻¹ + Embedding₂.hom *-Embedding₂ = *-hom + Embedding₂.embed *-Embedding₂ = embed + + +-MonoidEmbedding₂ : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 0) ⦄ → MonoidEmbedding₂ _+_ _+_ φ φ⁻¹ 0ᵃ 0ᵇ + MonoidEmbedding₂.embedding +-MonoidEmbedding₂ = +-Embedding₂ + MonoidEmbedding₂.0-hom +-MonoidEmbedding₂ = 0-hom + + *-MonoidEmbedding₂ : ⦃ @0 _ : Num.FromIntegerOK iNuma (pos 1) ⦄ → MonoidEmbedding₂ _*_ _*_ φ φ⁻¹ 1ᵃ 1ᵇ + MonoidEmbedding₂.embedding *-MonoidEmbedding₂ = *-Embedding₂ + MonoidEmbedding₂.0-hom *-MonoidEmbedding₂ = 1-hom + +{-| +Given an embedding from one number type a onto another one b, +we can conclude that b satisfies the laws of Num if a satisfies the +laws of Num. +-} +map-IsLawfulNum : ∀ {a b : Type} ⦃ iNuma : Num a ⦄ ⦃ iNumb : Num b ⦄ + → (a2b : a → b) (b2a : b → a) + → NumEmbedding a b a2b b2a + → IsLawfulNum b + ----------------------- + → IsLawfulNum a +map-IsLawfulNum {a} {b} {{numa}} {{numb}} f g proj lawb = + record + { +-assoc = map-assoc _+ᵃ_ _+ᵇ_ f g +-Embedding₂ (+-assoc lawb) + ; +-comm = map-comm _+ᵃ_ _+ᵇ_ f g +-Embedding₂ (+-comm lawb) + ; +-idˡ = λ x → map-idˡ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ +-MonoidEmbedding₂ (λ y → +-idˡ lawb y) x + ; +-idʳ = λ x → map-idʳ _+ᵃ_ _+ᵇ_ f g 0ᵃ 0ᵇ +-MonoidEmbedding₂ (λ y → +-idʳ lawb y) x + ; neg-inv = map-neg-inv + ; *-assoc = map-assoc _*ᵃ_ _*ᵇ_ f g *-Embedding₂ (*-assoc lawb) + ; *-idˡ = λ x → map-idˡ _*ᵃ_ _*ᵇ_ f g 1ᵃ 1ᵇ *-MonoidEmbedding₂ (λ y → *-idˡ lawb y) x + ; *-idʳ = λ x → map-idʳ _*ᵃ_ _*ᵇ_ f g 1ᵃ 1ᵇ *-MonoidEmbedding₂ (λ y → *-idʳ lawb y) x + ; distributeˡ = map-distributeˡ _+ᵃ_ _+ᵇ_ _*ᵃ_ _*ᵇ_ f g embed +-hom *-hom (distributeˡ lawb) + ; distributeʳ = map-distributeʳ _+ᵃ_ _+ᵇ_ _*ᵃ_ _*ᵇ_ f g embed +-hom *-hom (distributeʳ lawb) + } + where + open NumEmbedding proj + open NumHomomorphism hom + open IsLawfulNum lawb + open Num numa renaming (_+_ to _+ᵃ_; _*_ to _*ᵃ_; negate to negateᵃ) + open Num numb renaming (_+_ to _+ᵇ_; _*_ to _*ᵇ_; negate to negateᵇ) + + map-neg-inv : ∀ (x : a) ⦃ @0 _ : Num.FromIntegerOK numa (pos 0) ⦄ ⦃ @0 _ : Num.NegateOK numa x ⦄ + → x +ᵃ negateᵃ x ≡ 0ᵃ + map-neg-inv x = + x +ᵃ negateᵃ x ≡˘⟨ embed (x +ᵃ negateᵃ x) ⟩ + g (f (x +ᵃ negateᵃ x)) ≡⟨ cong g (+-hom x (negateᵃ x)) ⟩ + g (f x +ᵇ f (negateᵃ x)) ≡⟨ cong g (cong (f x +ᵇ_) (negate-hom x)) ⟩ + g (f x +ᵇ negateᵇ (f x)) ≡⟨ cong g (neg-inv lawb (f x)) ⟩ + g 0ᵇ ≡˘⟨ cong g 0-hom ⟩ + g (f 0ᵃ) ≡⟨ embed 0ᵃ ⟩ + 0ᵃ ∎ diff --git a/lib/base/Haskell/Law/Num/Int.agda b/lib/base/Haskell/Law/Num/Int.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Num/Int.agda @@ -0,0 +1,27 @@ +module Haskell.Law.Num.Int where + +open import Haskell.Prim using (refl; tt) +open import Haskell.Prim.Num +open import Haskell.Prim.Int +open import Haskell.Prim.Word + +open import Haskell.Law.Num.Def +open import Haskell.Law.Num.Word + +instance + open NumHomomorphism + open NumEmbedding + + iNumEmbeddingIntWord : NumEmbedding Int Word intToWord int64 + +-hom (hom iNumEmbeddingIntWord) (int64 _) (int64 _) = refl + *-hom (hom iNumEmbeddingIntWord) (int64 _) (int64 _) = refl + minus-ok (hom iNumEmbeddingIntWord) = tt + negate-ok (hom iNumEmbeddingIntWord) = tt + fromInteger-ok (hom iNumEmbeddingIntWord) = tt + 0-hom (hom iNumEmbeddingIntWord) = refl + 1-hom (hom iNumEmbeddingIntWord) = refl + negate-hom (hom iNumEmbeddingIntWord) (int64 _) = refl + embed iNumEmbeddingIntWord (int64 _) = refl + + iLawfulNumInt : IsLawfulNum Int + iLawfulNumInt = map-IsLawfulNum intToWord int64 iNumEmbeddingIntWord iLawfulNumWord diff --git a/lib/base/Haskell/Law/Num/Integer.agda b/lib/base/Haskell/Law/Num/Integer.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Num/Integer.agda @@ -0,0 +1,297 @@ +module Haskell.Law.Num.Integer where + +open import Haskell.Prim +open import Haskell.Prim.Num +open import Haskell.Prim.Integer + +open import Haskell.Law.Equality +open import Haskell.Law.Num.Def +open import Haskell.Law.Num.Nat + +-- Open the internal definitions because +-- these must be transparent for proofs. +open Haskell.Prim.Integer.Internal + +addInteger-idˡ : ∀ (x : Integer) → 0 + x ≡ x +addInteger-idˡ (pos _) = refl +addInteger-idˡ (negsuc _) = cong negsuc refl + +addInteger-idʳ : ∀ (x : Integer) → x + 0 ≡ x +addInteger-idʳ (pos n) = cong pos $ addNat-idʳ n +addInteger-idʳ (negsuc _) = cong negsuc refl + +mulInteger-idˡ : ∀ (x : Integer) → 1 * x ≡ x +mulInteger-idˡ (pos x) = cong pos (addNat-idʳ x) +mulInteger-idˡ (negsuc x) = cong negsuc (addNat-idʳ x) + +mulInteger-idʳ : ∀ (x : Integer) → x * 1 ≡ x +mulInteger-idʳ (pos x) = cong pos (mulNat-idʳ x) +mulInteger-idʳ (negsuc x) = cong negsuc (mulNat-idʳ x) + +subNat-refl : ∀ (x : Nat) → subNat x x ≡ 0 +subNat-refl zero = refl +subNat-refl (suc x) = subNat-refl x + +n-n≡0-Nat : ∀ (x y : Nat) → subNat (x + y) x ≡ pos y +n-n≡0-Nat x zero rewrite addNat-idʳ x = subNat-refl x +n-n≡0-Nat zero (suc _) = refl +n-n≡0-Nat (suc x) (suc y) = n-n≡0-Nat x (suc y) + +n-n≡0-Integer : ∀ (x : Integer) → x + (negateInteger x) ≡ 0 +n-n≡0-Integer (pos zero) = refl +n-n≡0-Integer (pos (suc x)) = subNat-refl x +n-n≡0-Integer (negsuc x) = subNat-refl x + +mulInteger-zeroˡ : ∀ (x : Integer) → 0 * x ≡ 0 +mulInteger-zeroˡ (pos _) = refl +mulInteger-zeroˡ (negsuc _) = refl + +mulInteger-zeroʳ : ∀ (x : Integer) → x * 0 ≡ 0 +mulInteger-zeroʳ (pos n) = cong pos (mulNat-zeroʳ n) +mulInteger-zeroʳ (negsuc n) rewrite mulNat-zeroʳ n = refl + +addInteger-comm : ∀ (x y : Integer) → x + y ≡ y + x +addInteger-comm (pos x) (pos y) = cong pos (addNat-comm x y) +addInteger-comm (pos _) (negsuc _) = refl +addInteger-comm (negsuc _) (pos _) = refl +addInteger-comm (negsuc x) (negsuc y) = cong negsuc (cong suc (addNat-comm x y)) + +subNat|x-[y+z]≡x-y-z : ∀ (x y z : Nat) → subNat x (y + suc z) ≡ subNat x y + negsuc z +subNat|x-[y+z]≡x-y-z _ zero _ = refl +subNat|x-[y+z]≡x-y-z zero (suc y) z = cong negsuc (addNat-suc y z) +subNat|x-[y+z]≡x-y-z (suc x) (suc y) z = subNat|x-[y+z]≡x-y-z x y z + +subNat|x-y+z≡[x+z]-y : ∀ (x y z : Nat) → subNat x y + pos (suc z) ≡ subNat (x + suc z) y +subNat|x-y+z≡[x+z]-y _ zero _ = refl +subNat|x-y+z≡[x+z]-y zero (suc _) _ = refl +subNat|x-y+z≡[x+z]-y (suc x) (suc y) z = subNat|x-y+z≡[x+z]-y x y z + +subNat-cong-suc : ∀ (x y : Nat) → subNat (suc x) y ≡ pos 1 + subNat x y +subNat-cong-suc _ zero = refl +subNat-cong-suc zero (suc _) = refl +subNat-cong-suc (suc x) (suc y) = subNat-cong-suc x y + +subNat|x+[y-z]≡[1+x]+[y-[1+z]] : ∀ (x y z : Nat) → pos x + subNat y z ≡ pos (suc x) + subNat y (suc z) +subNat|x+[y-z]≡[1+x]+[y-[1+z]] x zero zero = cong pos (addNat-idʳ x) +subNat|x+[y-z]≡[1+x]+[y-[1+z]] x (suc y) zero = cong pos (addNat-suc x y) +subNat|x+[y-z]≡[1+x]+[y-[1+z]] _ zero (suc _) = refl +subNat|x+[y-z]≡[1+x]+[y-[1+z]] x (suc y) (suc z) = subNat|x+[y-z]≡[1+x]+[y-[1+z]] x y z + +subNat|x-y+[1+z]≡[1+x]+[z-y] : ∀ (x y z : Nat) → subNat x y + pos (suc z) ≡ pos (suc x) + subNat z y +subNat|x-y+[1+z]≡[1+x]+[z-y] x zero z = cong pos (addNat-suc x z) +subNat|x-y+[1+z]≡[1+x]+[z-y] zero (suc _) zero = refl +subNat|x-y+[1+z]≡[1+x]+[z-y] zero (suc y) (suc z) = subNat-cong-suc z y +subNat|x-y+[1+z]≡[1+x]+[z-y] (suc x) (suc y) z = + subNat x y + pos (suc z) ≡⟨ subNat|x-y+[1+z]≡[1+x]+[z-y] x y z ⟩ + pos (suc x) + subNat z y ≡⟨ subNat|x+[y-z]≡[1+x]+[y-[1+z]] (suc x) z y ⟩ + pos (suc (suc x)) + subNat z (suc y) ∎ + +subNat|[1+x+y]-z≡[1+x]+[y-z] : ∀ (x y z : Nat) → subNat (suc x + y) z ≡ pos (suc x) + subNat y z +subNat|[1+x+y]-z≡[1+x]+[y-z] _ _ zero = refl +subNat|[1+x+y]-z≡[1+x]+[y-z] x zero (suc z) = cong (λ eq → subNat eq z) (addNat-idʳ x) +subNat|[1+x+y]-z≡[1+x]+[y-z] x (suc y) (suc z) = + subNat (x + suc y) z ≡⟨ sym (subNat|x-y+z≡[x+z]-y x z y) ⟩ + subNat x z + pos (suc y) ≡⟨ subNat|x-y+[1+z]≡[1+x]+[z-y] x z y ⟩ + pos (suc x) + subNat y z ∎ + +subNat|x-y+[-[1+z]]≡x-z+[-[1+y]] : ∀ (x y z : Nat) → subNat x y + negsuc z ≡ subNat x z + negsuc y +subNat|x-y+[-[1+z]]≡x-z+[-[1+y]] x y z = begin + subNat x y + negsuc z ≡⟨ sym (subNat|x-[y+z]≡x-y-z x y z) ⟩ + subNat x (y + suc z) ≡⟨ cong (subNat x) (addNat-comm y (suc z)) ⟩ + subNat x (suc z + y) ≡⟨ cong (subNat x) (sym (addNat-suc z y)) ⟩ + subNat x (z + suc y) ≡⟨ subNat|x-[y+z]≡x-y-z x z y ⟩ + subNat x z + negsuc y ∎ + +subNat-cong-+ : ∀ (x y z : Nat) → subNat (x + y) (x + z) ≡ subNat y z +subNat-cong-+ x y zero rewrite addNat-idʳ x = n-n≡0-Nat x y +subNat-cong-+ zero _ (suc _) = refl +subNat-cong-+ (suc x) y (suc z) = subNat-cong-+ x y (suc z) + +subNat-distrib-minus : ∀ (m n o : Nat) → subNat n o * pos m ≡ subNat (n * m) (o * m) +subNat-distrib-minus _ _ zero = refl +subNat-distrib-minus zero zero (suc o) rewrite mulNat-zeroʳ o = refl +subNat-distrib-minus (suc _) zero (suc _) = refl +subNat-distrib-minus zero (suc n) (suc o) rewrite mulNat-zeroʳ o | mulInteger-zeroʳ (subNat n o) | mulNat-zeroʳ n = refl +subNat-distrib-minus (suc m) (suc n) (suc o) = + subNat n o * (pos (suc m)) ≡⟨ subNat-distrib-minus (suc m) n o ⟩ + subNat (n * suc m) (o * suc m) ≡⟨ sym (subNat-cong-+ m (n * suc m) (o * suc m)) ⟩ + subNat (m + (n * suc m)) (m + (o * suc m)) ∎ + +subNat-mult-flip-negsuc : ∀ (m n o : Nat) → subNat o n * negsuc m ≡ subNat n o * pos (suc m) +subNat-mult-flip-negsuc _ zero zero = refl +subNat-mult-flip-negsuc _ zero (suc _) = refl +subNat-mult-flip-negsuc _ (suc _) zero = refl +subNat-mult-flip-negsuc m (suc n) (suc o) = subNat-mult-flip-negsuc m n o + +subNat-distrib-minus-cong-+ : ∀ (m n o : Nat) → subNat o n * (pos (suc m)) ≡ subNat (m + (o * suc m)) (m + (n * suc m)) +subNat-distrib-minus-cong-+ m n o = begin + subNat o n * (pos (suc m)) ≡⟨ subNat-distrib-minus (suc m) o n ⟩ + subNat (o * suc m) (n * suc m) ≡⟨ sym (subNat-cong-+ m (o * suc m) (n * suc m)) ⟩ + subNat (m + (o * suc m)) (m + (n * suc m)) ∎ + + +addInteger-assoc : ∀ (x y z : Integer) → (x + y) + z ≡ x + (y + z) +addInteger-assoc (pos zero) j k rewrite addInteger-idˡ j | addInteger-idˡ (j + k) = refl +addInteger-assoc i (pos zero) k rewrite addInteger-idʳ i | addInteger-idˡ k = refl +addInteger-assoc i j (pos zero) rewrite addInteger-idʳ (i + j) | addInteger-idʳ j = refl +addInteger-assoc (negsuc m) (negsuc n) (pos (suc o)) = + (negsuc m + negsuc n) + pos (suc o) ≡⟨⟩ + negsuc (suc (m + n)) + pos (suc o) ≡⟨⟩ + subNat o (suc m + n) ≡⟨ cong (subNat o) (addNat-comm (suc m) n) ⟩ + subNat o (n + suc m) ≡⟨ subNat|x-[y+z]≡x-y-z o n m ⟩ + subNat o n + negsuc m ≡⟨ addInteger-comm (subNat o n) (negsuc m) ⟩ + negsuc m + subNat o n ≡⟨⟩ + negsuc m + (negsuc n + pos (suc o)) ∎ +addInteger-assoc (negsuc m) (pos (suc n)) (pos (suc o)) = + (negsuc m + pos (suc n)) + pos (suc o) ≡⟨⟩ + subNat n m + pos (suc o) ≡⟨ subNat|x-y+z≡[x+z]-y n m o ⟩ + subNat (n + suc o) m ≡⟨⟩ + negsuc m + pos (suc (n + suc o)) ≡⟨⟩ + negsuc m + (pos (suc n) + pos (suc o)) ∎ +addInteger-assoc (pos (suc m)) (negsuc n) (negsuc o) = + (pos (suc m) + negsuc n) + negsuc o ≡⟨⟩ + subNat m n + negsuc o ≡⟨ sym $ subNat|x-[y+z]≡x-y-z m n o ⟩ + subNat m (n + suc o) ≡⟨ cong (subNat m) (addNat-suc n o) ⟩ + subNat m (suc (n + o)) ≡⟨⟩ + pos (suc m) + (negsuc (suc (n + o))) ≡⟨⟩ + pos (suc m) + (negsuc n + negsuc o) ∎ +addInteger-assoc (pos (suc m)) (negsuc n) (pos (suc o)) = + (pos (suc m) + negsuc n) + pos (suc o) ≡⟨⟩ + subNat m n + pos (suc o) ≡⟨ subNat|x-y+[1+z]≡[1+x]+[z-y] m n o ⟩ + pos (suc m) + subNat o n ≡⟨⟩ + pos (suc m) + (negsuc n + pos (suc o)) ∎ +addInteger-assoc (pos (suc x)) (pos (suc y)) (negsuc z) = begin + (pos (suc x) + pos (suc y)) + negsuc z ≡⟨⟩ + pos (suc (x + (suc y))) + negsuc z ≡⟨ cong (_+ negsuc z) (cong pos (cong suc (addNat-suc x y))) ⟩ + pos (suc (suc (x + y))) + negsuc z ≡⟨⟩ + subNat (suc (x + y)) z ≡⟨⟩ + subNat (suc x + y) z ≡⟨ subNat|[1+x+y]-z≡[1+x]+[y-z] x y z ⟩ + pos (suc x) + subNat y z ≡⟨⟩ + pos (suc x) + (pos (suc y) + negsuc z) ∎ +addInteger-assoc (negsuc m) (negsuc n) (negsuc o) = cong negsuc $ cong suc $ + suc ((m + n) + o) ≡⟨ cong suc (addNat-assoc m n o) ⟩ + suc (m + (n + o)) ≡⟨ sym (addNat-suc m (n + o)) ⟩ + m + (suc (n + o)) ∎ +addInteger-assoc (negsuc m) (pos (suc n)) (negsuc o) = + (negsuc m + pos (suc n)) + negsuc o ≡⟨⟩ + subNat n m + negsuc o ≡⟨ subNat|x-y+[-[1+z]]≡x-z+[-[1+y]] n m o ⟩ + subNat n o + negsuc m ≡⟨ addInteger-comm (subNat n o) (negsuc m) ⟩ + negsuc m + subNat n o ≡⟨⟩ + negsuc m + (pos (suc n) - pos (suc o)) ∎ +addInteger-assoc (pos (suc m)) (pos (suc n)) (pos (suc o)) = cong pos (addNat-assoc (suc m) (suc n) (suc o)) + +distribute-1ˡ : ∀ (x y : Nat) → x * (1 + y) ≡ x + (y * x) +distribute-1ˡ x y = begin + x * (suc y) ≡⟨ mulNat-suc x y ⟩ + x + (x * y) ≡⟨ cong (x +_) (mulNat-comm x y) ⟩ + x + (y * x) ∎ + +mulInteger-comm : ∀ (x y : Integer) → x * y ≡ y * x +mulInteger-comm (pos x) (pos y) = cong pos (mulNat-comm x y) +mulInteger-comm (pos x) (negsuc y) = cong negNat $ distribute-1ˡ x y +mulInteger-comm (negsuc x) (pos y) = cong negNat $ sym $ distribute-1ˡ y x +mulInteger-comm (negsuc x) (negsuc y) = cong pos $ cong suc $ + y + (x * (suc y)) ≡⟨ cong (y +_) (distribute-1ˡ x y) ⟩ + y + (x + (y * x)) ≡⟨ cong (y +_) (cong (x +_) (mulNat-comm y x)) ⟩ + y + (x + (x * y)) ≡⟨ sym (addNat-assoc y x (x * y)) ⟩ + (y + x) + (x * y) ≡⟨ cong (_+ x * y) (addNat-comm y x) ⟩ + (x + y) + (x * y) ≡⟨ addNat-assoc x y (x * y) ⟩ + x + (y + (x * y)) ≡⟨ cong (x +_) (sym (distribute-1ˡ y x)) ⟩ + x + (y * (suc x)) ∎ + +distrib-lemma : ∀ (m n o : Nat) → suc (m + ((n + o) * suc m)) ≡ (n * suc m) + (suc (m + (o * suc m))) +distrib-lemma m n o = + suc (m + ((n + o) * suc m)) ≡⟨ cong suc (cong (m +_) (mulNat-distributeʳ-addNat (suc m) n o)) ⟩ + suc (m + ((n * suc m) + (o * suc m))) ≡⟨⟩ + suc m + ((n * suc m) + (o * suc m)) ≡⟨ sym (addNat-assoc (suc m) (n * suc m) (o * suc m) ) ⟩ + (suc m + (n * suc m)) + (o * suc m) ≡⟨ cong (_+ o * suc m) (addNat-comm (suc m) (n * suc m)) ⟩ + ((n * suc m) + suc m) + (o * suc m) ≡⟨ addNat-assoc (n * suc m) (suc m) (o * suc m) ⟩ + (n * suc m) + (suc (m + (o * suc m))) ∎ + +distrib-lemma2 : ∀ (m n o : Nat) → m + ((n * suc m) + (suc m + (o * suc m))) ≡ suc ((m + (n * suc m)) + (m + (o * suc m))) +distrib-lemma2 m n o = + m + ( (n * suc m) + (suc m + (o * suc m))) ≡⟨⟩ + m + ( (n * suc m) + suc (m + (o * suc m))) ≡⟨ sym (addNat-assoc m (n * suc m) (suc (m + (o * suc m)))) ⟩ + (m + (n * suc m)) + suc (m + (o * suc m)) ≡⟨ addNat-suc (m + (n * suc m)) (m + (o * suc m)) ⟩ + suc ((m + (n * suc m)) + (m + (o * suc m))) ∎ + +mulInteger-distributeʳ-addInteger : ∀ (x y z : Integer) → (y + z) * x ≡ (y * x) + (z * x) +mulInteger-distributeʳ-addInteger (pos zero) j k rewrite mulInteger-zeroʳ j | mulInteger-zeroʳ k | mulInteger-zeroʳ (j + k) = refl +mulInteger-distributeʳ-addInteger i (pos zero) k rewrite addInteger-idˡ k | mulInteger-zeroˡ i | addInteger-idˡ (k * i) = refl +mulInteger-distributeʳ-addInteger i j (pos zero) rewrite addInteger-idʳ j | mulInteger-zeroˡ i | addInteger-idʳ (j * i) = refl +mulInteger-distributeʳ-addInteger (negsuc m) (negsuc n) (pos (suc o)) = begin + subNat o n * negsuc m ≡⟨ subNat-mult-flip-negsuc m n o ⟩ + subNat n o * pos (suc m) ≡⟨ subNat-distrib-minus-cong-+ m o n ⟩ + subNat (m + (n * suc m)) (m + (o * suc m)) ∎ +mulInteger-distributeʳ-addInteger (negsuc m) (pos (suc n)) (pos (suc o)) = cong negsuc $ begin + m + ((n + suc o) * suc m) ≡⟨ cong (m +_) (mulNat-distributeʳ-addNat (suc m) n (suc o)) ⟩ + m + ( (n * suc m) + (suc m + (o * suc m))) ≡⟨ distrib-lemma2 m n o ⟩ + suc ((m + (n * suc m)) + (m + (o * suc m))) ∎ -- Y +mulInteger-distributeʳ-addInteger (pos (suc m)) (negsuc n) (negsuc o) = cong negsuc $ begin + m + (suc (m + ((n + o) * suc m))) ≡⟨⟩ + m + (suc m + ((n + o) * suc m)) ≡⟨ cong (m +_) (distrib-lemma m n o) ⟩ + m + ( (n * suc m) + (suc m + (o * suc m))) ≡⟨ distrib-lemma2 m n o ⟩ + suc ((m + (n * suc m)) + (m + (o * suc m))) ∎ -- Y +mulInteger-distributeʳ-addInteger (pos (suc m)) (negsuc n) (pos (suc o)) = subNat-distrib-minus-cong-+ m n o +mulInteger-distributeʳ-addInteger (pos (suc m)) (pos (suc n)) (negsuc o) = subNat-distrib-minus-cong-+ m o n +mulInteger-distributeʳ-addInteger (negsuc m) (negsuc n) (negsuc o) = cong pos $ cong suc $ + m + (suc (m + ((n + o) * suc m))) ≡⟨⟩ + m + (suc m + ((n + o) * suc m)) ≡⟨ cong (m +_) (distrib-lemma m n o) ⟩ + m + ((n * suc m) + (suc m + (o * suc m))) ≡⟨ sym (addNat-assoc m (n * suc m) (suc m + (o * suc m))) ⟩ + (m + (n * suc m)) + (suc (m + (o * suc m))) ∎ -- X +mulInteger-distributeʳ-addInteger (negsuc m) (pos (suc n)) (negsuc o) = + subNat n o * negsuc m ≡⟨ subNat-mult-flip-negsuc m o n ⟩ + subNat o n * pos (suc m) ≡⟨ subNat-distrib-minus-cong-+ m n o ⟩ + subNat (m + (o * suc m)) (m + (n * suc m)) ∎ +mulInteger-distributeʳ-addInteger (pos (suc m)) (pos (suc n)) (pos (suc o)) = cong pos $ cong suc $ + m + ((n + suc o) * suc m) ≡⟨ cong (m +_) (mulNat-distributeʳ-addNat (suc m) n (suc o)) ⟩ + m + ((n * suc m) + (suc m + (o * suc m))) ≡⟨ sym (addNat-assoc m (n * suc m) (suc m + (o * suc m))) ⟩ + (m + (n * suc m)) + (suc m + (o * suc m)) ≡⟨⟩ + (m + (n * suc m)) + (suc (m + (o * suc m))) ∎ -- X + +mulInteger-distributeˡ-addInteger : ∀ (x y z : Integer) → x * (y + z) ≡ (x * y) + (x * z) +mulInteger-distributeˡ-addInteger x y z + -- This proof works the very same as addNat-distributeˡ-mulNat. + rewrite (mulInteger-comm x (y + z)) -- makes or goal become: (y + z) * x ≡ (x * y) + (x * z) + rewrite (mulInteger-comm x y) -- makes or goal become: (y + z) * x ≡ (y * x) + (x * z) + rewrite (mulInteger-comm x z) -- makes or goal become: (y + z) * x ≡ (y * x) + (z * x) + = mulInteger-distributeʳ-addInteger x y z + +mulInteger-assoc-lemma-2 : ∀ (m n o : Nat) → (n + m * suc n) * suc o ≡ (n * suc o) + (m * suc (o + (n * suc o))) +mulInteger-assoc-lemma-2 m n o = begin + (n + (m * suc n)) * (suc o) ≡⟨ mulNat-distributeʳ-addNat (suc o) n (m * suc n) ⟩ + (n * (suc o)) + ((m * suc n) * (suc o)) ≡⟨ cong (n * suc o +_) (mulNat-assoc m (suc n) (suc o)) ⟩ + (n * suc o) + (m * suc (o + (n * suc o))) ∎ + +mulInteger-assoc-lemma : ∀ (m n o : Nat) + → o + ((n + m * suc n) * suc o) ≡ (o + (n * suc o)) + (m * suc (o + (n * suc o))) +mulInteger-assoc-lemma m n o = begin + o + ((n + m * suc n) * suc o) ≡⟨ cong (o +_) (mulInteger-assoc-lemma-2 m n o) ⟩ + o + ((n * suc o) + (m * suc (o + (n * suc o)))) ≡⟨ sym (addNat-assoc o (n * suc o) (m * suc (o + (n * suc o)))) ⟩ + (o + (n * suc o)) + (m * suc (o + (n * suc o))) ∎ + +mulInteger-assoc : ∀ (x y z : Integer) → (x * y) * z ≡ x * (y * z) +mulInteger-assoc (pos zero) j k rewrite mulInteger-zeroˡ j | mulInteger-zeroˡ k | mulInteger-zeroˡ (j * k) = refl +mulInteger-assoc i (pos zero) k rewrite mulInteger-zeroʳ i | mulInteger-zeroˡ k | mulInteger-zeroʳ i = refl +mulInteger-assoc i j (pos zero) rewrite mulInteger-zeroʳ j | mulInteger-zeroʳ i | mulInteger-zeroʳ (i * j) = refl +mulInteger-assoc (negsuc m) (negsuc n) (pos (suc o)) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) +mulInteger-assoc (negsuc m) (pos (suc n)) (pos (suc o)) = cong negsuc (mulInteger-assoc-lemma m n o) +mulInteger-assoc (pos (suc m)) (negsuc n) (negsuc o) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) +mulInteger-assoc (pos (suc m)) (negsuc n) (pos (suc o)) = cong negsuc (mulInteger-assoc-lemma m n o) +mulInteger-assoc (pos (suc m)) (pos (suc n)) (negsuc o) = cong negsuc (mulInteger-assoc-lemma m n o) +mulInteger-assoc (negsuc m) (negsuc n) (negsuc o) = cong negsuc (mulInteger-assoc-lemma m n o) +mulInteger-assoc (negsuc m) (pos (suc n)) (negsuc o) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) +mulInteger-assoc (pos (suc m)) (pos (suc n)) (pos (suc o)) = cong pos (cong suc (mulInteger-assoc-lemma m n o)) + +instance + iLawfulNumInteger : IsLawfulNum Integer + iLawfulNumInteger .IsLawfulNum.+-assoc = addInteger-assoc + iLawfulNumInteger .IsLawfulNum.+-comm = addInteger-comm + iLawfulNumInteger .IsLawfulNum.+-idˡ x = addInteger-idˡ x + iLawfulNumInteger .IsLawfulNum.+-idʳ x = addInteger-idʳ x + iLawfulNumInteger .IsLawfulNum.neg-inv x = n-n≡0-Integer x + iLawfulNumInteger .IsLawfulNum.*-assoc = mulInteger-assoc + iLawfulNumInteger .IsLawfulNum.*-idˡ x = mulInteger-idˡ x + iLawfulNumInteger .IsLawfulNum.*-idʳ x = mulInteger-idʳ x + iLawfulNumInteger .IsLawfulNum.distributeˡ = mulInteger-distributeˡ-addInteger + iLawfulNumInteger .IsLawfulNum.distributeʳ = mulInteger-distributeʳ-addInteger diff --git a/lib/base/Haskell/Law/Num/Nat.agda b/lib/base/Haskell/Law/Num/Nat.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Num/Nat.agda @@ -0,0 +1,103 @@ +module Haskell.Law.Num.Nat where + +open import Haskell.Prim +open import Haskell.Prim.Num + +open import Haskell.Law.Equality +open import Haskell.Law.Num.Def + +addNat-suc : ∀ m n → m + suc n ≡ suc (m + n) +addNat-suc zero n = refl +addNat-suc (suc m) n = cong suc (addNat-suc m n) + +addNat-idˡ : ∀ (x : Nat) → 0 + x ≡ x +addNat-idˡ _ = refl + +addNat-idʳ : ∀ (x : Nat) → x + 0 ≡ x +addNat-idʳ zero = refl +addNat-idʳ (suc x) = cong suc (addNat-idʳ x) + +addNat-comm : ∀ (x y : Nat) → x + y ≡ y + x +addNat-comm zero y = sym (addNat-idʳ y) +addNat-comm (suc x) y = begin + suc (x + y) ≡⟨ cong suc (addNat-comm x y) ⟩ + suc (y + x) ≡⟨ sym (addNat-suc y x) ⟩ + y + suc x ∎ + +addNat-assoc : ∀ (x y z : Nat) → (x + y) + z ≡ x + (y + z) +addNat-assoc zero _ _ = refl +addNat-assoc (suc m) n o = cong suc (addNat-assoc m n o) + +mulNat-suc : ∀ (m n : Nat) → m * suc n ≡ m + m * n +mulNat-suc zero n = refl +mulNat-suc (suc m) n = begin + suc m * suc n ≡⟨⟩ + suc n + m * suc n ≡⟨ cong (suc n +_) (mulNat-suc m n) ⟩ + suc n + (m + m * n) ≡⟨⟩ + suc (n + (m + m * n)) ≡⟨ cong suc (sym (addNat-assoc n m (m * n))) ⟩ + suc (n + m + m * n) ≡⟨ cong (λ x → suc (x + m * n)) (addNat-comm n m) ⟩ + suc (m + n + m * n) ≡⟨ cong suc (addNat-assoc m n (m * n)) ⟩ + suc (m + (n + m * n)) ≡⟨⟩ + suc m + suc m * n ∎ + +mulNat-idˡ : ∀ (x : Nat) → 1 * x ≡ x +mulNat-idˡ = addNat-idʳ + +mulNat-idʳ : ∀ (x : Nat) → x * 1 ≡ x +mulNat-idʳ zero = refl +mulNat-idʳ (suc x) = cong suc (mulNat-idʳ x) + +mulNat-zeroˡ : ∀ (x : Nat) → 0 * x ≡ 0 +mulNat-zeroˡ _ = refl + +mulNat-zeroʳ : ∀ (x : Nat) → x * 0 ≡ 0 +mulNat-zeroʳ zero = refl +mulNat-zeroʳ (suc x) = mulNat-zeroʳ x + +mulNat-comm : ∀ (x y : Nat) → x * y ≡ y * x +mulNat-comm zero y = sym (mulNat-zeroʳ y) +mulNat-comm (suc x) y = begin + suc x * y ≡⟨⟩ + y + x * y ≡⟨ cong (y +_) (mulNat-comm x y) ⟩ + y + y * x ≡⟨ sym (mulNat-suc y x) ⟩ + y * suc x ∎ + +mulNat-distributeʳ-addNat : ∀ (x y z : Nat) → (y + z) * x ≡ (y * x) + (z * x) +mulNat-distributeʳ-addNat _ zero _ = refl +mulNat-distributeʳ-addNat x (suc y) z = begin + (suc y + z) * x ≡⟨⟩ + x + (y + z) * x ≡⟨ cong (x +_) (mulNat-distributeʳ-addNat x y z) ⟩ + x + (y * x + z * x) ≡⟨ sym (addNat-assoc x (y * x) (z * x)) ⟩ + x + y * x + z * x ≡⟨⟩ + suc y * x + z * x ∎ + +mulNat-distributeˡ-addNat : ∀ (x y z : Nat) → x * (y + z) ≡ (x * y) + (x * z) +mulNat-distributeˡ-addNat x y z + -- This proof transform left distribution to right distribution by using commutativity of *. + -- the initial goal is: x * (y + z) ≡ (x * y) + (x * z) + rewrite (mulNat-comm x (y + z)) -- makes or goal become: (y + z) * x ≡ (x * y) + (x * z) + rewrite (mulNat-comm x y) -- makes or goal become: (y + z) * x ≡ (y * x) + (x * z) + rewrite (mulNat-comm x z) -- makes or goal become: (y + z) * x ≡ (y * x) + (z * x) + = mulNat-distributeʳ-addNat x y z + +mulNat-assoc : ∀ (x y z : Nat) → (x * y) * z ≡ x * (y * z) +mulNat-assoc zero _ _ = refl +mulNat-assoc (suc x) y z = begin + (suc x * y) * z ≡⟨⟩ + (y + x * y) * z ≡⟨ mulNat-distributeʳ-addNat z y (x * y) ⟩ + y * z + (x * y) * z ≡⟨ cong (y * z +_) (mulNat-assoc x y z) ⟩ + y * z + x * (y * z) ≡⟨⟩ + suc x * (y * z) ∎ + +instance + iLawfulNumNat : IsLawfulNum Nat + iLawfulNumNat .IsLawfulNum.+-assoc = addNat-assoc + iLawfulNumNat .IsLawfulNum.+-comm = addNat-comm + iLawfulNumNat .IsLawfulNum.+-idˡ x = addNat-idˡ x + iLawfulNumNat .IsLawfulNum.+-idʳ x = addNat-idʳ x + iLawfulNumNat .IsLawfulNum.neg-inv zero = refl -- inline this proof because it has not much use anyway I guess? + iLawfulNumNat .IsLawfulNum.*-assoc = mulNat-assoc + iLawfulNumNat .IsLawfulNum.*-idˡ x = mulNat-idˡ x + iLawfulNumNat .IsLawfulNum.*-idʳ x = mulNat-idʳ x + iLawfulNumNat .IsLawfulNum.distributeˡ = mulNat-distributeˡ-addNat + iLawfulNumNat .IsLawfulNum.distributeʳ = mulNat-distributeʳ-addNat diff --git a/lib/base/Haskell/Law/Num/Word.agda b/lib/base/Haskell/Law/Num/Word.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Num/Word.agda @@ -0,0 +1,106 @@ +{-# OPTIONS --allow-unsolved-metas #-} +module Haskell.Law.Num.Word where + +open import Haskell.Prim +open import Haskell.Prim.Num +open import Haskell.Prim.Word +open Haskell.Prim.Word.WordInternal + +open import Haskell.Law.Equality +open import Haskell.Law.Function +open import Haskell.Law.Nat + +open import Haskell.Law.Num.Def +open import Haskell.Law.Num.Nat + +open Num iNumNat renaming (_+_ to _+ⁿ_; _*_ to _*ⁿ_) +open Num iNumWord renaming (_+_ to _+ʷ_; _*_ to _*ʷ_) + +postulate + -- This is a reasonable axiom because there are more natural numbers than + -- integer. More precisely, Words denote a finite subset of Integers. + -- This means, there is am embedding of Words into Integers as stated by + -- this axiom. + n2w∘w2n≡id : ∀ (x : Word) → n2w (w2n x) ≡ x + + -- Conversion of natural numbers to words is invertible as long as the + -- natural is within word bounds. + w2n∘n2w≡id : ∀ (x : Nat) → x ≤ 2⁶⁴ → w2n (n2w x) ≡ x + + -- Definitions of word arithmetics are based on conversions to Nats. + -- That conversion must be homomorphic w.r.t. to addition and multiplication + -- to not break their properties. + w2n-+-hom : Homomorphism₂ _+ʷ_ _+ⁿ_ w2n + w2n-*-hom : Homomorphism₂ _*ʷ_ _*ⁿ_ w2n + + -- 2⁶⁴ is the upper bound of the ring that forms Words in Nats. + max-int≡0 : n2w 2⁶⁴ ≡ 0 + + -- Words are bounded. They can never be larger than 2⁶⁴. + bounded : ∀ (x : Word) → w2n x ≤ 2⁶⁴ + +open MonoidEmbedding₂ + ++-wordsAsNats : MonoidEmbedding₂ addWord addNat w2n n2w 0 0 +Embedding₂.hom (embedding +-wordsAsNats) = w2n-+-hom +Embedding₂.embed (embedding +-wordsAsNats) = n2w∘w2n≡id +0-hom +-wordsAsNats = refl + +*-wordsAsNats : MonoidEmbedding₂ mulWord mulNat w2n n2w 1 1 +Embedding₂.hom (embedding *-wordsAsNats) = w2n-*-hom +Embedding₂.embed (embedding *-wordsAsNats) = n2w∘w2n≡id +0-hom *-wordsAsNats = refl + +addWord-idˡ : Identityˡ addWord 0 +addWord-idˡ = map-idˡ addWord addNat w2n n2w 0 0 +-wordsAsNats addNat-idˡ + +addWord-idʳ : Identityʳ addWord 0 +addWord-idʳ = map-idʳ addWord addNat w2n n2w 0 0 +-wordsAsNats addNat-idʳ + +addWord-comm : Commutative addWord +addWord-comm = map-comm addWord addNat w2n n2w (embedding +-wordsAsNats) addNat-comm + +addWord-assoc : Associative addWord +addWord-assoc = map-assoc addWord addNat w2n n2w (embedding +-wordsAsNats) addNat-assoc + +mulWord-comm : Commutative mulWord +mulWord-comm = map-comm mulWord mulNat w2n n2w (embedding *-wordsAsNats) mulNat-comm + +mulWord-assoc : Associative mulWord +mulWord-assoc = map-assoc mulWord mulNat w2n n2w (embedding *-wordsAsNats) mulNat-assoc + +mulWord-idˡ : Identityˡ mulWord 1 +mulWord-idˡ = map-idˡ mulWord mulNat w2n n2w 1 1 *-wordsAsNats mulNat-idˡ + +mulWord-idʳ : Identityʳ mulWord 1 +mulWord-idʳ = map-idʳ mulWord mulNat w2n n2w 1 1 *-wordsAsNats mulNat-idʳ + +mulWord-distributeˡ-addWord : Distributiveˡ addWord mulWord +mulWord-distributeˡ-addWord = map-distributeˡ addWord addNat mulWord mulNat w2n n2w n2w∘w2n≡id w2n-+-hom w2n-*-hom mulNat-distributeˡ-addNat + +mulWord-distributeʳ-addWord : Distributiveʳ addWord mulWord +mulWord-distributeʳ-addWord = map-distributeʳ addWord addNat mulWord mulNat w2n n2w n2w∘w2n≡id w2n-+-hom w2n-*-hom mulNat-distributeʳ-addNat + +neg-inv-word : ∀ (x : Word) → addWord x (negateWord x) ≡ 0 +neg-inv-word x = + x + negateWord x ≡⟨⟩ + n2w (w2n x + w2n (negateWord x)) ≡⟨⟩ + n2w (w2n x + w2n (n2w (monusNat 2⁶⁴ (w2n x)))) ≡⟨ cong n2w (cong (w2n x +_) (w2n∘n2w≡id (monusNat 2⁶⁴ (w2n x)) (y-x≤y (w2n x) 2⁶⁴))) ⟩ + n2w (w2n x + monusNat 2⁶⁴ (w2n x)) ≡⟨ cong n2w (x+[y-x]≡y (w2n x) 2⁶⁴ (bounded x)) ⟩ + n2w 2⁶⁴ ≡⟨ max-int≡0 ⟩ + 0 ∎ + +instance + open IsLawfulNum + + iLawfulNumWord : IsLawfulNum Word + +-assoc iLawfulNumWord = addWord-assoc + +-comm iLawfulNumWord = addWord-comm + +-idˡ iLawfulNumWord = λ x → addWord-idˡ x + +-idʳ iLawfulNumWord = λ x → addWord-idʳ x + neg-inv iLawfulNumWord = λ x → neg-inv-word x + *-assoc iLawfulNumWord = mulWord-assoc + *-idˡ iLawfulNumWord = λ x → mulWord-idˡ x + *-idʳ iLawfulNumWord = λ x → mulWord-idʳ x + distributeˡ iLawfulNumWord = mulWord-distributeˡ-addWord + distributeʳ iLawfulNumWord = mulWord-distributeʳ-addWord diff --git a/lib/base/Haskell/Law/Ord.agda b/lib/base/Haskell/Law/Ord.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Ord.agda @@ -0,0 +1,6 @@ +module Haskell.Law.Ord where + +open import Haskell.Law.Ord.Def public +open import Haskell.Law.Ord.Bool public +open import Haskell.Law.Ord.Maybe public +open import Haskell.Law.Ord.Ordering public diff --git a/lib/base/Haskell/Law/Ord/Bool.agda b/lib/base/Haskell/Law/Ord/Bool.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Ord/Bool.agda @@ -0,0 +1,68 @@ +module Haskell.Law.Ord.Bool where + +open import Haskell.Prim +open import Haskell.Prim.Ord + +open import Haskell.Law.Eq +open import Haskell.Law.Equality +open import Haskell.Law.Ord.Def + +instance + iLawfulOrdBool : IsLawfulOrd Bool + + iLawfulOrdBool .comparability False False = refl + iLawfulOrdBool .comparability False True = refl + iLawfulOrdBool .comparability True False = refl + iLawfulOrdBool .comparability True True = refl + + iLawfulOrdBool .transitivity False False False _ = refl + iLawfulOrdBool .transitivity False False True _ = refl + iLawfulOrdBool .transitivity False True True _ = refl + iLawfulOrdBool .transitivity True True True _ = refl + + iLawfulOrdBool .reflexivity False = refl + iLawfulOrdBool .reflexivity True = refl + + iLawfulOrdBool .antisymmetry False False _ = refl + iLawfulOrdBool .antisymmetry True True _ = refl + + iLawfulOrdBool .lte2gte False False = refl + iLawfulOrdBool .lte2gte False True = refl + iLawfulOrdBool .lte2gte True False = refl + iLawfulOrdBool .lte2gte True True = refl + + iLawfulOrdBool .lt2LteNeq False False = refl + iLawfulOrdBool .lt2LteNeq False True = refl + iLawfulOrdBool .lt2LteNeq True False = refl + iLawfulOrdBool .lt2LteNeq True True = refl + + iLawfulOrdBool .lt2gt False False = refl + iLawfulOrdBool .lt2gt False True = refl + iLawfulOrdBool .lt2gt True False = refl + iLawfulOrdBool .lt2gt True True = refl + + iLawfulOrdBool .compareLt False False = refl + iLawfulOrdBool .compareLt False True = refl + iLawfulOrdBool .compareLt True False = refl + iLawfulOrdBool .compareLt True True = refl + + iLawfulOrdBool .compareGt False False = refl + iLawfulOrdBool .compareGt False True = refl + iLawfulOrdBool .compareGt True False = refl + iLawfulOrdBool .compareGt True True = refl + + iLawfulOrdBool .compareEq False False = refl + iLawfulOrdBool .compareEq False True = refl + iLawfulOrdBool .compareEq True False = refl + iLawfulOrdBool .compareEq True True = refl + + iLawfulOrdBool .min2if False False = refl + iLawfulOrdBool .min2if False True = refl + iLawfulOrdBool .min2if True False = refl + iLawfulOrdBool .min2if True True = refl + + iLawfulOrdBool .max2if False False = refl + iLawfulOrdBool .max2if False True = refl + iLawfulOrdBool .max2if True False = refl + iLawfulOrdBool .max2if True True = refl + diff --git a/lib/base/Haskell/Law/Ord/Def.agda b/lib/base/Haskell/Law/Ord/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Ord/Def.agda @@ -0,0 +1,203 @@ +module Haskell.Law.Ord.Def where + +open import Haskell.Prim +open import Haskell.Prim.Ord +open import Haskell.Prim.Bool +open import Haskell.Prim.Int +open import Haskell.Prim.Word +open import Haskell.Prim.Integer +open import Haskell.Prim.Double +open import Haskell.Prim.Tuple +open import Haskell.Prim.Monoid +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Either + +open import Haskell.Prim.Eq +open import Haskell.Law.Eq + +open import Haskell.Law.Bool +open import Haskell.Law.Equality + +record IsLawfulOrd (a : Type) ⦃ iOrd : Ord a ⦄ : Type₁ where + field + overlap ⦃ super ⦄ : IsLawfulEq a + + -- Comparability: x <= y || y <= x = True + comparability : ∀ (x y : a) → (x <= y || y <= x) ≡ True + + -- Transitivity: if x <= y && y <= z = True, then x <= z = True + transitivity : ∀ ( x y z : a ) → ((x <= y) && (y <= z)) ≡ True → (x <= z) ≡ True + + -- Reflexivity: x <= x = True + reflexivity : ∀ (x : a) → (x <= x) ≡ True + + -- Antisymmetry: if x <= y && y <= x = True, then x == y = True + antisymmetry : ∀ (x y : a) → ((x <= y) && (y <= x)) ≡ True → (x == y) ≡ True + + -- x >= y = y <= x + lte2gte : ∀ (x y : a) → (x <= y) ≡ (y >= x) + + -- x < y = x <= y && x /= y + lt2LteNeq : ∀ (x y : a) → (x < y) ≡ (x <= y && x /= y) + + -- x > y = y < x + lt2gt : ∀ (x y : a) → (x < y) ≡ (y > x) + + -- x < y = compare x y == LT + compareLt : ∀ (x y : a) → (x < y) ≡ (compare x y == LT) + + -- x > y = compare x y == GT + compareGt : ∀ (x y : a) → (x > y) ≡ (compare x y == GT) + + -- x == y = compare x y == EQ + compareEq : ∀ (x y : a) → (x == y) ≡ (compare x y == EQ) + + -- min x y == if x <= y then x else y = True + min2if : ∀ (x y : a) → ((min x y) == (if (x <= y) then x else y)) ≡ True + + -- max x y == if x >= y then x else y = True + max2if : ∀ (x y : a) → ((max x y) == (if (x >= y) then x else y)) ≡ True + +open IsLawfulOrd ⦃ ... ⦄ public + +-------------------------------------------------- +-- Some more helper laws + +eq2nlt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x == y) ≡ True → (x < y) ≡ False +eq2nlt x y h + rewrite compareEq x y + | compareLt x y + | equality (compare x y) EQ h + = refl + +eq2ngt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x == y) ≡ True → (x > y) ≡ False +eq2ngt x y h + rewrite compareEq x y + | compareGt x y + | equality (compare x y) EQ h + = refl + +lte2LtEq : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x <= y) ≡ (x < y || x == y) +lte2LtEq x y + rewrite lt2LteNeq x y + | compareEq x y + with (x <= y) in h₁ | (compare x y) in h₂ +... | False | LT = refl +... | False | EQ = magic $ exFalso (reflexivity x) $ begin + (x <= x) ≡⟨ (cong (x <=_) (equality x y (begin + (x == y) ≡⟨ compareEq x y ⟩ + (compare x y == EQ) ≡⟨ equality' (compare x y) EQ h₂ ⟩ + True ∎ ) ) ) ⟩ + (x <= y) ≡⟨ h₁ ⟩ + False ∎ +... | False | GT = refl +... | True | LT = refl +... | True | EQ = refl +... | True | GT = refl + +gte2GtEq : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x >= y) ≡ (x > y || x == y) +gte2GtEq x y + rewrite sym $ lte2gte y x + | lte2LtEq y x + | eqSymmetry y x + | lt2gt y x + = refl + +gte2nlt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x >= y) ≡ not (x < y) +gte2nlt x y + rewrite gte2GtEq x y + | compareGt x y + | compareEq x y + | compareLt x y + with compare x y +... | GT = refl +... | EQ = refl +... | LT = refl + +gte2nLT : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x >= y) ≡ (compare x y /= LT) +gte2nLT x y + rewrite gte2nlt x y + | compareLt x y + = refl + +lte2ngt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x <= y) ≡ not (x > y) +lte2ngt x y + rewrite lte2LtEq x y + | compareLt x y + | compareEq x y + | compareGt x y + with compare x y +... | GT = refl +... | EQ = refl +... | LT = refl + +lte2nGT : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x <= y) ≡ (compare x y /= GT) +lte2nGT x y + rewrite lte2ngt x y + | compareGt x y + = refl + +eq2lte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x == y) ≡ True → (x <= y) ≡ True +eq2lte x y h + rewrite lte2ngt x y + | eq2ngt x y h + = refl + +lt2lte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x < y) ≡ True → (x <= y) ≡ True +lt2lte x y h = &&-rightTrue' (x < y) (x <= y) (x /= y) (lt2LteNeq x y) h + +eq2gte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x == y) ≡ True → (x >= y) ≡ True +eq2gte x y h + rewrite gte2nlt x y + | eq2nlt x y h + = refl + +gt2gte : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x > y) ≡ True → (x >= y) ≡ True +gt2gte x y h + rewrite sym (lt2gt y x) + | sym (lt2lte y x h) + | lte2gte y x + = refl + +-------------------------------------------------- +-- Postulated instances + +postulate instance + iLawfulOrdNat : IsLawfulOrd Nat + + iLawfulOrdInteger : IsLawfulOrd Integer + + iLawfulOrdInt : IsLawfulOrd Int + + iLawfulOrdWord : IsLawfulOrd Word + + iLawfulOrdDouble : IsLawfulOrd Double + + iLawfulOrdChar : IsLawfulOrd Char + + iLawfulOrdUnit : IsLawfulOrd ⊤ + + iLawfulOrdTuple₂ : ⦃ iOrdA : Ord a ⦄ ⦃ iOrdB : Ord b ⦄ + → ⦃ IsLawfulOrd a ⦄ → ⦃ IsLawfulOrd b ⦄ + → IsLawfulOrd (a × b) + + iLawfulOrdTuple₃ : ⦃ iOrdA : Ord a ⦄ ⦃ iOrdB : Ord b ⦄ ⦃ iOrdC : Ord c ⦄ + → ⦃ IsLawfulOrd a ⦄ → ⦃ IsLawfulOrd b ⦄ → ⦃ IsLawfulOrd c ⦄ + → IsLawfulOrd (a × b × c) + + iLawfulOrdList : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → IsLawfulOrd (List a) + + iLawfulOrdEither : ⦃ iOrdA : Ord a ⦄ → ⦃ iOrdB : Ord b ⦄ → ⦃ IsLawfulOrd a ⦄ → ⦃ IsLawfulOrd b ⦄ → IsLawfulOrd (Either a b) diff --git a/lib/base/Haskell/Law/Ord/Maybe.agda b/lib/base/Haskell/Law/Ord/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Ord/Maybe.agda @@ -0,0 +1,150 @@ +module Haskell.Law.Ord.Maybe where + +open import Haskell.Prim +open import Haskell.Prim.Bool +open import Haskell.Prim.Eq +open import Haskell.Prim.Maybe +open import Haskell.Prim.Ord + +open import Haskell.Law.Bool +open import Haskell.Law.Eq +open import Haskell.Law.Equality hiding ( trustMe ) +open import Haskell.Law.Maybe +open import Haskell.Law.Ord.Def + +compMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → (x <= y || y <= x) ≡ True +compMaybe Nothing Nothing = refl +compMaybe Nothing (Just _) = refl +compMaybe (Just _) Nothing = refl +compMaybe (Just x) (Just y) + rewrite sym (lte2nGT x y) + | sym (lte2nGT y x) + = comparability x y + +transMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ ( x y z : Maybe a ) → ((x <= y) && (y <= z)) ≡ True → (x <= z) ≡ True +transMaybe Nothing Nothing Nothing _ = refl +transMaybe Nothing Nothing (Just _) _ = refl +transMaybe Nothing (Just _) (Just _) _ = refl +transMaybe (Just x) (Just y) Nothing h + = magic ((nequality (GT /= GT) True refl) (&&-rightTrue (compare x y /= GT) (GT /= GT) h)) +transMaybe (Just x) (Just y) (Just z) h + rewrite sym (compareGt x z) + | sym (lte2nGT x y) + | sym (lte2nGT y z) + | sym (lte2ngt x z) -- not (x > z) → (x <= z) + = transitivity x y z h + +reflMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x : Maybe a) → (x <= x) ≡ True +reflMaybe Nothing = refl +reflMaybe (Just x) + rewrite (equality (compare x x) EQ (trans (sym (compareEq x x)) (eqReflexivity x))) + = refl + +antisymmetryMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → ((x <= y) && (y <= x)) ≡ True → (x == y) ≡ True +antisymmetryMaybe Nothing Nothing _ = refl +antisymmetryMaybe (Just x) (Just y) h + rewrite sym (lte2nGT x y) + | sym (lte2nGT y x) + = antisymmetry x y h + +lte2gteMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → (x <= y) ≡ (y >= x) +lte2gteMaybe Nothing Nothing = refl +lte2gteMaybe Nothing (Just _) = refl +lte2gteMaybe (Just _) Nothing = refl +lte2gteMaybe (Just x) (Just y) + rewrite sym (compareGt x y) + | sym (lte2ngt x y) + | lte2gte x y -- IH + | gte2nlt y x + | compareLt y x + = refl + +lt2LteNeqMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → (x < y) ≡ (x <= y && x /= y) +lt2LteNeqMaybe Nothing Nothing = refl +lt2LteNeqMaybe Nothing (Just _) = refl +lt2LteNeqMaybe (Just _) Nothing = refl +lt2LteNeqMaybe (Just x) (Just y) + rewrite sym (compareLt x y) + | lt2LteNeq x y -- IH + | lte2ngt x y + | compareGt x y + = refl + +lt2gtMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → (x < y) ≡ (y > x) +lt2gtMaybe Nothing Nothing = refl +lt2gtMaybe Nothing (Just _) = refl +lt2gtMaybe (Just _) Nothing = refl +lt2gtMaybe (Just x) (Just y) + rewrite sym (compareLt x y) + | lt2gt x y -- IH + | compareGt y x + = refl + +compareLtMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → (x < y) ≡ (compare x y == LT) +compareLtMaybe Nothing Nothing = refl +compareLtMaybe Nothing (Just _) = refl +compareLtMaybe (Just _) Nothing = refl +compareLtMaybe (Just _) (Just _) = refl + +compareGtMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → (x > y) ≡ (compare x y == GT) +compareGtMaybe Nothing Nothing = refl +compareGtMaybe Nothing (Just _) = refl +compareGtMaybe (Just _) Nothing = refl +compareGtMaybe (Just _) (Just _) = refl + +compareEqMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ iLawfulOrdA : IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → (x == y) ≡ (compare x y == EQ) +compareEqMaybe Nothing Nothing = refl +compareEqMaybe Nothing (Just y) = refl +compareEqMaybe (Just x) Nothing = refl +compareEqMaybe (Just x) (Just y) = compareEq x y + +min2ifMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → ((min x y) == (if (x <= y) then x else y)) ≡ True +min2ifMaybe Nothing Nothing = refl +min2ifMaybe Nothing (Just _) = refl +min2ifMaybe (Just _) Nothing = refl +min2ifMaybe (Just x) (Just y) + rewrite sym (ifFlip (compare x y == GT) (Just x) (Just y)) + = equality' + (if (compare x y /= GT) then Just x else Just y) + (if (compare x y /= GT) then Just x else Just y) + refl + +max2ifMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : Maybe a) → ((max x y) == (if (x >= y) then x else y)) ≡ True +max2ifMaybe Nothing Nothing = refl +max2ifMaybe Nothing (Just y) = eqReflexivity y +max2ifMaybe (Just x) Nothing = eqReflexivity x +max2ifMaybe (Just x) (Just y) + rewrite sym (ifFlip (compare x y == LT) (Just x) (Just y)) + = equality' + (if (compare x y /= LT) then Just x else Just y) + (if (compare x y /= LT) then Just x else Just y) + refl + +instance + iLawfulOrdMaybe : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → IsLawfulOrd (Maybe a) + iLawfulOrdMaybe = λ where + .comparability → compMaybe + .transitivity → transMaybe + .reflexivity → reflMaybe + .antisymmetry → antisymmetryMaybe + .lte2gte → lte2gteMaybe + .lt2LteNeq → lt2LteNeqMaybe + .lt2gt → lt2gtMaybe + .compareLt → compareLtMaybe + .compareGt → compareGtMaybe + .compareEq → compareEqMaybe + .min2if → min2ifMaybe + .max2if → max2ifMaybe + diff --git a/lib/base/Haskell/Law/Ord/Ordering.agda b/lib/base/Haskell/Law/Ord/Ordering.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Ord/Ordering.agda @@ -0,0 +1,121 @@ +module Haskell.Law.Ord.Ordering where + +open import Haskell.Prim +open import Haskell.Prim.Ord + +open import Haskell.Law.Eq +open import Haskell.Law.Equality +open import Haskell.Law.Ord.Def + +instance + iLawfulOrdOrdering : IsLawfulOrd Ordering + + iLawfulOrdOrdering .comparability LT LT = refl + iLawfulOrdOrdering .comparability LT EQ = refl + iLawfulOrdOrdering .comparability LT GT = refl + iLawfulOrdOrdering .comparability EQ LT = refl + iLawfulOrdOrdering .comparability EQ EQ = refl + iLawfulOrdOrdering .comparability EQ GT = refl + iLawfulOrdOrdering .comparability GT LT = refl + iLawfulOrdOrdering .comparability GT EQ = refl + iLawfulOrdOrdering .comparability GT GT = refl + + iLawfulOrdOrdering .transitivity LT LT LT _ = refl + iLawfulOrdOrdering .transitivity LT LT EQ _ = refl + iLawfulOrdOrdering .transitivity LT LT GT _ = refl + iLawfulOrdOrdering .transitivity LT EQ EQ _ = refl + iLawfulOrdOrdering .transitivity LT EQ GT _ = refl + iLawfulOrdOrdering .transitivity LT GT GT _ = refl + iLawfulOrdOrdering .transitivity EQ EQ EQ _ = refl + iLawfulOrdOrdering .transitivity EQ EQ GT _ = refl + iLawfulOrdOrdering .transitivity EQ GT GT _ = refl + iLawfulOrdOrdering .transitivity GT GT GT _ = refl + + iLawfulOrdOrdering .reflexivity LT = refl + iLawfulOrdOrdering .reflexivity EQ = refl + iLawfulOrdOrdering .reflexivity GT = refl + + iLawfulOrdOrdering .antisymmetry LT LT _ = refl + iLawfulOrdOrdering .antisymmetry EQ EQ _ = refl + iLawfulOrdOrdering .antisymmetry GT GT _ = refl + + iLawfulOrdOrdering .lte2gte LT LT = refl + iLawfulOrdOrdering .lte2gte LT EQ = refl + iLawfulOrdOrdering .lte2gte LT GT = refl + iLawfulOrdOrdering .lte2gte EQ LT = refl + iLawfulOrdOrdering .lte2gte EQ EQ = refl + iLawfulOrdOrdering .lte2gte EQ GT = refl + iLawfulOrdOrdering .lte2gte GT LT = refl + iLawfulOrdOrdering .lte2gte GT EQ = refl + iLawfulOrdOrdering .lte2gte GT GT = refl + + iLawfulOrdOrdering .lt2LteNeq LT LT = refl + iLawfulOrdOrdering .lt2LteNeq LT EQ = refl + iLawfulOrdOrdering .lt2LteNeq LT GT = refl + iLawfulOrdOrdering .lt2LteNeq EQ LT = refl + iLawfulOrdOrdering .lt2LteNeq EQ EQ = refl + iLawfulOrdOrdering .lt2LteNeq EQ GT = refl + iLawfulOrdOrdering .lt2LteNeq GT LT = refl + iLawfulOrdOrdering .lt2LteNeq GT EQ = refl + iLawfulOrdOrdering .lt2LteNeq GT GT = refl + + iLawfulOrdOrdering .lt2gt LT LT = refl + iLawfulOrdOrdering .lt2gt LT EQ = refl + iLawfulOrdOrdering .lt2gt LT GT = refl + iLawfulOrdOrdering .lt2gt EQ LT = refl + iLawfulOrdOrdering .lt2gt EQ EQ = refl + iLawfulOrdOrdering .lt2gt EQ GT = refl + iLawfulOrdOrdering .lt2gt GT LT = refl + iLawfulOrdOrdering .lt2gt GT EQ = refl + iLawfulOrdOrdering .lt2gt GT GT = refl + + iLawfulOrdOrdering .compareLt LT LT = refl + iLawfulOrdOrdering .compareLt LT EQ = refl + iLawfulOrdOrdering .compareLt LT GT = refl + iLawfulOrdOrdering .compareLt EQ LT = refl + iLawfulOrdOrdering .compareLt EQ EQ = refl + iLawfulOrdOrdering .compareLt EQ GT = refl + iLawfulOrdOrdering .compareLt GT LT = refl + iLawfulOrdOrdering .compareLt GT EQ = refl + iLawfulOrdOrdering .compareLt GT GT = refl + + iLawfulOrdOrdering .compareGt LT LT = refl + iLawfulOrdOrdering .compareGt LT EQ = refl + iLawfulOrdOrdering .compareGt LT GT = refl + iLawfulOrdOrdering .compareGt EQ LT = refl + iLawfulOrdOrdering .compareGt EQ EQ = refl + iLawfulOrdOrdering .compareGt EQ GT = refl + iLawfulOrdOrdering .compareGt GT LT = refl + iLawfulOrdOrdering .compareGt GT EQ = refl + iLawfulOrdOrdering .compareGt GT GT = refl + + iLawfulOrdOrdering .compareEq LT LT = refl + iLawfulOrdOrdering .compareEq LT EQ = refl + iLawfulOrdOrdering .compareEq LT GT = refl + iLawfulOrdOrdering .compareEq EQ LT = refl + iLawfulOrdOrdering .compareEq EQ EQ = refl + iLawfulOrdOrdering .compareEq EQ GT = refl + iLawfulOrdOrdering .compareEq GT LT = refl + iLawfulOrdOrdering .compareEq GT EQ = refl + iLawfulOrdOrdering .compareEq GT GT = refl + + iLawfulOrdOrdering .min2if LT LT = refl + iLawfulOrdOrdering .min2if LT EQ = refl + iLawfulOrdOrdering .min2if LT GT = refl + iLawfulOrdOrdering .min2if EQ LT = refl + iLawfulOrdOrdering .min2if EQ EQ = refl + iLawfulOrdOrdering .min2if EQ GT = refl + iLawfulOrdOrdering .min2if GT LT = refl + iLawfulOrdOrdering .min2if GT EQ = refl + iLawfulOrdOrdering .min2if GT GT = refl + + iLawfulOrdOrdering .max2if LT LT = refl + iLawfulOrdOrdering .max2if LT EQ = refl + iLawfulOrdOrdering .max2if LT GT = refl + iLawfulOrdOrdering .max2if EQ LT = refl + iLawfulOrdOrdering .max2if EQ EQ = refl + iLawfulOrdOrdering .max2if EQ GT = refl + iLawfulOrdOrdering .max2if GT LT = refl + iLawfulOrdOrdering .max2if GT EQ = refl + iLawfulOrdOrdering .max2if GT GT = refl + diff --git a/lib/base/Haskell/Law/Semigroup/Def.agda b/lib/base/Haskell/Law/Semigroup/Def.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Semigroup/Def.agda @@ -0,0 +1,27 @@ +module Haskell.Law.Semigroup.Def where + +open import Haskell.Prim +open import Haskell.Prim.Tuple + +open import Haskell.Prim.Monoid + +record IsLawfulSemigroup (a : Type) ⦃ iSemigroupA : Semigroup a ⦄ : Type₁ where + field + -- Associativity: x <> (y <> z) = (x <> y) <> z + associativity : (x y z : a) → x <> (y <> z) ≡ (x <> y) <> z + +open IsLawfulSemigroup ⦃ ... ⦄ public + +postulate instance + iLawfulSemigroupFun : ⦃ iSemB : Semigroup b ⦄ → ⦃ IsLawfulSemigroup b ⦄ → IsLawfulSemigroup (a → b) + + iLawfulSemigroupUnit : IsLawfulSemigroup ⊤ + + iLawfulSemigroupTuple₂ : ⦃ iSemA : Semigroup a ⦄ ⦃ iSemB : Semigroup b ⦄ + → ⦃ IsLawfulSemigroup a ⦄ → ⦃ IsLawfulSemigroup b ⦄ + → IsLawfulSemigroup (a × b) + + iLawfulSemigroupTuple₃ : ⦃ iSemA : Semigroup a ⦄ ⦃ iSemB : Semigroup b ⦄ ⦃ iSemC : Semigroup c ⦄ + → ⦃ IsLawfulSemigroup a ⦄ → ⦃ IsLawfulSemigroup b ⦄ → ⦃ IsLawfulSemigroup c ⦄ + → IsLawfulSemigroup (a × b × c) + diff --git a/lib/base/Haskell/Law/Semigroup/Either.agda b/lib/base/Haskell/Law/Semigroup/Either.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Semigroup/Either.agda @@ -0,0 +1,13 @@ +module Haskell.Law.Semigroup.Either where + +open import Haskell.Prim +open import Haskell.Prim.Either + +open import Haskell.Prim.Monoid + +open import Haskell.Law.Equality +open import Haskell.Law.Semigroup.Def + +instance + iLawfulSemigroupEither : IsLawfulSemigroup (Either a b) + iLawfulSemigroupEither .associativity = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } diff --git a/lib/base/Haskell/Law/Semigroup/List.agda b/lib/base/Haskell/Law/Semigroup/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Semigroup/List.agda @@ -0,0 +1,17 @@ +module Haskell.Law.Semigroup.List where + +open import Haskell.Prim +open import Haskell.Prim.List + +open import Haskell.Prim.Monoid + +open import Haskell.Law.Equality +open import Haskell.Law.List +open import Haskell.Law.Semigroup.Def + +instance + iLawfulSemigroupList : IsLawfulSemigroup (List a) + iLawfulSemigroupList .associativity [] _ _ = refl + iLawfulSemigroupList .associativity (x ∷ xs) ys zs + rewrite sym (++-assoc xs ys zs) + = refl diff --git a/lib/base/Haskell/Law/Semigroup/Maybe.agda b/lib/base/Haskell/Law/Semigroup/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Law/Semigroup/Maybe.agda @@ -0,0 +1,18 @@ +module Haskell.Law.Semigroup.Maybe where + +open import Haskell.Prim +open import Haskell.Prim.Maybe + +open import Haskell.Prim.Monoid + +open import Haskell.Law.Equality +open import Haskell.Law.Semigroup.Def + +instance + iLawfulSemigroupMaybe : ⦃ iSemA : Semigroup a ⦄ → ⦃ IsLawfulSemigroup a ⦄ → IsLawfulSemigroup (Maybe a) + iLawfulSemigroupMaybe .associativity Nothing _ _ = refl + iLawfulSemigroupMaybe .associativity (Just _) Nothing _ = refl + iLawfulSemigroupMaybe .associativity (Just _) (Just _) Nothing = refl + iLawfulSemigroupMaybe .associativity (Just x) (Just y) (Just z) + rewrite associativity x y z + = refl diff --git a/lib/base/Haskell/Prelude.agda b/lib/base/Haskell/Prelude.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prelude.agda @@ -0,0 +1,140 @@ +{-# OPTIONS --no-auto-inline #-} +module Haskell.Prelude where + +open import Haskell.Prim +open Haskell.Prim public using + ( Type; + Bool; True; False; Char; Integer; + List; []; _∷_; Nat; zero; suc; ⊤; tt; + TypeError; ⊥; iNumberNat; lengthNat; + IsTrue; IsFalse; NonEmpty; + All; allNil; allCons; + Any; anyHere; anyThere; + id; _∘_; _$_; flip; const; + if_then_else_; case_of_; + Number; fromNat; Negative; fromNeg; + IsString; fromString; + _≡_; refl; + a; b; c; d; e; f; m; s; t ) + +open import Haskell.Prim.Absurd public +open import Haskell.Prim.Applicative public +open import Haskell.Prim.Bool public +open import Haskell.Prim.Bounded public +open import Haskell.Prim.Char public +open import Haskell.Prim.Double public +open import Haskell.Prim.Either public +open import Haskell.Prim.Enum public +open import Haskell.Prim.Eq public +open import Haskell.Prim.Foldable public +open import Haskell.Prim.Functor public +open import Haskell.Prim.Int public +open import Haskell.Prim.Integer public +open import Haskell.Prim.IO public +open import Haskell.Prim.List public +open import Haskell.Prim.Maybe public +open import Haskell.Prim.Monad public +open import Haskell.Prim.Monoid public +open import Haskell.Prim.Num public +open import Haskell.Prim.Ord public +open import Haskell.Prim.Show public +open import Haskell.Prim.String public +open import Haskell.Prim.Traversable public +open import Haskell.Prim.Tuple public hiding (first; second; _***_) +open import Haskell.Prim.Word public + +-- Problematic features +-- - [Partial]: Could pass implicit/instance arguments to prove totality. +-- - [Float]: Or Float (Agda floats are Doubles) +-- - [Infinite]: Define colists and map to Haskell lists? + +-- Missing from the Haskell Prelude: +-- +-- Float [Float] +-- Rational +-- +-- Real(toRational), +-- Integral(quot, rem, div, mod, quotRem, divMod, toInteger), +-- Fractional((/), recip, fromRational), +-- Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, +-- asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), +-- RealFrac(properFraction, truncate, round, ceiling, floor), +-- RealFloat(floatRadix, floatDigits, floatRange, decodeFloat, +-- encodeFloat, exponent, significand, scaleFloat, isNaN, +-- isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2), +-- +-- subtract, even, odd, gcd, lcm, (^), (^^), +-- fromIntegral, realToFrac, +-- +-- foldr1, foldl1, maximum, minimum [Partial] +-- +-- until [Partial] +-- +-- iterate, repeat, cycle [Infinite] +-- +-- ReadS, Read(readsPrec, readList), +-- reads, readParen, read, lex, +-- +-- IO, putChar, putStr, putStrLn, print, +-- getChar, getLine, getContents, interact, +-- FilePath, readFile, writeFile, appendFile, readIO, readLn, +-- IOError, ioError, userError, + + +-------------------------------------------------- +-- Functions + +infixr 0 _$!_ + +_$!_ : (a → b) → a → b +_$!_ = _$_ + +seq : a → b → b +seq = const id + +asTypeOf : a → a → a +asTypeOf x _ = x + +undefined : {@0 @(tactic absurd) i : ⊥} → a +undefined {i = ()} + +error : {@0 @(tactic absurd) i : ⊥} → String → a +error {i = ()} err + +errorWithoutStackTrace : {@0 @(tactic absurd) i : ⊥} → String → a +errorWithoutStackTrace {i = ()} err + +------------------------------------------------- +-- More List functions +-- These uses Eq, Ord, or Foldable, so can't go in Prim.List without +-- turning those dependencies around. + +reverse : List a → List a +reverse = foldl (flip _∷_) [] + +infixl 9 _!!_ _!!ᴺ_ + +_!!ᴺ_ : (xs : List a) (n : Nat) → @0 ⦃ IsTrue (n < lengthNat xs) ⦄ → a +(x ∷ xs) !!ᴺ zero = x +(x ∷ xs) !!ᴺ suc n = xs !!ᴺ n + +_!!_ : (xs : List a) (n : Int) + → ⦃ @0 nn : IsNonNegativeInt n ⦄ + → ⦃ @0 _ : IsTrue (intToNat n {{nn}} < lengthNat xs) ⦄ → a +xs !! n = xs !!ᴺ intToNat n + +lookup : ⦃ Eq a ⦄ → a → List (a × b) → Maybe b +lookup x [] = Nothing +lookup x ((x₁ , y) ∷ xs) = if x == x₁ then Just y else lookup x xs + + +------------------------------------------------- +-- Unsafe functions + +coerce : @0 a ≡ b → a → b +coerce refl x = x + +IsJust : Maybe a → Type +IsJust Nothing = ⊥ +IsJust (Just _) = ⊤ + diff --git a/lib/base/Haskell/Prim.agda b/lib/base/Haskell/Prim.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim.agda @@ -0,0 +1,130 @@ +{-# OPTIONS --no-auto-inline #-} + +-- Basic things needed by other primitive modules. +-- Note that this module exports types and functions that should not +-- be used directly in Haskell definitions, so you probably want to +-- import Haskell.Prelude instead. + +module Haskell.Prim where + +open import Agda.Primitive public renaming (Set to Type) +open import Agda.Builtin.Bool public renaming (true to True; false to False) +open import Agda.Builtin.Int public renaming (Int to Integer) +open import Agda.Builtin.Nat public renaming (_==_ to eqNat; _<_ to ltNat; _+_ to addNat; _-_ to monusNat; _*_ to mulNat) +open import Agda.Builtin.Char public renaming (primCharToNat to c2n) +open import Agda.Builtin.Unit public +open import Agda.Builtin.Equality public +open import Agda.Builtin.FromString public +open import Agda.Builtin.FromNat public +open import Agda.Builtin.FromNeg public +open import Agda.Builtin.String public renaming (String to AgdaString) +open import Agda.Builtin.Word public renaming (primWord64ToNat to w2n; primWord64FromNat to n2w) +open import Agda.Builtin.Strict public +open import Agda.Builtin.List public + +variable + @0 ℓ : Level + a b c d e : Type + f m s t : Type → Type + + +-------------------------------------------------- +-- Functions + +id : a → a +id x = x + +infixr 9 _∘_ +_∘_ : (b → c) → (a → b) → a → c +(f ∘ g) x = f (g x) + +flip : (a → b → c) → b → a → c +flip f x y = f y x + +const : a → b → a +const x _ = x + +infixr 0 _$_ +_$_ : (a → b) → a → b +f $ x = f x + + +-------------------------------------------------- +-- Language constructs + +infix -1 case_of_ +case_of_ : (a' : a) → ((a'' : a) → @0 {{ a' ≡ a'' }} → b) → b +case x of f = f x + +infix -2 if_then_else_ +if_then_else_ : {@0 a : Type ℓ} → (flg : Bool) → (@0 {{ flg ≡ True }} → a) → (@0 {{ flg ≡ False }} → a) → a +if False then x else y = y +if True then x else y = x + +-- for explicit type signatures (e. g. `4 :: Integer` is `the Int 4`) +the : (@0 a : Type ℓ) -> a -> a +the _ x = x + +-------------------------------------------------- +-- Agda strings + +instance + iIsStringAgdaString : IsString AgdaString + iIsStringAgdaString .IsString.Constraint _ = ⊤ + iIsStringAgdaString .fromString s = s + + +-------------------------------------------------- +-- Numbers + +instance + iNumberNat : Number Nat + iNumberNat .Number.Constraint _ = ⊤ + iNumberNat .fromNat n = n + + +-------------------------------------------------- +-- Lists + +lengthNat : List a → Nat +lengthNat [] = 0 +lengthNat (_ ∷ xs) = addNat 1 (lengthNat xs) + + +-------------------------------------------------- +-- Proof things + +data ⊥ : Type where + +magic : {A : Type} → ⊥ → A +magic () + +--principle of explosion +exFalso : {x : Bool} → (x ≡ True) → (x ≡ False) → ⊥ +exFalso {False} () b +exFalso {True} a () + +-- Use to bundle up constraints +data All {a b} {A : Type a} (B : A → Type b) : List A → Type (a ⊔ b) where + instance + allNil : All B [] + allCons : ∀ {x xs} ⦃ i : B x ⦄ ⦃ is : All B xs ⦄ → All B (x ∷ xs) + +data Any {a b} {A : Type a} (B : A → Type b) : List A → Type (a ⊔ b) where + instance + anyHere : ∀ {x xs} ⦃ i : B x ⦄ → Any B (x ∷ xs) + anyThere : ∀ {x xs} ⦃ is : Any B xs ⦄ → Any B (x ∷ xs) + +data IsTrue : Bool → Type where + instance itsTrue : IsTrue True + +data IsFalse : Bool → Type where + instance itsFalse : IsFalse False + +data NonEmpty {a : Type} : List a → Type where + instance itsNonEmpty : ∀ {x xs} → NonEmpty (x ∷ xs) + +data TypeError (err : AgdaString) : Type where + +it : ∀ {@0 ℓ} {@0 a : Type ℓ} → ⦃ a ⦄ → a +it ⦃ x ⦄ = x diff --git a/lib/base/Haskell/Prim/Absurd.agda b/lib/base/Haskell/Prim/Absurd.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Absurd.agda @@ -0,0 +1,23 @@ + +module Haskell.Prim.Absurd where + +open import Haskell.Prim + +open import Agda.Builtin.Reflection renaming (bindTC to _>>=_; absurd to absurdP) + +private + + pattern vArg x = arg (arg-info visible (modality relevant quantity-ω)) x + + refute : Nat → Term + refute i = def (quote _$_) ( vArg (pat-lam (absurd-clause [] (vArg (absurdP 0) ∷ []) ∷ []) []) + ∷ vArg (var i []) ∷ []) + + tryRefute : Nat → Term → TC ⊤ + tryRefute 0 _ = typeError (strErr "No variable of empty type found in the context" ∷ []) + tryRefute (suc n) hole = catchTC (unify hole (refute n)) (tryRefute n hole) + +absurd : Term → TC ⊤ +absurd hole = do + Γ ← getContext + tryRefute (lengthNat Γ) hole diff --git a/lib/base/Haskell/Prim/Applicative.agda b/lib/base/Haskell/Prim/Applicative.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Applicative.agda @@ -0,0 +1,92 @@ +module Haskell.Prim.Applicative where + +open import Haskell.Prim +open import Haskell.Prim.Either +open import Haskell.Prim.Foldable +open import Haskell.Prim.Functor +open import Haskell.Prim.IO +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Monoid +open import Haskell.Prim.Tuple + + +-------------------------------------------------- +-- Applicative + +-- ** base +record Applicative (f : Type → Type) : Type₁ where + infixl 4 _<*>_ _<*_ _*>_ + field + pure : a → f a + _<*>_ : f (a → b) → f a → f b + overlap ⦃ super ⦄ : Functor f + _<*_ : f a → f b → f a + _*>_ : f a → f b → f b +-- ** defaults +record DefaultApplicative (f : Type → Type) : Type₁ where + constructor mk + infixl 4 _<*>_ _<*_ _*>_ + field + pure : a → f a + _<*>_ : f (a → b) → f a → f b + overlap ⦃ super ⦄ : Functor f + + _<*_ : f a → f b → f a + x <* y = const <$> x <*> y + + _*>_ : f a → f b → f b + x *> y = const id <$> x <*> y +-- ** export +open Applicative ⦃...⦄ public +{-# COMPILE AGDA2HS Applicative existing-class #-} +-- ** instances +instance + open DefaultApplicative + + iDefaultApplicativeList : DefaultApplicative List + iDefaultApplicativeList .pure x = x ∷ [] + iDefaultApplicativeList ._<*>_ fs xs = concatMap (λ f → map f xs) fs + + iApplicativeList : Applicative List + iApplicativeList = record {DefaultApplicative iDefaultApplicativeList} + + iDefaultApplicativeMaybe : DefaultApplicative Maybe + iDefaultApplicativeMaybe .pure = Just + iDefaultApplicativeMaybe ._<*>_ (Just f) (Just x) = Just (f x) + iDefaultApplicativeMaybe ._<*>_ _ _ = Nothing + + iApplicativeMaybe : Applicative Maybe + iApplicativeMaybe = record {DefaultApplicative iDefaultApplicativeMaybe} + + iDefaultApplicativeEither : DefaultApplicative (Either a) + iDefaultApplicativeEither .pure = Right + iDefaultApplicativeEither ._<*>_ (Right f) (Right x) = Right (f x) + iDefaultApplicativeEither ._<*>_ (Left e) _ = Left e + iDefaultApplicativeEither ._<*>_ _ (Left e) = Left e + + iApplicativeEither : Applicative (Either a) + iApplicativeEither = record{DefaultApplicative iDefaultApplicativeEither} + + iDefaultApplicativeFun : DefaultApplicative (λ b → a → b) + iDefaultApplicativeFun .pure = const + iDefaultApplicativeFun ._<*>_ f g x = f x (g x) + + iApplicativeFun : Applicative (λ b → a → b) + iApplicativeFun = record{DefaultApplicative iDefaultApplicativeFun} + + iDefaultApplicativeTuple₂ : ⦃ Monoid a ⦄ → DefaultApplicative (a ×_) + iDefaultApplicativeTuple₂ .pure x = mempty , x + iDefaultApplicativeTuple₂ ._<*>_ (a , f) (b , x) = a <> b , f x + + iApplicativeTuple₂ : ⦃ Monoid a ⦄ → Applicative (a ×_) + iApplicativeTuple₂ = record{DefaultApplicative iDefaultApplicativeTuple₂} + + iDefaultApplicativeTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → DefaultApplicative (a × b ×_) + iDefaultApplicativeTuple₃ .pure x = mempty , mempty , x + iDefaultApplicativeTuple₃ ._<*>_ (a , u , f) (b , v , x) = a <> b , u <> v , f x + + iApplicativeTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Applicative (a × b ×_) + iApplicativeTuple₃ = record{DefaultApplicative iDefaultApplicativeTuple₃} + +instance postulate iApplicativeIO : Applicative IO diff --git a/lib/base/Haskell/Prim/Bool.agda b/lib/base/Haskell/Prim/Bool.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Bool.agda @@ -0,0 +1,24 @@ + +module Haskell.Prim.Bool where + +open import Haskell.Prim + +-------------------------------------------------- +-- Booleans + +infixr 3 _&&_ +_&&_ : Bool → Bool → Bool +False && _ = False +True && x = x + +infixr 2 _||_ +_||_ : Bool → Bool → Bool +False || x = x +True || _ = True + +not : Bool → Bool +not False = True +not True = False + +otherwise : Bool +otherwise = True diff --git a/lib/base/Haskell/Prim/Bounded.agda b/lib/base/Haskell/Prim/Bounded.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Bounded.agda @@ -0,0 +1,94 @@ + +module Haskell.Prim.Bounded where + +open import Haskell.Prim +open import Haskell.Prim.Eq +open import Haskell.Prim.Int +open import Haskell.Prim.Maybe +open import Haskell.Prim.Ord +open import Haskell.Prim.Tuple +open import Haskell.Prim.Word + +-------------------------------------------------- +-- Bounded + +record BoundedBelow (a : Type) : Type where + field + minBound : a + +record BoundedAbove (a : Type) : Type where + field + maxBound : a + +record Bounded (a : Type) : Type where + field + overlap ⦃ below ⦄ : BoundedBelow a + overlap ⦃ above ⦄ : BoundedAbove a + +{-# COMPILE AGDA2HS Bounded existing-class #-} + +open BoundedBelow ⦃...⦄ public +open BoundedAbove ⦃...⦄ public + +instance + iBounded : ⦃ BoundedBelow a ⦄ → ⦃ BoundedAbove a ⦄ → Bounded a + iBounded .Bounded.below = it + iBounded .Bounded.above = it + +instance + iBoundedBelowNat : BoundedBelow Nat + iBoundedBelowNat .minBound = 0 + + iBoundedBelowWord : BoundedBelow Word + iBoundedBelowWord .minBound = 0 + iBoundedAboveWord : BoundedAbove Word + iBoundedAboveWord .maxBound = 18446744073709551615 + + iBoundedBelowInt : BoundedBelow Int + iBoundedBelowInt .minBound = -9223372036854775808 + iBoundedAboveInt : BoundedAbove Int + iBoundedAboveInt .maxBound = 9223372036854775807 + + iBoundedBelowBool : BoundedBelow Bool + iBoundedBelowBool .minBound = False + iBoundedAboveBool : BoundedAbove Bool + iBoundedAboveBool .maxBound = True + + iBoundedBelowChar : BoundedBelow Char + iBoundedBelowChar .minBound = '\0' + iBoundedAboveChar : BoundedAbove Char + iBoundedAboveChar .maxBound = '\1114111' + + iBoundedBelowUnit : BoundedBelow ⊤ + iBoundedBelowUnit .minBound = tt + + iBoundedAboveUnit : BoundedAbove ⊤ + iBoundedAboveUnit .maxBound = tt + + iBoundedBelowTuple₂ : ⦃ BoundedBelow a ⦄ → ⦃ BoundedBelow b ⦄ + → BoundedBelow (a × b) + iBoundedBelowTuple₂ .minBound = minBound , minBound + iBoundedAboveTuple₂ : ⦃ BoundedAbove a ⦄ → ⦃ BoundedAbove b ⦄ + → BoundedAbove (a × b) + iBoundedAboveTuple₂ .maxBound = maxBound , maxBound + + iBoundedBelowTuple₃ : ⦃ BoundedBelow a ⦄ → ⦃ BoundedBelow b ⦄ → ⦃ BoundedBelow c ⦄ + → BoundedBelow (a × b × c) + iBoundedBelowTuple₃ .minBound = minBound , minBound , minBound + iBoundedAboveTuple₃ : ⦃ BoundedAbove a ⦄ → ⦃ BoundedAbove b ⦄ → ⦃ BoundedAbove c ⦄ + → BoundedAbove (a × b × c) + iBoundedAboveTuple₃ .maxBound = maxBound , maxBound , maxBound + + iBoundedBelowOrdering : BoundedBelow Ordering + iBoundedBelowOrdering .minBound = LT + iBoundedAboveOrdering : BoundedAbove Ordering + iBoundedAboveOrdering .maxBound = GT + +-- Sanity checks + +private + _ : addWord maxBound 1 ≡ minBound + _ = refl + + _ : addInt maxBound 1 ≡ minBound + _ = refl diff --git a/lib/base/Haskell/Prim/Char.agda b/lib/base/Haskell/Prim/Char.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Char.agda @@ -0,0 +1,9 @@ +module Haskell.Prim.Char where + +open import Haskell.Prim + +import Agda.Builtin.Char +open Agda.Builtin.Char using (Char) + +eqChar : Char → Char → Bool +eqChar a b = eqNat (c2n a) (c2n b) diff --git a/lib/base/Haskell/Prim/Double.agda b/lib/base/Haskell/Prim/Double.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Double.agda @@ -0,0 +1,15 @@ + +module Haskell.Prim.Double where + +open import Agda.Builtin.Float public renaming (Float to Double) + +open import Haskell.Prim + +instance + iNumberDouble : Number Double + iNumberDouble .Number.Constraint _ = ⊤ + iNumberDouble .fromNat n = primNatToFloat n + + iNegativeDouble : Negative Double + iNegativeDouble .Negative.Constraint _ = ⊤ + iNegativeDouble .fromNeg n = primFloatMinus 0.0 (fromNat n) diff --git a/lib/base/Haskell/Prim/Either.agda b/lib/base/Haskell/Prim/Either.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Either.agda @@ -0,0 +1,20 @@ + +module Haskell.Prim.Either where + +open import Haskell.Prim +open import Haskell.Prim.Bool + +-------------------------------------------------- +-- Either + +data Either (a b : Type) : Type where + Left : a → Either a b + Right : b → Either a b + +either : (a → c) → (b → c) → Either a b → c +either f g (Left x) = f x +either f g (Right y) = g y + +testBool : (b : Bool) → Either (IsFalse b) (IsTrue b) +testBool False = Left itsFalse +testBool True = Right itsTrue diff --git a/lib/base/Haskell/Prim/Enum.agda b/lib/base/Haskell/Prim/Enum.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Enum.agda @@ -0,0 +1,263 @@ + +module Haskell.Prim.Enum where + +open import Haskell.Prim +open import Haskell.Prim.Bool +open import Haskell.Prim.Bounded +open import Haskell.Prim.Either +open import Haskell.Prim.Eq +open import Haskell.Prim.Functor +open import Haskell.Prim.Int +open import Haskell.Prim.Integer +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Num +open import Haskell.Prim.Ord +open import Haskell.Prim.Tuple +open import Haskell.Prim.Word + + +-------------------------------------------------- +-- Enum +-- Assumptions: unbounded enums have no constraints on their +-- operations and bounded enums should work on all values between +-- minBound and maxBound. Unbounded enums do not support enumFrom +-- and enumFromThen (since they return infinite lists). + +@0 IfBoundedBelow : Maybe (BoundedBelow a) → (⦃ BoundedBelow a ⦄ → Type) → Type +IfBoundedBelow Nothing k = ⊤ +IfBoundedBelow (Just i) k = k ⦃ i ⦄ + +@0 IfBoundedAbove : Maybe (BoundedAbove a) → (⦃ BoundedAbove a ⦄ → Type) → Type +IfBoundedAbove Nothing k = ⊤ +IfBoundedAbove (Just i) k = k ⦃ i ⦄ + +record Enum (a : Type) : Type₁ where + field + BoundedBelowEnum : Maybe (BoundedBelow a) + BoundedAboveEnum : Maybe (BoundedAbove a) + fromEnum : a → Int + + private + @0 IsBoundedBelow : Type + IsBoundedBelow = maybe ⊥ (λ _ → ⊤) BoundedBelowEnum + + @0 IsBoundedAbove : Type + IsBoundedAbove = maybe ⊥ (λ _ → ⊤) BoundedAboveEnum + + @0 TrueIfLB : (⦃ BoundedBelow a ⦄ → Bool) → Type + TrueIfLB C = IfBoundedBelow BoundedBelowEnum (IsTrue C) + + @0 TrueIfUB : (⦃ BoundedAbove a ⦄ → Bool) → Type + TrueIfUB C = IfBoundedAbove BoundedAboveEnum (IsTrue C) + + @0 FalseIfLB : (⦃ BoundedBelow a ⦄ → Bool) → Type + FalseIfLB C = IfBoundedBelow BoundedBelowEnum (IsFalse C) + + @0 FalseIfUB : (⦃ BoundedAbove a ⦄ → Bool) → Type + FalseIfUB C = IfBoundedAbove BoundedAboveEnum (IsFalse C) + + minInt : ⦃ BoundedBelow a ⦄ → Int + minInt ⦃ _ ⦄ = fromEnum minBound + + maxInt : ⦃ BoundedAbove a ⦄ → Int + maxInt ⦃ _ ⦄ = fromEnum maxBound + + field + toEnum : (n : Int) → @0 ⦃ TrueIfLB (minInt <= n) ⦄ → @0 ⦃ TrueIfUB (n <= maxInt) ⦄ → a + succ : (x : a) → @0 ⦃ FalseIfUB (fromEnum x == maxInt) ⦄ → a + pred : (x : a) → @0 ⦃ FalseIfLB (fromEnum x == minInt) ⦄ → a + + enumFrom : @0 ⦃ IsBoundedAbove ⦄ → a → List a + enumFromTo : a → a → List a + -- In the Prelude Enum instances `enumFromThenTo x x y` gives the + -- infinite list of `x`s. The constraint is a little bit stronger than it needs to be, + -- since it rules out different x and x₁ that maps to the same Int, but this saves us + -- requiring an Eq instance for `a`, and it's not a terrible limitation to not be able to + -- write [0, 2^64 .. 2^66]. + enumFromThenTo : (x x₁ : a) → @0 ⦃ IsFalse (fromEnum x == fromEnum x₁) ⦄ → a → List a + enumFromThen : @0 ⦃ IsBoundedBelow ⦄ → @0 ⦃ IsBoundedAbove ⦄ → (x x₁ : a) → @0 ⦃ IsFalse (fromEnum x == fromEnum x₁) ⦄ → List a + +open Enum ⦃...⦄ public + +{-# COMPILE AGDA2HS Enum existing-class #-} + +private + divNat : Nat → Nat → Nat + divNat a 0 = 0 + divNat a (suc b) = div-helper 0 b a b + + diff : Integer → Integer → Maybe Nat + diff a b = + case a - b of λ where + (pos n) → Just n + (negsuc _) → Nothing + + unsafeIntegerToNat : Integer → Nat + unsafeIntegerToNat (pos n) = n + unsafeIntegerToNat (negsuc _) = 0 + + integerFromCount : Integer → Integer → Nat → List Integer + integerFromCount a step 0 = [] + integerFromCount a step (suc n) = a ∷ integerFromCount (a + step) step n + + integerFromTo : Integer → Integer → List Integer + integerFromTo a b = maybe [] (integerFromCount a 1 ∘ suc) (diff b a) + + integerFromThenTo : (a a₁ : Integer) → @0 ⦃ IsFalse (integerToInt a == integerToInt a₁) ⦄ → Integer → List Integer + integerFromThenTo a a₁ b = + case compare a a₁ of λ where + LT → maybe [] (λ d → integerFromCount a (a₁ - a) (suc (divNat d (unsafeIntegerToNat (a₁ - a))))) (diff b a) + EQ → [] -- impossible + GT → maybe [] (λ d → integerFromCount a (a₁ - a) (suc (divNat d (unsafeIntegerToNat (a - a₁))))) (diff a b) + +instance + iEnumInteger : Enum Integer + iEnumInteger .BoundedBelowEnum = Nothing + iEnumInteger .BoundedAboveEnum = Nothing + iEnumInteger .fromEnum = integerToInt + iEnumInteger .toEnum n = intToInteger n + iEnumInteger .succ = _+ 1 + iEnumInteger .pred = _- 1 + iEnumInteger .enumFromTo = integerFromTo + iEnumInteger .enumFromThenTo = integerFromThenTo + +private + fromTo : (from : a → Integer) (to : Integer → a) + → a → a → List a + fromTo from to a b = map to (enumFromTo (from a) (from b)) + + fromThenTo : (from : a → Integer) (to : Integer → a) + → (x x₁ : a) → @0 ⦃ IsFalse (fromEnum (from x) == fromEnum (from x₁)) ⦄ → a → List a + fromThenTo from to a a₁ b = map to (enumFromThenTo (from a) (from a₁) (from b)) + + +instance + iEnumNat : Enum Nat + iEnumNat .BoundedBelowEnum = Just it + iEnumNat .BoundedAboveEnum = Nothing + iEnumNat .fromEnum = integerToInt ∘ pos + iEnumNat .toEnum n = unsafeIntegerToNat (intToInteger n) + iEnumNat .succ n = suc n + iEnumNat .pred (suc n) = n + iEnumNat .enumFromTo = fromTo pos unsafeIntegerToNat + iEnumNat .enumFromThenTo = fromThenTo pos unsafeIntegerToNat + + iEnumInt : Enum Int + iEnumInt .BoundedBelowEnum = Just it + iEnumInt .BoundedAboveEnum = Just it + iEnumInt .fromEnum = integerToInt ∘ intToInteger + iEnumInt .toEnum n = integerToInt (intToInteger n) + iEnumInt .succ x = integerToInt (intToInteger x + 1) + iEnumInt .pred x = integerToInt (intToInteger x - 1) + iEnumInt .enumFromTo a b = fromTo intToInteger integerToInt a b + iEnumInt .enumFromThenTo a a₁ b = fromThenTo intToInteger integerToInt a a₁ b + iEnumInt .enumFrom a = fromTo intToInteger integerToInt a maxBound + iEnumInt .enumFromThen a a₁ = + if a < a₁ then fromThenTo intToInteger integerToInt a a₁ maxBound + else fromThenTo intToInteger integerToInt a a₁ minBound + + iEnumWord : Enum Word + iEnumWord .BoundedBelowEnum = Just it + iEnumWord .BoundedAboveEnum = Just it + iEnumWord .fromEnum = integerToInt ∘ wordToInteger + iEnumWord .toEnum n = integerToWord (intToInteger n) + iEnumWord .succ x = integerToWord (wordToInteger x + 1) + iEnumWord .pred x = integerToWord (wordToInteger x - 1) + iEnumWord .enumFromTo a b = fromTo wordToInteger integerToWord a b + iEnumWord .enumFromThenTo a a₁ b = fromThenTo wordToInteger integerToWord a a₁ b + iEnumWord .enumFrom a = fromTo wordToInteger integerToWord a maxBound + iEnumWord .enumFromThen a a₁ = + if a < a₁ then fromThenTo wordToInteger integerToWord a a₁ maxBound + else fromThenTo wordToInteger integerToWord a a₁ minBound + +private + fromBool : Bool → Integer + fromBool = if_then 1 else 0 + + toBool : Integer → Bool + toBool = _/= 0 + +instance + iEnumBool : Enum Bool + iEnumBool .BoundedBelowEnum = Just it + iEnumBool .BoundedAboveEnum = Just it + iEnumBool .fromEnum = integerToInt ∘ fromBool + iEnumBool .toEnum n = toBool (intToInteger n) + iEnumBool .succ x = toBool (fromBool x + 1) + iEnumBool .pred x = toBool (fromBool x - 1) + iEnumBool .enumFromTo a b = fromTo fromBool toBool a b + iEnumBool .enumFromThenTo a a₁ b = fromThenTo fromBool toBool a a₁ b + iEnumBool .enumFrom a = fromTo fromBool toBool a maxBound + iEnumBool .enumFromThen a a₁ = + if a < a₁ then fromThenTo fromBool toBool a a₁ maxBound + else fromThenTo fromBool toBool a a₁ minBound + +private + fromOrdering : Ordering → Integer + fromOrdering = λ where LT → 0; EQ → 1; GT → 2 + + toOrdering : Integer → Ordering + toOrdering = λ where (pos 0) → LT; (pos 1) → EQ; _ → GT + +instance + iEnumOrdering : Enum Ordering + iEnumOrdering .BoundedBelowEnum = Just it + iEnumOrdering .BoundedAboveEnum = Just it + iEnumOrdering .fromEnum = integerToInt ∘ fromOrdering + iEnumOrdering .toEnum n = toOrdering (intToInteger n) + iEnumOrdering .succ x = toOrdering (fromOrdering x + 1) + iEnumOrdering .pred x = toOrdering (fromOrdering x - 1) + iEnumOrdering .enumFromTo a b = fromTo fromOrdering toOrdering a b + iEnumOrdering .enumFromThenTo a a₁ b = fromThenTo fromOrdering toOrdering a a₁ b + iEnumOrdering .enumFrom a = fromTo fromOrdering toOrdering a maxBound + iEnumOrdering .enumFromThen a a₁ = + if a < a₁ then fromThenTo fromOrdering toOrdering a a₁ maxBound + else fromThenTo fromOrdering toOrdering a a₁ minBound + +private + fromUnit : ⊤ → Integer + fromUnit _ = 0 + + toUnit : Integer → ⊤ + toUnit _ = tt + +instance + iEnumUnit : Enum ⊤ + iEnumUnit .BoundedBelowEnum = Just it + iEnumUnit .BoundedAboveEnum = Just it + iEnumUnit .fromEnum = integerToInt ∘ fromUnit + iEnumUnit .toEnum n = toUnit (intToInteger n) + iEnumUnit .succ x = toUnit (fromUnit x + 1) + iEnumUnit .pred x = toUnit (fromUnit x - 1) + iEnumUnit .enumFromTo a b = fromTo fromUnit toUnit a b + iEnumUnit .enumFromThenTo a a₁ b = fromThenTo fromUnit toUnit a a₁ b + iEnumUnit .enumFrom a = fromTo fromUnit toUnit a maxBound + iEnumUnit .enumFromThen a a₁ = + if a < a₁ then fromThenTo fromUnit toUnit a a₁ maxBound + else fromThenTo fromUnit toUnit a a₁ minBound + +private + fromChar : Char → Integer + fromChar = pos ∘ c2n + + toChar : Integer → Char + toChar = λ where (pos n) → primNatToChar n; _ → '_' + +instance + iEnumChar : Enum Char + iEnumChar .BoundedBelowEnum = Just it + iEnumChar .BoundedAboveEnum = Just it + iEnumChar .fromEnum = integerToInt ∘ fromChar + iEnumChar .toEnum n = toChar (intToInteger n) + iEnumChar .succ x = toChar (fromChar x + 1) + iEnumChar .pred x = toChar (fromChar x - 1) + iEnumChar .enumFromTo a b = fromTo fromChar toChar a b + iEnumChar .enumFromThenTo a a₁ b = fromThenTo fromChar toChar a a₁ b + iEnumChar .enumFrom a = fromTo fromChar toChar a maxBound + iEnumChar .enumFromThen a a₁ = + if a < a₁ then fromThenTo fromChar toChar a a₁ maxBound + else fromThenTo fromChar toChar a a₁ minBound + + -- Missing: + -- Enum Double (can't go via Integer) diff --git a/lib/base/Haskell/Prim/Eq.agda b/lib/base/Haskell/Prim/Eq.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Eq.agda @@ -0,0 +1,82 @@ + +module Haskell.Prim.Eq where + +open import Haskell.Prim +open import Haskell.Prim.Bool +open import Haskell.Prim.Char +open import Haskell.Prim.Integer +open import Haskell.Prim.Int +open import Haskell.Prim.Word +open import Haskell.Prim.Double +open import Haskell.Prim.Tuple +open import Haskell.Prim.Maybe +open import Haskell.Prim.Either + +-------------------------------------------------- +-- Eq + +record Eq (a : Type) : Type where + infix 4 _==_ + field + _==_ : a → a → Bool + +open Eq ⦃...⦄ public + +{-# COMPILE AGDA2HS Eq existing-class #-} + +_/=_ : {{Eq a}} → a → a → Bool +x /= y = not (x == y) + +infix 4 _/=_ + +instance + iEqNat : Eq Nat + iEqNat ._==_ = eqNat + + iEqInteger : Eq Integer + iEqInteger ._==_ = eqInteger + + iEqInt : Eq Int + iEqInt ._==_ = eqInt + + iEqWord : Eq Word + iEqWord ._==_ = eqWord + + iEqDouble : Eq Double + iEqDouble ._==_ = primFloatEquality + + iEqBool : Eq Bool + iEqBool ._==_ False False = True + iEqBool ._==_ True True = True + iEqBool ._==_ _ _ = False + + iEqChar : Eq Char + iEqChar ._==_ = eqChar + + iEqUnit : Eq ⊤ + iEqUnit ._==_ _ _ = True + + iEqTuple₂ : ⦃ Eq a ⦄ → ⦃ Eq b ⦄ → Eq (a × b) + iEqTuple₂ ._==_ (x₁ , y₁) (x₂ , y₂) = x₁ == x₂ && y₁ == y₂ + + iEqTuple₃ : ⦃ Eq a ⦄ → ⦃ Eq b ⦄ → ⦃ Eq c ⦄ → Eq (a × b × c) + iEqTuple₃ ._==_ (x₁ , y₁ , z₁) (x₂ , y₂ , z₂) = x₁ == x₂ && y₁ == y₂ && z₁ == z₂ + + iEqList : ⦃ Eq a ⦄ → Eq (List a) + iEqList {a} ._==_ = eqList + where + eqList : List a → List a → Bool + eqList [] [] = True + eqList (x ∷ xs) (y ∷ ys) = x == y && eqList xs ys + eqList _ _ = False + + + iEqMaybe : ⦃ Eq a ⦄ → Eq (Maybe a) + iEqMaybe ._==_ Nothing Nothing = True + iEqMaybe ._==_ (Just x) (Just y) = x == y + iEqMaybe ._==_ _ _ = False + + iEqEither : ⦃ Eq a ⦄ → ⦃ Eq b ⦄ → Eq (Either a b) + iEqEither ._==_ (Left x) (Left y) = x == y + iEqEither ._==_ (Right x) (Right y) = x == y + iEqEither ._==_ _ _ = False diff --git a/lib/base/Haskell/Prim/Foldable.agda b/lib/base/Haskell/Prim/Foldable.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Foldable.agda @@ -0,0 +1,122 @@ + +module Haskell.Prim.Foldable where + +open import Haskell.Prim +open import Haskell.Prim.Num hiding (abs) +open import Haskell.Prim.Eq +open import Haskell.Prim.List +open import Haskell.Prim.Int +open import Haskell.Prim.Bool +open import Haskell.Prim.Maybe +open import Haskell.Prim.Either +open import Haskell.Prim.Tuple +open import Haskell.Prim.Monoid + +-------------------------------------------------- +-- Foldable + +-- ** base +record Foldable (t : Type → Type) : Type₁ where + field + foldMap : ⦃ Monoid b ⦄ → (a → b) → t a → b + foldr : (a → b → b) → b → t a → b + foldl : (b → a → b) → b → t a → b + any : (a → Bool) → t a → Bool + all : (a → Bool) → t a → Bool + and : t Bool → Bool + null : t a → Bool + or : t Bool → Bool + concat : t (List a) → List a + concatMap : (a → List b) → t a → List b + elem : ⦃ Eq a ⦄ → a → t a → Bool + notElem : ⦃ Eq a ⦄ → a → t a → Bool + toList : t a → List a + sum : ⦃ iNum : Num a ⦄ → t a → a + product : ⦃ iNum : Num a ⦄ → t a → a + length : t a → Int +-- ** defaults +record DefaultFoldable (t : Type → Type) : Type₁ where + module M = Foldable {t = t} + field foldMap : ⦃ Monoid b ⦄ → (a → b) → t a → b + + foldr : (a → b → b) → b → t a → b + foldr f z t = foldMap ⦃ MonoidEndo ⦄ f t z + + foldl : (b → a → b) → b → t a → b + foldl f z t = foldMap ⦃ MonoidEndoᵒᵖ ⦄ (flip f) t z + + any : (a → Bool) → t a → Bool + any = foldMap ⦃ MonoidDisj ⦄ + + all : (a → Bool) → t a → Bool + all = foldMap ⦃ MonoidConj ⦄ + + and : t Bool → Bool + and = all id + + or : t Bool → Bool + or = any id + + null : t a → Bool + null = all (const False) + + concat : t (List a) → List a + concat = foldMap id + + concatMap : (a → List b) → t a → List b + concatMap = foldMap + + elem : ⦃ Eq a ⦄ → a → t a → Bool + elem x = foldMap ⦃ MonoidDisj ⦄ (x ==_) + + notElem : ⦃ Eq a ⦄ → a → t a → Bool + notElem x t = not (elem x t) + + toList : t a → List a + toList = foldr _∷_ [] + + sum : ⦃ iNum : Num a ⦄ → t a → a + sum = foldMap ⦃ MonoidSum ⦄ id + + product : ⦃ iNum : Num a ⦄ → t a → a + product = foldMap ⦃ MonoidProduct ⦄ id + + length : t a → Int + length = foldMap ⦃ MonoidSum ⦄ (const 1) +-- ** export +open Foldable ⦃...⦄ public +{-# COMPILE AGDA2HS Foldable existing-class #-} + +-- ** instances +instance + iDefaultFoldableList : DefaultFoldable List + iDefaultFoldableList .DefaultFoldable.foldMap = foldMapList + where + foldMapList : ⦃ Monoid b ⦄ → (a → b) → List a → b + foldMapList f [] = mempty + foldMapList f (x ∷ xs) = f x <> foldMapList f xs + + iFoldableList : Foldable List + iFoldableList = record {DefaultFoldable iDefaultFoldableList} + + iDefaultFoldableMaybe : DefaultFoldable Maybe + iDefaultFoldableMaybe .DefaultFoldable.foldMap = λ where + _ Nothing → mempty + f (Just x) → f x + + iFoldableMaybe : Foldable Maybe + iFoldableMaybe = record {DefaultFoldable iDefaultFoldableMaybe} + + iDefaultFoldableEither : DefaultFoldable (Either a) + iDefaultFoldableEither .DefaultFoldable.foldMap = λ where + _ (Left _) → mempty + f (Right x) → f x + + iFoldableEither : Foldable (Either a) + iFoldableEither = record {DefaultFoldable iDefaultFoldableEither} + + iDefaultFoldablePair : DefaultFoldable (a ×_) + iDefaultFoldablePair .DefaultFoldable.foldMap = λ f (_ , x) → f x + + iFoldablePair : Foldable (a ×_) + iFoldablePair = record {DefaultFoldable iDefaultFoldablePair} diff --git a/lib/base/Haskell/Prim/Functor.agda b/lib/base/Haskell/Prim/Functor.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Functor.agda @@ -0,0 +1,89 @@ + +module Haskell.Prim.Functor where + +open import Haskell.Prim +open import Haskell.Prim.Either +open import Haskell.Prim.IO +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Tuple + +-------------------------------------------------- +-- Functor + +-- ** base +record Functor (f : Type → Type) : Type₁ where + infixl 4 _<$_ + field + fmap : (a → b) → f a → f b + _<$_ : (@0 {{ b }} → a) → f b → f a +-- ** defaults +record DefaultFunctor (f : Type → Type) : Type₁ where + field fmap : (a → b) → f a → f b + + infixl 4 _<$_ + + _<$_ : (@0 {{ b }} → a) → f b → f a + x <$ m = fmap (λ b → x {{b}}) m + +-- ** export +open Functor ⦃...⦄ public +{-# COMPILE AGDA2HS Functor existing-class #-} + +_<$>_ : {{Functor f}} → (a → b) → f a → f b +_<$>_ = fmap + +_<&>_ : {{Functor f}} → f a → (a → b) → f b +m <&> f = fmap f m + +_$>_ : {{Functor f}} → f a → (@0 {{ a }} → b) → f b +m $> x = x <$ m + +void : {{Functor f}} → f a → f ⊤ +void = tt <$_ + +infixl 1 _<&>_ +infixl 4 _<$>_ _$>_ + +instance + iDefaultFunctorList : DefaultFunctor List + iDefaultFunctorList .DefaultFunctor.fmap = map + + iFunctorList : Functor List + iFunctorList = record{DefaultFunctor iDefaultFunctorList} + + iDefaultFunctorMaybe : DefaultFunctor Maybe + iDefaultFunctorMaybe .DefaultFunctor.fmap = λ where + f Nothing → Nothing + f (Just x) → Just (f x) + + iFunctorMaybe : Functor Maybe + iFunctorMaybe = record{DefaultFunctor iDefaultFunctorMaybe} + + iDefaultFunctorEither : DefaultFunctor (Either a) + iDefaultFunctorEither .DefaultFunctor.fmap = λ where + f (Left x) → Left x + f (Right y) → Right (f y) + + iFunctorEither : Functor (Either a) + iFunctorEither = record{DefaultFunctor iDefaultFunctorEither} + + iDefaultFunctorFun : DefaultFunctor (λ b → a → b) + iDefaultFunctorFun .DefaultFunctor.fmap = _∘_ + + iFunctorFun : Functor (λ b → a → b) + iFunctorFun = record{DefaultFunctor iDefaultFunctorFun} + + iDefaultFunctorTuple₂ : DefaultFunctor (a ×_) + iDefaultFunctorTuple₂ .DefaultFunctor.fmap = λ f (x , y) → x , f y + + iFunctorTuple₂ : Functor (a ×_) + iFunctorTuple₂ = record{DefaultFunctor iDefaultFunctorTuple₂} + + iDefaultFunctorTuple₃ : DefaultFunctor (a × b ×_) + iDefaultFunctorTuple₃ .DefaultFunctor.fmap = λ where f (x , y , z) → x , y , f z + + iFunctorTuple₃ : Functor (a × b ×_) + iFunctorTuple₃ = record{DefaultFunctor iDefaultFunctorTuple₃} + +instance postulate iFunctorIO : Functor IO diff --git a/lib/base/Haskell/Prim/IO.agda b/lib/base/Haskell/Prim/IO.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/IO.agda @@ -0,0 +1,27 @@ +module Haskell.Prim.IO where + +open import Haskell.Prim +open import Haskell.Prim.Show +open import Haskell.Prim.String + +postulate IO : ∀{a} → Type a → Type a + +FilePath = String + +postulate + -- Input functions + interact : (String → String) → IO ⊤ + getContents : IO String + getLine : IO String + getChar : IO Char + + -- Output functions + print : ⦃ Show a ⦄ → a → IO ⊤ + putChar : Char → IO ⊤ + putStr : String → IO ⊤ + putStrLn : String → IO ⊤ + + -- Files + readFile : FilePath → IO String + writeFile : FilePath → String → IO ⊤ + appendFile : FilePath → String → IO ⊤ diff --git a/lib/base/Haskell/Prim/Int.agda b/lib/base/Haskell/Prim/Int.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Int.agda @@ -0,0 +1,110 @@ +{-# OPTIONS --no-auto-inline #-} + +-- Agda doesn't have an Int type (only Word64). With some work we +-- can represent signed ints using Word64. + +module Haskell.Prim.Int where + +open import Haskell.Prim +open import Haskell.Prim.Word +open import Haskell.Prim.Integer +open import Haskell.Prim.Bool + + +-------------------------------------------------- +-- Definition + +data Int : Type where + int64 : Word64 → Int + +intToWord : Int → Word64 +intToWord (int64 a) = a + +unsafeIntToNat : Int → Nat +unsafeIntToNat a = w2n (intToWord a) + + +-------------------------------------------------- +-- Literals + +private + 2⁶⁴ : Nat + 2⁶⁴ = 18446744073709551616 + + 2⁶³ : Nat + 2⁶³ = 9223372036854775808 + + maxInt : Nat + maxInt = monusNat 2⁶³ 1 + +instance + iNumberInt : Number Int + iNumberInt .Number.Constraint n = IsTrue (ltNat n 2⁶³) + iNumberInt .fromNat n = int64 (n2w n) + + iNegativeInt : Negative Int + iNegativeInt .Negative.Constraint n = IsTrue (ltNat n (addNat 1 2⁶³)) + iNegativeInt .fromNeg n = int64 (n2w (monusNat 2⁶⁴ n)) + + +-------------------------------------------------- +-- Arithmetic + +isNegativeInt : Int → Bool +isNegativeInt (int64 w) = ltNat maxInt (w2n w) + +eqInt : Int → Int → Bool +eqInt (int64 a) (int64 b) = eqNat (w2n a) (w2n b) + +negateInt : Int → Int +negateInt (int64 a) = int64 (n2w (monusNat 2⁶⁴ (w2n a))) + +intToInteger : Int → Integer +intToInteger a = if isNegativeInt a then negsuc (monusNat (unsafeIntToNat (negateInt a)) 1) + else pos (unsafeIntToNat a) + +integerToInt : Integer → Int +integerToInt (pos n) = int64 (n2w n) +integerToInt (negsuc n) = negateInt (int64 (n2w (suc n))) + +private + ltPosInt : Int → Int → Bool + ltPosInt (int64 a) (int64 b) = ltWord a b + +ltInt : Int → Int → Bool +ltInt a b with isNegativeInt a | isNegativeInt b +... | True | False = True +... | False | True = False +... | True | True = ltPosInt (negateInt b) (negateInt a) +... | False | False = ltPosInt a b + +addInt : Int → Int → Int +addInt (int64 a) (int64 b) = int64 (addWord a b) + +subInt : Int → Int → Int +subInt a b = addInt a (negateInt b) + +mulInt : Int → Int → Int +mulInt (int64 a) (int64 b) = int64 (mulWord a b) + +absInt : Int → Int +absInt a = if isNegativeInt a then negateInt a else a + +signInt : Int → Int +signInt a = if isNegativeInt a then -1 + else if eqInt a 0 then 0 else 1 + +showInt : Int → List Char +showInt a = showInteger (intToInteger a) + + +-------------------------------------------------- +-- Constraints + +@0 IsNonNegativeInt : Int → Type +IsNonNegativeInt a@(int64 _) = + if isNegativeInt a then TypeError (primStringAppend (primStringFromList (showInt a)) " is negative") + else ⊤ + +intToNat : (a : Int) → @0 ⦃ IsNonNegativeInt a ⦄ → Nat +intToNat a = unsafeIntToNat a diff --git a/lib/base/Haskell/Prim/Integer.agda b/lib/base/Haskell/Prim/Integer.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Integer.agda @@ -0,0 +1,106 @@ + +module Haskell.Prim.Integer where + +open import Haskell.Prim +open import Haskell.Prim.Bool + +{-| +This module contains functions that should not be used +within code that is supposed to be translated to Haskell. +Nevertheless, these functions must be accessible for +proofs (within the standard library). +Hence, these functions are not flagged as private but +instead are collected in a dedicated module that is not +opened by default. +-} +module Internal where + negNat : Nat → Integer + negNat 0 = pos 0 + negNat (suc n) = negsuc n + + subNat : Nat → Nat → Integer + subNat n zero = pos n + subNat zero (suc m) = negsuc m + subNat (suc n) (suc m) = subNat n m +open Internal + +-------------------------------------------------- +-- Literals + + +instance + iNumberInteger : Number Integer + iNumberInteger .Number.Constraint _ = ⊤ + iNumberInteger .fromNat n = pos n + + iNegativeInteger : Negative Integer + iNegativeInteger .Negative.Constraint _ = ⊤ + iNegativeInteger .fromNeg n = negNat n + + +-------------------------------------------------- +-- Arithmetic + +negateInteger : Integer → Integer +negateInteger (pos 0) = pos 0 +negateInteger (pos (suc n)) = negsuc n +negateInteger (negsuc n) = pos (suc n) + +addInteger : Integer → Integer → Integer +addInteger (pos n) (pos m) = pos (addNat n m) +addInteger (pos n) (negsuc m) = subNat n (suc m) +addInteger (negsuc n) (pos m) = subNat m (suc n) +addInteger (negsuc n) (negsuc m) = negsuc (suc (addNat n m)) + +subInteger : Integer → Integer → Integer +subInteger n m = addInteger n (negateInteger m) + +mulInteger : Integer → Integer → Integer +mulInteger (pos n) (pos m) = pos (mulNat n m) +mulInteger (pos n) (negsuc m) = negNat (mulNat n (suc m)) +mulInteger (negsuc n) (pos m) = negNat (mulNat (suc n) m) +mulInteger (negsuc n) (negsuc m) = pos (mulNat (suc n) (suc m)) + +absInteger : Integer → Integer +absInteger (pos n) = pos n +absInteger (negsuc n) = pos (suc n) + +signInteger : Integer → Integer +signInteger (pos 0) = 0 +signInteger (pos (suc _)) = 1 +signInteger (negsuc _) = -1 + + +-------------------------------------------------- +-- Comparisons + +eqInteger : Integer → Integer → Bool +eqInteger (pos n) (pos m) = eqNat n m +eqInteger (negsuc n) (negsuc m) = eqNat n m +eqInteger _ _ = False + +ltInteger : Integer → Integer → Bool +ltInteger (pos n) (pos m) = ltNat n m +ltInteger (pos n) (negsuc _) = False +ltInteger (negsuc n) (pos _) = True +ltInteger (negsuc n) (negsuc m) = ltNat m n + + +-------------------------------------------------- +-- Show + +showInteger : Integer → List Char +showInteger n = primStringToList (primShowInteger n) + + +-------------------------------------------------- +-- Constraints + +isNegativeInteger : Integer → Bool +isNegativeInteger (pos _) = False +isNegativeInteger (negsuc _) = True + +@0 IsNonNegativeInteger : Integer → Type +IsNonNegativeInteger (pos _) = ⊤ +IsNonNegativeInteger n@(negsuc _) = + TypeError (primStringAppend (primShowInteger n) (" is negative")) diff --git a/lib/base/Haskell/Prim/List.agda b/lib/base/Haskell/Prim/List.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/List.agda @@ -0,0 +1,128 @@ + +module Haskell.Prim.List where + +open import Haskell.Prim +open import Haskell.Prim.Bool +open import Haskell.Prim.Tuple +open import Haskell.Prim.Int + + +-------------------------------------------------- +-- List + +map : (a → b) → List a → List b +map f [] = [] +map f (x ∷ xs) = f x ∷ map f xs + +infixr 5 _++_ +_++_ : ∀ {@0 ℓ} {@0 a : Type ℓ} → List a → List a → List a +[] ++ ys = ys +(x ∷ xs) ++ ys = x ∷ xs ++ ys + +filter : (a → Bool) → List a → List a +filter p [] = [] +filter p (x ∷ xs) = if p x then x ∷ filter p xs else filter p xs + +scanl : (b → a → b) → b → List a → List b +scanl f z [] = z ∷ [] +scanl f z (x ∷ xs) = z ∷ scanl f (f z x) xs + +scanr : (a → b → b) → b → List a → List b +scanr f z [] = z ∷ [] +scanr f z (x ∷ xs) = + case scanr f z xs of λ where + [] → [] -- impossible + qs@(q ∷ _) → f x q ∷ qs + +scanl1 : (a → a → a) → List a → List a +scanl1 f [] = [] +scanl1 f (x ∷ xs) = scanl f x xs + +scanr1 : (a → a → a) → List a → List a +scanr1 f [] = [] +scanr1 f (x ∷ []) = x ∷ [] +scanr1 f (x ∷ xs) = + case scanr1 f xs of λ where + [] → [] -- impossible + qs@(q ∷ _) → f x q ∷ qs + +takeWhile : (a → Bool) → List a → List a +takeWhile p [] = [] +takeWhile p (x ∷ xs) = if p x then x ∷ takeWhile p xs else [] + +dropWhile : (a → Bool) → List a → List a +dropWhile p [] = [] +dropWhile p (x ∷ xs) = if p x then dropWhile p xs else x ∷ xs + +span : (a → Bool) → List a → List a × List a +span p [] = [] , [] +span p (x ∷ xs) = if p x then first (x ∷_) (span p xs) + else ([] , x ∷ xs) + +break : (a → Bool) → List a → List a × List a +break p = span (not ∘ p) + +zipWith : (a → b → c) → List a → List b → List c +zipWith f [] _ = [] +zipWith f _ [] = [] +zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys + +zip : List a → List b → List (a × b) +zip = zipWith _,_ + +zipWith3 : (a → b → c → d) → List a → List b → List c → List d +zipWith3 f [] _ _ = [] +zipWith3 f _ [] _ = [] +zipWith3 f _ _ [] = [] +zipWith3 f (x ∷ xs) (y ∷ ys) (z ∷ zs) = f x y z ∷ zipWith3 f xs ys zs + +zip3 : List a → List b → List c → List (a × b × c) +zip3 = zipWith3 _,_,_ + +unzip : List (a × b) → List a × List b +unzip [] = [] , [] +unzip ((x , y) ∷ xys) = (x ∷_) *** (y ∷_) $ unzip xys + +unzip3 : List (a × b × c) → List a × List b × List c +unzip3 [] = [] , [] , [] +unzip3 ((x , y , z) ∷ xyzs) = + case unzip3 xyzs of λ where + (xs , ys , zs) → x ∷ xs , y ∷ ys , z ∷ zs + +takeNat : Nat → List a → List a +takeNat n [] = [] +takeNat zero xs = [] +takeNat (suc n) (x ∷ xs) = x ∷ takeNat n xs + +take : (n : Int) → @0 ⦃ IsNonNegativeInt n ⦄ → List a → List a +take n xs = takeNat (intToNat n) xs + +dropNat : Nat → List a → List a +dropNat n [] = [] +dropNat zero xs = xs +dropNat (suc n) (_ ∷ xs) = dropNat n xs + +drop : (n : Int) → @0 ⦃ IsNonNegativeInt n ⦄ → List a → List a +drop n xs = dropNat (intToNat n) xs + +splitAtNat : (n : Nat) → List a → List a × List a +splitAtNat _ [] = [] , [] +splitAtNat 0 xs = [] , xs +splitAtNat (suc n) (x ∷ xs) = first (x ∷_) (splitAtNat n xs) + +splitAt : (n : Int) → @0 ⦃ IsNonNegativeInt n ⦄ → List a → List a × List a +splitAt n xs = splitAtNat (intToNat n) xs + +head : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → a +head (x ∷ _) = x + +tail : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → List a +tail (_ ∷ xs) = xs + +last : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → a +last (x ∷ []) = x +last (_ ∷ xs@(_ ∷ _)) = last xs + +init : (xs : List a) → @0 ⦃ NonEmpty xs ⦄ → List a +init (x ∷ []) = [] +init (x ∷ xs@(_ ∷ _)) = x ∷ init xs diff --git a/lib/base/Haskell/Prim/Maybe.agda b/lib/base/Haskell/Prim/Maybe.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Maybe.agda @@ -0,0 +1,14 @@ +module Haskell.Prim.Maybe where + +open import Haskell.Prim + +-------------------------------------------------- +-- Maybe + +data Maybe {@0 ℓ} (a : Type ℓ) : Type ℓ where + Nothing : Maybe a + Just : a -> Maybe a + +maybe : ∀ {@0 ℓ₁ ℓ₂} {@0 a : Type ℓ₁} {@0 b : Type ℓ₂} → b → (a → b) → Maybe a → b +maybe n j Nothing = n +maybe n j (Just x) = j x diff --git a/lib/base/Haskell/Prim/Monad.agda b/lib/base/Haskell/Prim/Monad.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Monad.agda @@ -0,0 +1,137 @@ + +module Haskell.Prim.Monad where + +open import Haskell.Prim +open import Haskell.Prim.Applicative +open import Haskell.Prim.Either +open import Haskell.Prim.Foldable +open import Haskell.Prim.Functor +open import Haskell.Prim.IO +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Monoid +open import Haskell.Prim.String +open import Haskell.Prim.Tuple + +------------------------------------------------------------------------------- +-- Monad + +module Do where + + -- ** base + record Monad (m : Type → Type) : Type₁ where + field + _>>=_ : m a → (a → m b) → m b + overlap ⦃ super ⦄ : Applicative m + return : a → m a + _>>_ : m a → (@0 {{ a }} → m b) → m b + -- ** defaults + record DefaultMonad (m : Type → Type) : Type₁ where + field + _>>=_ : m a → (a → m b) → m b + overlap ⦃ super ⦄ : Applicative m + return : a → m a + return = pure + + _>>_ : m a → (@0 {{ a }} → m b) → m b + m >> m₁ = m >>= λ x → m₁ {{x}} + + -- ** export + open Monad ⦃...⦄ public + {-# COMPILE AGDA2HS Monad existing-class #-} + +-- Use `Dont._>>=_` and `Dont._>>_` if you do not want agda2hs to use +-- do-notation. +module Dont where + + open Do using (Monad) + + _>>=_ : ⦃ Monad m ⦄ → m a → (a → m b) → m b + _>>=_ = Do._>>=_ + + _>>_ : ⦃ Monad m ⦄ → m a → (@0 {{ a }} → m b) → m b + _>>_ = Do._>>_ + +open Do public + +_=<<_ : {{Monad m}} → (a → m b) → m a → m b +_=<<_ = flip _>>=_ + +mapM₋ : ⦃ Monad m ⦄ → ⦃ Foldable t ⦄ → (a → m b) → t a → m ⊤ +mapM₋ f = foldr (λ x k → f x >> k) (pure tt) + +sequence₋ : ⦃ Monad m ⦄ → ⦃ Foldable t ⦄ → t (m a) → m ⊤ +sequence₋ = foldr (λ mx my → mx >> my) (pure tt) + +-- ** instances +instance + iDefaultMonadList : DefaultMonad List + iDefaultMonadList .DefaultMonad._>>=_ = flip concatMap + + iMonadList : Monad List + iMonadList = record {DefaultMonad iDefaultMonadList} + + iDefaultMonadMaybe : DefaultMonad Maybe + iDefaultMonadMaybe .DefaultMonad._>>=_ = flip (maybe Nothing) + + iMonadMaybe : Monad Maybe + iMonadMaybe = record {DefaultMonad iDefaultMonadMaybe} + + iDefaultMonadEither : DefaultMonad (Either a) + iDefaultMonadEither .DefaultMonad._>>=_ = flip (either Left) + + iMonadEither : Monad (Either a) + iMonadEither = record {DefaultMonad iDefaultMonadEither} + + iDefaultMonadFun : DefaultMonad (λ b → a → b) + iDefaultMonadFun .DefaultMonad._>>=_ = λ f k r → k (f r) r + + iMonadFun : Monad (λ b → a → b) + iMonadFun = record {DefaultMonad iDefaultMonadFun} + + iDefaultMonadTuple₂ : ⦃ Monoid a ⦄ → DefaultMonad (a ×_) + iDefaultMonadTuple₂ .DefaultMonad._>>=_ = λ (a , x) k → first (a <>_) (k x) + + iMonadTuple₂ : ⦃ Monoid a ⦄ → Monad (a ×_) + iMonadTuple₂ = record {DefaultMonad iDefaultMonadTuple₂} + + iDefaultMonadTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → DefaultMonad (a × b ×_) + iDefaultMonadTuple₃ .DefaultMonad._>>=_ = λ where + (a , b , x) k → case k x of λ where + (a₁ , b₁ , y) → a <> a₁ , b <> b₁ , y + + iMonadTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Monad (a × b ×_) + iMonadTuple₃ = record {DefaultMonad iDefaultMonadTuple₃} + +-- For 'Monad IO', we only postulate the '_>>=_' operation, +-- and construct the instance via 'DefaultMonad' as usual. +-- This is necessary to ensure that the existing 'Applicative IO' +-- instance is picked for the 'super' instance field. +postulate + bindIO : IO a → (a → IO b) → IO b + +instance + iDefaultMonadIO : DefaultMonad IO + iDefaultMonadIO .DefaultMonad._>>=_ = bindIO + + iMonadIO : Monad IO + iMonadIO = record {DefaultMonad iDefaultMonadIO} + +------------------------------------------------------------------------------- +-- MonadFail class + +record MonadFail (m : Type → Type) : Type₁ where + field + fail : String → m a + overlap ⦃ super ⦄ : Monad m + +open MonadFail ⦃...⦄ public + +{-# COMPILE AGDA2HS MonadFail existing-class #-} + +instance + MonadFailList : MonadFail List + MonadFailList .fail _ = [] + + MonadFailMaybe : MonadFail Maybe + MonadFailMaybe .fail _ = Nothing diff --git a/lib/base/Haskell/Prim/Monoid.agda b/lib/base/Haskell/Prim/Monoid.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Monoid.agda @@ -0,0 +1,130 @@ + +module Haskell.Prim.Monoid where + +open import Haskell.Prim +open import Haskell.Prim.Bool +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Either +open import Haskell.Prim.Tuple + +-------------------------------------------------- +-- Semigroup + +record Semigroup (a : Type) : Type where + infixr 6 _<>_ + field _<>_ : a → a → a +open Semigroup ⦃...⦄ public +{-# COMPILE AGDA2HS Semigroup existing-class #-} + +instance + iSemigroupList : Semigroup (List a) + iSemigroupList ._<>_ = _++_ + + iSemigroupMaybe : ⦃ Semigroup a ⦄ → Semigroup (Maybe a) + iSemigroupMaybe ._<>_ Nothing m = m + iSemigroupMaybe ._<>_ m Nothing = m + iSemigroupMaybe ._<>_ (Just x) (Just y) = Just (x <> y) + + iSemigroupEither : Semigroup (Either a b) + iSemigroupEither ._<>_ (Left _) e = e + iSemigroupEither ._<>_ e _ = e + + iSemigroupFun : ⦃ Semigroup b ⦄ → Semigroup (a → b) + iSemigroupFun ._<>_ f g x = f x <> g x + + iSemigroupUnit : Semigroup ⊤ + iSemigroupUnit ._<>_ _ _ = tt + + + iSemigroupTuple₂ : ⦃ Semigroup a ⦄ → ⦃ Semigroup b ⦄ → Semigroup (a × b) + iSemigroupTuple₂ ._<>_ (x₁ , y₁) (x₂ , y₂) = x₁ <> x₂ , y₁ <> y₂ + + iSemigroupTuple₃ : ⦃ Semigroup a ⦄ → ⦃ Semigroup b ⦄ → ⦃ Semigroup c ⦄ → Semigroup (a × b × c) + iSemigroupTuple₃ ._<>_ (x₁ , y₁ , z₁) (x₂ , y₂ , z₂) = x₁ <> x₂ , y₁ <> y₂ , z₁ <> z₂ + + +-------------------------------------------------- +-- Monoid + +-- ** base +record Monoid (a : Type) : Type where + field + mempty : a + overlap ⦃ super ⦄ : Semigroup a + mappend : a → a → a + mconcat : List a → a +-- ** defaults +record DefaultMonoid (a : Type) : Type where + field + mempty : a + overlap ⦃ super ⦄ : Semigroup a + + mappend : a → a → a + mappend = _<>_ + + mconcat : List a → a + mconcat [] = mempty + mconcat (x ∷ xs) = x <> mconcat xs +-- ** export +open Monoid ⦃...⦄ public +{-# COMPILE AGDA2HS Monoid existing-class #-} +-- ** instances +instance + iDefaultMonoidList : DefaultMonoid (List a) + iDefaultMonoidList .DefaultMonoid.mempty = [] + + iMonoidList : Monoid (List a) + iMonoidList = record{DefaultMonoid iDefaultMonoidList} + + iDefaultMonoidMaybe : ⦃ Semigroup a ⦄ → DefaultMonoid (Maybe a) + iDefaultMonoidMaybe .DefaultMonoid.mempty = Nothing + + iMonoidMaybe : ⦃ Semigroup a ⦄ → Monoid (Maybe a) + iMonoidMaybe = record{DefaultMonoid iDefaultMonoidMaybe} + + iDefaultMonoidFun : ⦃ Monoid b ⦄ → DefaultMonoid (a → b) + iDefaultMonoidFun .DefaultMonoid.mempty = λ _ → mempty + + iMonoidFun : ⦃ Monoid b ⦄ → Monoid (a → b) + iMonoidFun = record{DefaultMonoid iDefaultMonoidFun} + + iDefaultMonoidUnit : DefaultMonoid ⊤ + iDefaultMonoidUnit .DefaultMonoid.mempty = tt + + iMonoidUnit : Monoid ⊤ + iMonoidUnit = record{DefaultMonoid iDefaultMonoidUnit} + + iDefaultMonoidTuple₂ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → DefaultMonoid (a × b) + iDefaultMonoidTuple₂ .DefaultMonoid.mempty = (mempty , mempty) + + iMonoidTuple₂ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Monoid (a × b) + iMonoidTuple₂ = record{DefaultMonoid iDefaultMonoidTuple₂} + + iDefaultMonoidTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → ⦃ Monoid c ⦄ → DefaultMonoid (a × b × c) + iDefaultMonoidTuple₃ .DefaultMonoid.mempty = (mempty , mempty , mempty) + + iMonoidTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → ⦃ Monoid c ⦄ → Monoid (a × b × c) + iMonoidTuple₃ = record{DefaultMonoid iDefaultMonoidTuple₃} + +open DefaultMonoid + +MonoidEndo : Monoid (a → a) +MonoidEndo = record {DefaultMonoid (λ where + .mempty → id + .super ._<>_ → _∘_)} + +MonoidEndoᵒᵖ : Monoid (a → a) +MonoidEndoᵒᵖ = record {DefaultMonoid (λ where + .mempty → id + .super ._<>_ → flip _∘_) } + +MonoidConj : Monoid Bool +MonoidConj = record {DefaultMonoid (λ where + .mempty → True + .super ._<>_ → _&&_)} + +MonoidDisj : Monoid Bool +MonoidDisj = record {DefaultMonoid (λ where + .mempty → False + .super ._<>_ → _||_)} diff --git a/lib/base/Haskell/Prim/Num.agda b/lib/base/Haskell/Prim/Num.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Num.agda @@ -0,0 +1,120 @@ +{-# OPTIONS --no-auto-inline #-} + +module Haskell.Prim.Num where + +open import Haskell.Prim +open import Haskell.Prim.Word +open import Haskell.Prim.Int +open import Haskell.Prim.Integer +open import Haskell.Prim.Double +open import Haskell.Prim.Eq +open import Haskell.Prim.Ord +open import Haskell.Prim.Monoid + +-------------------------------------------------- +-- Num + +record Num (a : Type) : Type₁ where + infixl 6 _+_ _-_ + infixl 7 _*_ + field + @0 MinusOK : a → a → Type + @0 NegateOK : a → Type + @0 FromIntegerOK : Integer → Type + _+_ : a → a → a + _-_ : (x y : a) → @0 ⦃ MinusOK x y ⦄ → a + _*_ : a → a → a + negate : (x : a) → @0 ⦃ NegateOK x ⦄ → a + abs : a → a + signum : a → a + fromInteger : (n : Integer) → @0 ⦃ FromIntegerOK n ⦄ → a + overlap ⦃ number ⦄ : Number a + overlap ⦃ numZero ⦄ : number .Number.Constraint 0 + overlap ⦃ numOne ⦄ : number .Number.Constraint 1 + +open Num ⦃...⦄ public hiding (FromIntegerOK; number) + +{-# COMPILE AGDA2HS Num existing-class #-} + +instance + iNumNat : Num Nat + iNumNat .MinusOK n m = IsFalse (ltNat n m) + iNumNat .NegateOK 0 = ⊤ + iNumNat .NegateOK (suc _) = ⊥ + iNumNat .Num.FromIntegerOK (negsuc _) = ⊥ + iNumNat .Num.FromIntegerOK (pos _) = ⊤ + iNumNat ._+_ n m = addNat n m + iNumNat ._-_ n m = monusNat n m + iNumNat ._*_ n m = mulNat n m + iNumNat .negate n = n + iNumNat .abs n = n + iNumNat .signum 0 = 0 + iNumNat .signum (suc n) = 1 + iNumNat .fromInteger (pos n) = n + iNumNat .fromInteger (negsuc _) ⦃ () ⦄ + + iNumInt : Num Int + iNumInt .MinusOK _ _ = ⊤ + iNumInt .NegateOK _ = ⊤ + iNumInt .Num.FromIntegerOK _ = ⊤ + iNumInt ._+_ x y = addInt x y + iNumInt ._-_ x y = subInt x y + iNumInt ._*_ x y = mulInt x y + iNumInt .negate x = negateInt x + iNumInt .abs x = absInt x + iNumInt .signum x = signInt x + iNumInt .fromInteger n = integerToInt n + + iNumInteger : Num Integer + iNumInteger .MinusOK _ _ = ⊤ + iNumInteger .NegateOK _ = ⊤ + iNumInteger .Num.FromIntegerOK _ = ⊤ + iNumInteger ._+_ x y = addInteger x y + iNumInteger ._-_ x y = subInteger x y + iNumInteger ._*_ x y = mulInteger x y + iNumInteger .negate x = negateInteger x + iNumInteger .abs x = absInteger x + iNumInteger .signum x = signInteger x + iNumInteger .fromInteger n = n + + iNumWord : Num Word + iNumWord .MinusOK _ _ = ⊤ + iNumWord .NegateOK _ = ⊤ + iNumWord .Num.FromIntegerOK _ = ⊤ + iNumWord ._+_ x y = addWord x y + iNumWord ._-_ x y = subWord x y + iNumWord ._*_ x y = mulWord x y + iNumWord .negate x = negateWord x + iNumWord .abs x = x + iNumWord .signum x = if x == 0 then 0 else 1 + iNumWord .fromInteger n = integerToWord n + + iNumDouble : Num Double + iNumDouble .MinusOK _ _ = ⊤ + iNumDouble .NegateOK _ = ⊤ + iNumDouble .Num.FromIntegerOK _ = ⊤ + iNumDouble ._+_ x y = primFloatPlus x y + iNumDouble ._-_ x y = primFloatMinus x y + iNumDouble ._*_ x y = primFloatTimes x y + iNumDouble .negate x = primFloatMinus 0.0 x + iNumDouble .abs x = if x < 0.0 then primFloatMinus 0.0 x else x + iNumDouble .signum x = case compare x 0.0 of λ where + LT → -1.0 + EQ → x + GT → 1.0 + iNumDouble .fromInteger (pos n) = fromNat n + iNumDouble .fromInteger (negsuc n) = fromNeg (suc n) + +open DefaultMonoid + +MonoidSum : ⦃ iNum : Num a ⦄ → Monoid a +MonoidSum = record {DefaultMonoid (λ where + .mempty → 0 + .super ._<>_ → _+_ + )} + +MonoidProduct : ⦃ iNum : Num a ⦄ → Monoid a +MonoidProduct = record {DefaultMonoid (λ where + .mempty → 1 + .super ._<>_ → _*_ + )} diff --git a/lib/base/Haskell/Prim/Ord.agda b/lib/base/Haskell/Prim/Ord.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Ord.agda @@ -0,0 +1,234 @@ + +module Haskell.Prim.Ord where + +open import Haskell.Prim +open import Haskell.Prim.Eq +open import Haskell.Prim.Bool +open import Haskell.Prim.Int +open import Haskell.Prim.Word +open import Haskell.Prim.Integer +open import Haskell.Prim.Double +open import Haskell.Prim.Tuple +open import Haskell.Prim.Monoid +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Either + +-------------------------------------------------- +-- Ordering + +data Ordering : Type where + LT EQ GT : Ordering + +instance + iEqOrdering : Eq Ordering + iEqOrdering ._==_ LT LT = True + iEqOrdering ._==_ EQ EQ = True + iEqOrdering ._==_ GT GT = True + iEqOrdering ._==_ _ _ = False + + iSemigroupOrdering : Semigroup Ordering + iSemigroupOrdering ._<>_ LT _ = LT + iSemigroupOrdering ._<>_ EQ o = o + iSemigroupOrdering ._<>_ GT _ = GT + + iMonoidOrdering : Monoid Ordering + iMonoidOrdering = record {DefaultMonoid (record {mempty = EQ})} + +-------------------------------------------------- +-- Ord + +record Ord (a : Type) : Type where + field + compare : a → a → Ordering + _<_ : a → a → Bool + _>_ : a → a → Bool + _>=_ : a → a → Bool + _<=_ : a → a → Bool + max : a → a → a + min : a → a → a + overlap ⦃ super ⦄ : Eq a + + infix 4 _<_ _>_ _<=_ _>=_ + +record OrdFromCompare (a : Type) : Type where + field + compare : a → a → Ordering + overlap ⦃ super ⦄ : Eq a + + _<_ : a → a → Bool + x < y = compare x y == LT + + _>_ : a → a → Bool + x > y = compare x y == GT + + _>=_ : a → a → Bool + x >= y = compare x y /= LT + + _<=_ : a → a → Bool + x <= y = compare x y /= GT + + max : a → a → a + max x y = if compare x y == LT then y else x + + min : a → a → a + min x y = if compare x y == GT then y else x + +record OrdFromLessThan (a : Type) : Type where + field + _<_ : a → a → Bool + overlap ⦃ super ⦄ : Eq a + + compare : a → a → Ordering + compare x y = if x < y then LT else if x == y then EQ else GT + + _>_ : a → a → Bool + x > y = y < x + + _>=_ : a → a → Bool + x >= y = y < x || x == y + + _<=_ : a → a → Bool + x <= y = x < y || x == y + + max : a → a → a + max x y = if x < y then y else x + + min : a → a → a + min x y = if y < x then y else x + + +open Ord ⦃...⦄ public + +{-# COMPILE AGDA2HS Ord existing-class #-} + +private + compareFromLt : ⦃ Eq a ⦄ → (a → a → Bool) → a → a → Ordering + compareFromLt _<_ x y = if x < y then LT else if x == y then EQ else GT + +private + maxNat : Nat → Nat → Nat + maxNat zero y = y + maxNat (suc x) zero = suc x + maxNat (suc x) (suc y) = suc (maxNat x y) + + minNat : Nat → Nat → Nat + minNat zero y = zero + minNat (suc x) zero = zero + minNat (suc x) (suc y) = suc (minNat x y) + +instance + iOrdFromLessThanNat : OrdFromLessThan Nat + iOrdFromLessThanNat .OrdFromLessThan._<_ = ltNat + + iOrdNat : Ord Nat + iOrdNat = record + { OrdFromLessThan iOrdFromLessThanNat + ; max = maxNat + ; min = minNat + } + + iOrdFromLessThanInteger : OrdFromLessThan Integer + iOrdFromLessThanInteger .OrdFromLessThan._<_ = ltInteger + + iOrdInteger : Ord Integer + iOrdInteger = record {OrdFromLessThan iOrdFromLessThanInteger} + + iOrdFromLessThanInt : OrdFromLessThan Int + iOrdFromLessThanInt .OrdFromLessThan._<_ = ltInt + + iOrdInt : Ord Int + iOrdInt = record {OrdFromLessThan iOrdFromLessThanInt} + + iOrdFromLessThanWord : OrdFromLessThan Word + iOrdFromLessThanWord .OrdFromLessThan._<_ = ltWord + + iOrdWord : Ord Word + iOrdWord = record {OrdFromLessThan iOrdFromLessThanWord} + + iOrdFromLessThanDouble : OrdFromLessThan Double + iOrdFromLessThanDouble .OrdFromLessThan._<_ = primFloatLess + + iOrdDouble : Ord Double + iOrdDouble = record {OrdFromLessThan iOrdFromLessThanDouble} + + iOrdFromLessThanChar : OrdFromLessThan Char + iOrdFromLessThanChar .OrdFromLessThan._<_ x y = c2n x < c2n y + + iOrdChar : Ord Char + iOrdChar = record {OrdFromLessThan iOrdFromLessThanChar} + + iOrdFromCompareBool : OrdFromCompare Bool + iOrdFromCompareBool .OrdFromCompare.compare = λ where + False True → LT + True False → GT + _ _ → EQ + + iOrdBool : Ord Bool + iOrdBool = record {OrdFromCompare iOrdFromCompareBool} + + iOrdFromCompareUnit : OrdFromCompare ⊤ + iOrdFromCompareUnit .OrdFromCompare.compare = λ _ _ → EQ + + iOrdUnit : Ord ⊤ + iOrdUnit = record {OrdFromCompare iOrdFromCompareUnit} + + iOrdFromCompareTuple₂ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → OrdFromCompare (a × b) + iOrdFromCompareTuple₂ .OrdFromCompare.compare = λ where + (x₁ , y₁) (x₂ , y₂) → compare x₁ x₂ <> compare y₁ y₂ + + iOrdTuple₂ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → Ord (a × b) + iOrdTuple₂ = record {OrdFromCompare iOrdFromCompareTuple₂} + + iOrdFromCompareTuple₃ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → ⦃ Ord c ⦄ → OrdFromCompare (a × b × c) + iOrdFromCompareTuple₃ .OrdFromCompare.compare = λ where + (x₁ , y₁ , z₁) (x₂ , y₂ , z₂) → compare x₁ x₂ <> compare y₁ y₂ <> compare z₁ z₂ + + iOrdTuple₃ : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → ⦃ Ord c ⦄ → Ord (a × b × c) + iOrdTuple₃ = record {OrdFromCompare iOrdFromCompareTuple₃} + +compareList : ⦃ Ord a ⦄ → List a → List a → Ordering +compareList [] [] = EQ +compareList [] (_ ∷ _) = LT +compareList (_ ∷ _) [] = GT +compareList (x ∷ xs) (y ∷ ys) = compare x y <> compareList xs ys + +instance + iOrdFromCompareList : ⦃ Ord a ⦄ → OrdFromCompare (List a) + iOrdFromCompareList .OrdFromCompare.compare = compareList + + iOrdList : ⦃ Ord a ⦄ → Ord (List a) + iOrdList = record {OrdFromCompare iOrdFromCompareList} + + iOrdFromCompareMaybe : ⦃ Ord a ⦄ → OrdFromCompare (Maybe a) + iOrdFromCompareMaybe .OrdFromCompare.compare = λ where + Nothing Nothing → EQ + Nothing (Just _) → LT + (Just _) Nothing → GT + (Just x) (Just y) → compare x y + + iOrdMaybe : ⦃ Ord a ⦄ → Ord (Maybe a) + iOrdMaybe = record {OrdFromCompare iOrdFromCompareMaybe} + + iOrdFromCompareEither : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → OrdFromCompare (Either a b) + iOrdFromCompareEither .OrdFromCompare.compare = λ where + (Left x) (Left y) → compare x y + (Left _) (Right _) → LT + (Right _) (Left _) → GT + (Right x) (Right y) → compare x y + + iOrdEither : ⦃ Ord a ⦄ → ⦃ Ord b ⦄ → Ord (Either a b) + iOrdEither = record {OrdFromCompare iOrdFromCompareEither} + + iOrdFromCompareOrdering : OrdFromCompare Ordering + iOrdFromCompareOrdering .OrdFromCompare.compare = λ where + LT LT → EQ + LT _ → LT + _ LT → GT + EQ EQ → EQ + EQ GT → LT + GT EQ → GT + GT GT → EQ + + iOrdOrdering : Ord Ordering + iOrdOrdering = record {OrdFromCompare iOrdFromCompareOrdering} diff --git a/lib/base/Haskell/Prim/Show.agda b/lib/base/Haskell/Prim/Show.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Show.agda @@ -0,0 +1,159 @@ + +module Haskell.Prim.Show where + +open import Haskell.Prim +open import Haskell.Prim.String +open import Haskell.Prim.List +open import Haskell.Prim.Word +open import Haskell.Prim.Double +open import Haskell.Prim.Maybe +open import Haskell.Prim.Eq +open import Haskell.Prim.Tuple +open import Haskell.Prim.Ord +open import Haskell.Prim.Either +open import Haskell.Prim.Integer +open import Haskell.Prim.Bool +open import Haskell.Prim.Int +open import Haskell.Prim.Foldable + + +-------------------------------------------------- +-- Show + +ShowS : Type +ShowS = String → String + +showChar : Char → ShowS +showChar = _∷_ + +showString : String → ShowS +showString = _++_ + +showParen : Bool → ShowS → ShowS +showParen False s = s +showParen True s = showString "(" ∘ s ∘ showString ")" + +defaultShowList : (a → ShowS) → List a → ShowS +defaultShowList shows = λ where + [] → showString "[]" + (x ∷ xs) → showString "[" + ∘ foldl (λ s x → s ∘ showString "," ∘ shows x) (shows x) xs + ∘ showString "]" + +-- ** base +record Show (a : Type) : Type where + field + showsPrec : Int → a → ShowS + showList : List a → ShowS + show : a → String +-- ** export +record Show₁ (a : Type) : Type where + field showsPrec : Int → a → ShowS + + show : a → String + show x = showsPrec 0 x "" + + showList : List a → ShowS + showList = defaultShowList (showsPrec 0) +record Show₂ (a : Type) : Type where + field show : a → String + + showsPrec : Int → a → ShowS + showsPrec _ x s = show x ++ s + + showList : List a → ShowS + showList = defaultShowList (showsPrec 0) +-- ** export +open Show ⦃...⦄ public + +shows : ⦃ Show a ⦄ → a → ShowS +shows = showsPrec 0 + +{-# COMPILE AGDA2HS Show existing-class #-} + +-- ** instances +instance + iShow₂Nat : Show₂ Nat + iShow₂Nat .Show₂.show = primStringToList ∘ primShowNat + + iShowNat : Show Nat + iShowNat = record {Show₂ iShow₂Nat} + + iShow₂Integer : Show₂ Integer + iShow₂Integer .Show₂.show = showInteger + + iShowInteger : Show Integer + iShowInteger = record {Show₂ iShow₂Integer} + + iShow₂Int : Show₂ Int + iShow₂Int .Show₂.show = showInt + + iShowInt : Show Int + iShowInt = record{Show₂ iShow₂Int} + + iShow₂Word : Show₂ Word + iShow₂Word .Show₂.show = showWord + + iShowWord : Show Word + iShowWord = record{Show₂ iShow₂Word} + + iShow₂Double : Show₂ Double + iShow₂Double .Show₂.show = primStringToList ∘ primShowFloat + + iShowDouble : Show Double + iShowDouble = record{Show₂ iShow₂Double} + + iShow₂Bool : Show₂ Bool + iShow₂Bool .Show₂.show = λ where False → "False"; True → "True" + + iShowBool : Show Bool + iShowBool = record{Show₂ iShow₂Bool} + + iShow₁Char : Show₁ Char + iShow₁Char .Show₁.showsPrec _ = showString ∘ primStringToList ∘ primShowChar + + iShowChar : Show Char + iShowChar = record{Show₁ iShow₁Char} + + iShow₁List : ⦃ Show a ⦄ → Show₁ (List a) + iShow₁List .Show₁.showsPrec _ = showList + + iShowList : ⦃ Show a ⦄ → Show (List a) + iShowList = record{Show₁ iShow₁List} + +private + showApp₁ : ⦃ Show a ⦄ → Int → String → a → ShowS + showApp₁ p tag x = showParen (p > 10) $ + showString tag ∘ showString " " ∘ showsPrec 11 x + +instance + iShow₁Maybe : ⦃ Show a ⦄ → Show₁ (Maybe a) + iShow₁Maybe .Show₁.showsPrec = λ where + p Nothing → showString "Nothing" + p (Just x) → showApp₁ p "Just" x + + iShowMaybe : ⦃ Show a ⦄ → Show (Maybe a) + iShowMaybe = record{Show₁ iShow₁Maybe} + + iShow₁Either : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show₁ (Either a b) + iShow₁Either .Show₁.showsPrec = λ where + p (Left x) → showApp₁ p "Left" x + p (Right y) → showApp₁ p "Right" y + + iShowEither : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show (Either a b) + iShowEither = record{Show₁ iShow₁Either} + +instance + iShow₁Tuple₂ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show₁ (a × b) + iShow₁Tuple₂ .Show₁.showsPrec = λ _ → λ where + (x , y) → showString "(" ∘ shows x ∘ showString ", " ∘ shows y ∘ showString ")" + + iShowTuple₂ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → Show (a × b) + iShowTuple₂ = record{Show₁ iShow₁Tuple₂} + + iShow₁Tuple₃ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → ⦃ Show c ⦄ → Show₁ (a × b × c) + iShow₁Tuple₃ .Show₁.showsPrec = λ _ → λ where + (x , y , z) → showString "(" ∘ shows x ∘ showString ", " ∘ shows y ∘ showString ", " ∘ shows z ∘ showString ")" + + iShowTuple₃ : ⦃ Show a ⦄ → ⦃ Show b ⦄ → ⦃ Show c ⦄ → Show (a × b × c) + iShowTuple₃ = record{Show₁ iShow₁Tuple₃} diff --git a/lib/base/Haskell/Prim/Strict.agda b/lib/base/Haskell/Prim/Strict.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Strict.agda @@ -0,0 +1,12 @@ + +module Haskell.Prim.Strict where + +open import Haskell.Prim + +record Strict (a : Type ℓ) : Type ℓ where + constructor !_ + field + force : a +open Strict public + +{-# COMPILE AGDA2HS Strict unboxed-strict #-} diff --git a/lib/base/Haskell/Prim/String.agda b/lib/base/Haskell/Prim/String.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/String.agda @@ -0,0 +1,52 @@ + +module Haskell.Prim.String where + +open import Haskell.Prim +open import Haskell.Prim.List +open import Haskell.Prim.Foldable + +-------------------------------------------------- +-- String +-- This is _not_ the builtin String type of Agda +-- which is defined by postulates. +-- `fromString` can be used to convert back +-- to builtin Agda strings. + +String = List Char + +instance + iIsStringString : IsString String + iIsStringString .IsString.Constraint _ = ⊤ + iIsStringString .fromString s = primStringToList s + +private + cons : Char → List String → List String + cons c [] = (c ∷ []) ∷ [] + cons c (s ∷ ss) = (c ∷ s) ∷ ss + +lines : String → List String +lines [] = [] +lines ('\n' ∷ s) = [] ∷ lines s +lines (c ∷ s) = cons c (lines s) + +private + mutual + space : String → List String + space [] = [] + space (c ∷ s) = if primIsSpace c then space s else cons c (word s) + + word : String → List String + word [] = [] + word (c ∷ s) = if primIsSpace c then [] ∷ space s else cons c (word s) + +words : String → List String +words [] = [] +words s@(c ∷ s₁) = if primIsSpace c then space s₁ else word s + +unlines : List String → String +unlines = concatMap (_++ "\n") + +unwords : List String → String +unwords [] = "" +unwords (w ∷ []) = w +unwords (w ∷ ws) = w ++ ' ' ∷ unwords ws diff --git a/lib/base/Haskell/Prim/Thunk.agda b/lib/base/Haskell/Prim/Thunk.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Thunk.agda @@ -0,0 +1,15 @@ +{-# OPTIONS --sized-types #-} + +module Haskell.Prim.Thunk where + +open import Agda.Builtin.Size public + +open import Haskell.Prim + +record Thunk {ℓ} (a : @0 Size → Type ℓ) (@0 i : Size) : Type ℓ where + constructor delay + coinductive + field force : {@0 j : Size< i} → a j +open Thunk public + +{-# COMPILE AGDA2HS Thunk unboxed #-} diff --git a/lib/base/Haskell/Prim/Traversable.agda b/lib/base/Haskell/Prim/Traversable.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Traversable.agda @@ -0,0 +1,78 @@ + + +module Haskell.Prim.Traversable where + +open import Haskell.Prim +open import Haskell.Prim.Applicative +open import Haskell.Prim.Functor +open import Haskell.Prim.Foldable +open import Haskell.Prim.Monad +open import Haskell.Prim.List +open import Haskell.Prim.Maybe +open import Haskell.Prim.Either +open import Haskell.Prim.Tuple + +-------------------------------------------------- +-- Traversable + +-- ** base +record Traversable (t : Type → Type) : Type₁ where + field + traverse : ⦃ Applicative f ⦄ → (a → f b) → t a → f (t b) + overlap ⦃ functor ⦄ : Functor t + overlap ⦃ foldable ⦄ : Foldable t + + sequenceA : ⦃ Applicative f ⦄ → t (f a) → f (t a) + mapM : ⦃ Monad m ⦄ → (a → m b) → t a → m (t b) + sequence : ⦃ Monad m ⦄ → t (m a) → m (t a) +-- ** defaults +record DefaultTraversable (t : Type → Type) : Type₁ where + field + traverse : ⦃ Applicative f ⦄ → (a → f b) → t a → f (t b) + overlap ⦃ functor ⦄ : Functor t + overlap ⦃ foldable ⦄ : Foldable t + + sequenceA : ⦃ Applicative f ⦄ → t (f a) → f (t a) + sequenceA = traverse id + + mapM : ⦃ Monad m ⦄ → (a → m b) → t a → m (t b) + mapM = traverse + + sequence : ⦃ Monad m ⦄ → t (m a) → m (t a) + sequence = sequenceA +-- ** export +open Traversable ⦃...⦄ public +{-# COMPILE AGDA2HS Traversable existing-class #-} +-- ** instances +private + mkTraversable : DefaultTraversable t → Traversable t + mkTraversable x = record {DefaultTraversable x} + + infix 0 traverse=_ + traverse=_ : ⦃ Functor t ⦄ → ⦃ Foldable t ⦄ + → (∀ {f a b} → ⦃ Applicative f ⦄ → (a → f b) → t a → f (t b)) + → Traversable t + traverse= x = record {DefaultTraversable (record {traverse = x})} +instance + open DefaultTraversable + + iTraversableList : Traversable List + iTraversableList = traverse= traverseList + where + traverseList : ⦃ Applicative f ⦄ → (a → f b) → List a → f (List b) + traverseList f [] = pure [] + traverseList f (x ∷ xs) = ⦇ f x ∷ traverseList f xs ⦈ + + iTraversableMaybe : Traversable Maybe + iTraversableMaybe = traverse= λ where + f Nothing → pure Nothing + f (Just x) → Just <$> f x + + iTraversableEither : Traversable (Either a) + iTraversableEither = traverse= λ where + f (Left x) → pure (Left x) + f (Right y) → Right <$> f y + + iTraversablePair : Traversable (a ×_) + iTraversablePair = traverse= λ + f (x , y) → (x ,_) <$> f y diff --git a/lib/base/Haskell/Prim/Tuple.agda b/lib/base/Haskell/Prim/Tuple.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Tuple.agda @@ -0,0 +1,45 @@ + +module Haskell.Prim.Tuple where + +open import Haskell.Prim + +-------------------------------------------------- +-- Tuples + +infix 3 _×_ _×_×_ + +infix -1 _,_ _,_,_ + +record _×_ (a b : Type) : Type where + constructor _,_ + field + fst : a + snd : b +open _×_ public + +{-# COMPILE AGDA2HS _×_ tuple #-} + +record _×_×_ (a b c : Type) : Type where + no-eta-equality; pattern + constructor _,_,_ + field + fst3 : a + snd3 : b + thd3 : c + +{-# COMPILE AGDA2HS _×_×_ tuple #-} + +uncurry : (a → b → c) → a × b → c +uncurry f (x , y) = f x y + +curry : (a × b → c) → a → b → c +curry f x y = f (x , y) + +first : (a → b) → a × c → b × c +first f (x , y) = f x , y + +second : (a → b) → c × a → c × b +second f (x , y) = x , f y + +_***_ : (a → b) → (c → d) → a × c → b × d +(f *** g) (x , y) = f x , g y diff --git a/lib/base/Haskell/Prim/Word.agda b/lib/base/Haskell/Prim/Word.agda new file mode 100644 --- /dev/null +++ b/lib/base/Haskell/Prim/Word.agda @@ -0,0 +1,54 @@ + +module Haskell.Prim.Word where + +open import Haskell.Prim +open import Haskell.Prim.Integer + +import Agda.Builtin.Word renaming (Word64 to Word) +open Agda.Builtin.Word public using (Word) + + +-------------------------------------------------- +-- Literals + +module WordInternal where + 2⁶⁴ : Nat + 2⁶⁴ = 18446744073709551616 +open WordInternal + +instance + iNumberWord : Number Word + iNumberWord .Number.Constraint n = IsTrue (ltNat n 2⁶⁴) + iNumberWord .fromNat n = n2w n + + +-------------------------------------------------- +-- Arithmetic + +negateWord : Word → Word +negateWord a = n2w (monusNat 2⁶⁴ (w2n a)) + +addWord : Word → Word → Word +addWord a b = n2w (addNat (w2n a) (w2n b)) + +subWord : Word → Word → Word +subWord a b = addWord a (negateWord b) + +mulWord : Word → Word → Word +mulWord a b = n2w (mulNat (w2n a) (w2n b)) + +eqWord : Word → Word → Bool +eqWord a b = eqNat (w2n a) (w2n b) + +ltWord : Word → Word → Bool +ltWord a b = ltNat (w2n a) (w2n b) + +showWord : Word → List Char +showWord a = primStringToList (primShowNat (w2n a)) + +integerToWord : Integer → Word +integerToWord (pos n) = n2w n +integerToWord (negsuc n) = negateWord (n2w (suc n)) + +wordToInteger : Word → Integer +wordToInteger n = pos (w2n n) diff --git a/lib/base/base.agda-lib b/lib/base/base.agda-lib new file mode 100644 --- /dev/null +++ b/lib/base/base.agda-lib @@ -0,0 +1,8 @@ +-- This library +-- * mirrors the Haskell `base` package +-- * is intertwined with `agda2hs` + +name: agda2hs-base +depend: +include: . +flags: -W noUnsupportedIndexedMatch --erasure --no-projection-like diff --git a/src/Agda2Hs/AgdaUtils.hs b/src/Agda2Hs/AgdaUtils.hs --- a/src/Agda2Hs/AgdaUtils.hs +++ b/src/Agda2Hs/AgdaUtils.hs @@ -26,6 +26,7 @@ import Agda.TypeChecking.Reduce ( reduceDefCopy ) import Agda.Utils.Either ( isRight ) +import Agda.Utils.GetOpt ( OptDescr(..) , ArgDescr(..) ) import Agda.Utils.List ( initMaybe ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Monad ( ifM ) @@ -143,3 +144,19 @@ endsInSort t = do TelV tel b <- telView t addContext tel $ ifIsSort b (\_ -> return True) (return False) + +-- Heavily butchered version of the private function informationOptions in +-- Agda.Interaction.Options.Base, just for the purpose of checking if the +-- user has requested any information so we can disable the backend. +infoFlags :: [OptDescr ()] +infoFlags = + [ Option ['V'] ["version"] (NoArg ()) "" + , Option [] ["numeric-version"] (NoArg ()) "" + , Option ['?'] ["help"] (OptArg (const ()) "HELP_TOPIC") "" + , Option [] ["emacs-mode"] (ReqArg (const ()) "EMACS_MODE_COMMAND") "" + , Option [] ["print-agda-dir"] (NoArg ()) "" + , Option [] ["print-agda-app-dir"] (NoArg ()) "" + , Option [] ["print-agda-data-dir"] (NoArg ()) "" + , Option [] ["print-options"] (NoArg ()) "" + , Option [] ["setup"] (NoArg ()) "" + ] diff --git a/src/Agda2Hs/Compile.hs b/src/Agda2Hs/Compile.hs --- a/src/Agda2Hs/Compile.hs +++ b/src/Agda2Hs/Compile.hs @@ -1,7 +1,9 @@ module Agda2Hs.Compile where +import Prelude hiding (null) + import Control.Monad.Trans.RWS.CPS ( evalRWST ) -import Control.Monad.State ( gets ) +import Control.Monad.State ( gets, liftIO ) import Control.Arrow ((>>>)) import Data.Functor import Data.List ( isPrefixOf, group, sort ) @@ -10,6 +12,7 @@ import Agda.Compiler.Backend import Agda.Compiler.Common ( curIF ) +import Agda.Utils.FileName ( isNewerThan ) import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName ) import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.TypeChecking.Pretty @@ -17,21 +20,19 @@ import Agda.Utils.Impossible import Agda.Utils.List import Agda.Utils.Null -import Agda.Utils.Monad ( whenM, anyM, when ) - -import qualified Language.Haskell.Exts.Extension as Hs +import Agda.Utils.Monad ( whenM, anyM, when, unless ) import Agda2Hs.Compile.ClassInstance ( compileInstance ) import Agda2Hs.Compile.Data ( compileData ) import Agda2Hs.Compile.Function ( compileFun, checkTransparentPragma, checkInlinePragma ) +import Agda2Hs.Compile.Name ( hsTopLevelModuleName ) import Agda2Hs.Compile.Postulate ( compilePostulate ) import Agda2Hs.Compile.Record ( compileRecord, checkUnboxPragma ) import Agda2Hs.Compile.Types -import Agda2Hs.Compile.Utils ( setCurrentRangeQ, tellExtension, primModules, isClassName ) +import Agda2Hs.Compile.Utils import Agda2Hs.Pragma -import qualified Language.Haskell.Exts.Syntax as Hs -import qualified Language.Haskell.Exts.Pretty as Hs +import qualified Agda2Hs.Language.Haskell as Hs initCompileEnv :: TopLevelModuleName -> SpecialRules -> CompileEnv initCompileEnv tlm rewrites = CompileEnv @@ -53,13 +54,22 @@ runC tlm rewrites c = evalRWST c (initCompileEnv tlm rewrites) initCompileState moduleSetup :: Options -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile ModuleEnv ModuleRes) -moduleSetup _ _ m _ = do +moduleSetup opts _ m mifile = do -- we never compile primitive modules if any (`isPrefixOf` prettyShow m) primModules then pure $ Skip () else do - reportSDoc "agda2hs.compile" 3 $ text "Compiling module: " <+> prettyTCM m - setScope . iInsideScope =<< curIF - return $ Recompile m + -- check whether the file needs to be recompiled + uptodate <- case mifile of + Nothing -> pure False + Just ifile -> let ofile = moduleFileName opts m in + liftIO =<< isNewerThan <$> ofile <*> pure ifile + if uptodate then do + reportSDoc "agda2hs.compile" 3 $ text "Module " <+> prettyTCM m <+> text " is already up-to-date" + return $ Skip () + else do + reportSDoc "agda2hs.compile" 3 $ text "Compiling module: " <+> prettyTCM m + setScope . iInsideScope =<< curIF + return $ Recompile m -- Main compile function ------------------------ @@ -86,7 +96,7 @@ reportSDoc "agda2hs.compile" 45 $ text "Pragma:" <+> text (show p) reportSDoc "agda2hs.compile" 45 $ text "Compiling definition:" <+> pretty (theDef def) - isInstance <- anyM (defInstance def) $ isClassName . instanceClass + isInstance <- anyM (isClassName . instanceClass) $ defInstance def reportSDoc "agda2hs.compile" 15 $ text "Is instance?" <+> prettyTCM isInstance @@ -109,17 +119,18 @@ (DefaultPragma _ , Function{}) -> compileFun True def (DefaultPragma ds , Record{} ) -> pure <$> compileRecord (ToRecord False ds) def - _ -> genericDocError =<< text "Don't know how to compile" <+> prettyTCM (defName def) + _ -> agda2hsErrorM $ text "Don't know how to compile" <+> prettyTCM (defName def) postCompile :: C () postCompile = whenM (gets $ lcaseUsed >>> (> 0)) $ tellExtension Hs.LambdaCase verifyOutput :: Options -> ModuleEnv -> IsMain -> TopLevelModuleName - -> [(CompiledDef, CompileOutput)] -> TCM Bool + -> [(CompiledDef, CompileOutput)] -> TCM () verifyOutput _ _ _ m ls = do reportSDoc "agda2hs.compile" 5 $ text "Checking generated output before rendering: " <+> prettyTCM m ensureUniqueConstructors + ensureNoOutputFromHsModules where ensureUniqueConstructors = do let allCons = do @@ -133,5 +144,19 @@ Hs.RecDecl _ n _ -> n duplicateCons = filter ((> 1) . length) . group . sort $ allCons when (length duplicateCons > 0) $ - genericDocError =<< vcat (map (\x -> text $ "Cannot generate multiple constructors with the same identifier: " <> Hs.prettyPrint (headWithDefault __IMPOSSIBLE__ x)) duplicateCons) - return (length duplicateCons == 0) + agda2hsErrorM $ vcat (map (\x -> text $ "Cannot generate multiple constructors with the same identifier: " <> Hs.prettyPrint (headWithDefault __IMPOSSIBLE__ x)) duplicateCons) + + ensureNoOutputFromHsModules = unless (null $ concat $ map fst ls) $ do + let hsModName = hsTopLevelModuleName m + case hsModuleKind hsModName of + HsModule -> do + reportSDoc "agda2hs.compile" 10 $ text "Haskell module" <+> prettyTCM m <+> text "has non-null output." + agda2hsErrorM $ hsep + ( pwords "The `Haskell.` namespace are reserved for binding existing Haskell modules, so the module" + ++ [text "`" <> prettyTCM m <> text "`"] + ++ pwords "should not contain any" + ++ [text "`{-# COMPILE AGDA2HS ... #-}`"] + ++ pwords "pragmas that produce Haskell code." + ) + PrimModule -> __IMPOSSIBLE__ + AgdaModule -> return () diff --git a/src/Agda2Hs/Compile/ClassInstance.hs b/src/Agda2Hs/Compile/ClassInstance.hs --- a/src/Agda2Hs/Compile/ClassInstance.hs +++ b/src/Agda2Hs/Compile/ClassInstance.hs @@ -8,9 +8,6 @@ import Data.Maybe ( isNothing, mapMaybe ) import qualified Data.HashMap.Strict as HMap -import qualified Language.Haskell.Exts as Hs -import Language.Haskell.Exts.Extension as Hs - import Agda.Compiler.Backend import Agda.Compiler.Common ( curDefs, sortDefs ) @@ -30,17 +27,20 @@ import Agda.TypeChecking.Telescope ( mustBePi, piApplyM ) import Agda.Utils.Lens +import Agda.Utils.List ( headWithDefault ) import Agda.Utils.Monad ( ifNotM ) import Agda.Utils.Impossible ( __IMPOSSIBLE__ ) import Agda2Hs.AgdaUtils import Agda2Hs.Compile.Function import Agda2Hs.Compile.Name +import Agda2Hs.Compile.Term import Agda2Hs.Compile.Type import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils -import Agda2Hs.HsUtils +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( hsName, pp, replaceName, unQual ) enableCopatterns :: C a -> C a enableCopatterns = local $ \e -> e { copatternsEnabled = True } @@ -65,7 +65,7 @@ compileInstance (ToDerivation strategy) def@Defn{..} = setCurrentRangeQ defName $ do - reportSDoc "agda2hs.compile.instance" 13 $ + reportSDoc "agda2hs.compile.instance" 13 $ text "compiling instance" <+> prettyTCM defName <+> text "to standalone deriving" tellExtension Hs.StandaloneDeriving enableStrategy strategy @@ -74,7 +74,7 @@ compileInstance ToDefinition def@Defn{..} = enableCopatterns $ setCurrentRangeQ defName $ do - reportSDoc "agda2hs.compile.instance" 13 $ + reportSDoc "agda2hs.compile.instance" 13 $ text "compiling instance" <+> prettyTCM defName <+> text "to instance definition" ir <- compileInstRule [] (unEl defType) withFunctionLocals defName $ do @@ -95,7 +95,7 @@ text "compileInstance compiled clauses: " : map (nest 2 . text . pp) ds when (length (nub rs) > 1) $ - genericDocError =<< fsep (pwords "More than one minimal record used.") + agda2hsErrorM $ fsep (pwords "More than one minimal record used.") return $ Hs.InstDecl () Nothing ir (Just ds) where Function{..} = theDef @@ -139,7 +139,7 @@ etaExpandClause :: Clause -> C [Clause] etaExpandClause cl@Clause{clauseBody = Nothing} = - genericError "Instance definition with absurd pattern!" + agda2hsError "Instance definition with absurd pattern!" etaExpandClause cl@Clause{namedClausePats = ps, clauseBody = Just t} = do case t of Con c _ _ -> do @@ -148,7 +148,7 @@ clauseBody = Just $ t `applyE` [Proj ProjSystem $ unArg f] } | f <- fields ] return cls - _ -> genericDocError =<< fsep (pwords $ + _ -> agda2hsErrorM $ fsep (pwords $ "Type class instances must be defined using copatterns (or top-level" ++ " records) and cannot be defined using helper functions.") @@ -181,7 +181,7 @@ -- reached record projection | ProjP _ q <- namedArg p = do - -- we put back the remaining patterns in the original clause + -- we put back the remaining patterns in the original clause let c' = c {namedClausePats = ps} -- We want the actual field name, not the instance-opened projection. @@ -198,9 +198,9 @@ -- retrieve the type of the projection Just (unEl -> Pi a b) <- getDefType q ty -- We don't really have the information available to reconstruct the instance - -- head. However, all dependencies on the instance head are in erased positions, + -- head. However, all dependencies on the instance head are in erased positions, -- so we can just use a dummy term instead - let instanceHead = __DUMMY_TERM__ + let instanceHead = __DUMMY_TERM__ ty' = b `absApp` instanceHead reportSDoc "agda2hs.compile.instance" 15 $ @@ -222,9 +222,9 @@ if -- Instance field: check canonicity. | isInstance arg -> do - unless (null ps) $ genericDocError =<< text "not allowed: explicitly giving superclass" + unless (null ps) $ agda2hsError "not allowed: explicitly giving superclass" body <- case clauseBody c' of - Nothing -> genericDocError =<< text "not allowed: absurd clause for superclass" + Nothing -> agda2hsError "not allowed: absurd clause for superclass" Just b -> return b addContext (clauseTel c) $ do liftTCM $ setModuleCheckpoint curModule @@ -245,8 +245,14 @@ text $ "raw name: " ++ prettyShow (Def n []) d@Defn{..} <- getConstInfo n let mod = if isExtendedLambdaName defName then curModule else qnameModule defName - (fc, rs) <- withCurrentModule mod $ - concatUnzip <$> mapM (compileInstanceClause mod defType) (funClauses theDef) + let isMatchingProj [] = False + isMatchingProj (p:ps) | ProjP _ g <- namedArg p = g .~ q + isMatchingProj (p:ps) = isMatchingProj ps + (fc, rs) <- withCurrentModule mod + $ fmap concatUnzip + . mapM (compileInstanceClause mod defType) + . filter (isMatchingProj . namedClausePats) + $ funClauses theDef let hd = hsName $ prettyShow $ nameConcrete $ qnameName defName let fc' = {- dropPatterns 1 $ -} replaceName hd uf fc reportSDoc "agda2hs.compile.instance" 6 $ vcat $ @@ -258,7 +264,7 @@ -- same (minimal) dictionary as the primitive fields. | Clause {namedClausePats = [], clauseBody = Just (Def n es)} <- c' , n .~ q -> do - let err = genericDocError =<< text "illegal instance declaration: instances using default methods should use a named definition or an anonymous `λ where`." + let err = agda2hsError $ "illegal instance declaration: instances using default methods should use a named definition or an anonymous `λ where`." filterArgs :: Type -> [Term] -> C [Term] filterArgs ty [] = return [] filterArgs ty (v:vs) = do @@ -309,7 +315,7 @@ df : _ -> return $ getArgInfo df [] -> badness where - badness = genericDocError =<< text "Not a record field:" <+> prettyTCM f + badness = agda2hsErrorM $ text "Not a record field:" <+> prettyTCM f findDefinitions :: (QName -> Definition -> C Bool) -> ModuleName -> C [Definition] @@ -327,17 +333,17 @@ rname <- liftTCM $ resolveName cqname case rname of DefinedName _ aname _ -> return $ anameName aname - _ -> genericDocError =<< text ("Couldn't find " ++ s) + _ -> agda2hsStringError $ "Couldn't find " ++ s lookupDefaultImplementations :: QName -> [Hs.Name ()] -> C [Definition] lookupDefaultImplementations recName fields = do let modName = qnameToMName recName - isField f _ = (`elem` fields) . unQual <$> compileQName f + isField f _ = (`elem` fields) <$> compileName (qnameName f) findDefinitions isField modName classMemberNames :: Definition -> C [Hs.Name ()] classMemberNames def = case theDef def of Record{recFields = fs} -> fmap unQual <$> traverse compileQName (map unDom fs) - _ -> genericDocError =<< text "Not a record:" <+> prettyTCM (defName def) + _ -> agda2hsErrorM $ text "Not a record:" <+> prettyTCM (defName def) diff --git a/src/Agda2Hs/Compile/Data.hs b/src/Agda2Hs/Compile/Data.hs --- a/src/Agda2Hs/Compile/Data.hs +++ b/src/Agda2Hs/Compile/Data.hs @@ -1,7 +1,5 @@ module Agda2Hs.Compile.Data where -import qualified Language.Haskell.Exts.Syntax as Hs - import Control.Monad ( when ) import Agda.Compiler.Backend import Agda.Syntax.Common @@ -18,8 +16,10 @@ import Agda2Hs.Compile.Type ( compileDomType, compileTeleBinds ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils -import Agda2Hs.HsUtils +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( hsName ) + checkNewtype :: Hs.Name () -> [Hs.QualConDecl ()] -> C () checkNewtype name cs = do checkSingleElement name cs "Newtype must have exactly one constructor in definition" @@ -51,9 +51,9 @@ allIndicesErased t = reduce (unEl t) >>= \case Pi dom t -> compileDomType (absName t) dom >>= \case DomDropped -> allIndicesErased (unAbs t) - DomType{} -> genericDocError =<< text "Not supported: indexed datatypes" - DomConstraint{} -> genericDocError =<< text "Not supported: constraints in types" - DomForall{} -> genericDocError =<< text "Not supported: indexed datatypes" + DomType{} -> agda2hsError "Not supported: indexed datatypes" + DomConstraint{} -> agda2hsError "Not supported: constraints in types" + DomForall{} -> agda2hsError "Not supported: indexed datatypes" _ -> return () compileConstructor :: [Arg Term] -> QName -> C (Hs.QualConDecl ()) @@ -74,6 +74,6 @@ DomType s hsA -> do ty <- addTyBang s hsA (ty :) <$> underAbstraction a tel compileConstructorArgs - DomConstraint hsA -> genericDocError =<< text "Not supported: constructors with class constraints" + DomConstraint hsA -> agda2hsError "Not supported: constructors with class constraints" DomDropped -> underAbstraction a tel compileConstructorArgs DomForall{} -> __IMPOSSIBLE__ diff --git a/src/Agda2Hs/Compile/Function.hs b/src/Agda2Hs/Compile/Function.hs --- a/src/Agda2Hs/Compile/Function.hs +++ b/src/Agda2Hs/Compile/Function.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Agda2Hs.Compile.Function where import Control.Arrow ( (***) ) @@ -10,8 +9,6 @@ import Data.Maybe ( fromMaybe, isJust ) import qualified Data.Text as Text -import qualified Language.Haskell.Exts as Hs - import Agda.Compiler.Backend import Agda.Compiler.Common @@ -46,8 +43,10 @@ import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils import Agda2Hs.Compile.Var ( compileDBVar ) -import Agda2Hs.HsUtils +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils + ( Strictness, hsName, pApp, patToExp, constrainType, qualifyType ) -- | Compilation rules for specific constructors in patterns. isSpecialCon :: QName -> Maybe (Type -> NAPs -> C (Hs.Pat ())) @@ -65,7 +64,7 @@ ] itsBad :: Type -> NAPs -> C (Hs.Pat ()) - itsBad _ _ = genericDocError =<< "constructor `" <> prettyTCM qn <> "` not supported in patterns" + itsBad _ _ = agda2hsErrorM $ "constructor `" <> prettyTCM qn <> "` not supported in patterns" -- | Translate Int.pos pattern. posIntPat :: Type -> NAPs -> C (Hs.Pat ()) @@ -92,7 +91,7 @@ | prettyShow (conName ch) == "Agda.Builtin.Nat.Nat.zero" -> return 0 | prettyShow (conName ch) == "Agda.Builtin.Nat.Nat.suc" , [p] <- ps -> (1+) <$> compileLitNatPat (namedArg p) - p -> genericDocError =<< "not a literal natural number pattern:" prettyTCM p + p -> agda2hsErrorM $ "not a literal natural number pattern:" prettyTCM p compileFun, compileFun' @@ -111,7 +110,7 @@ reportSDoc "agda2hs.compile" 6 $ "Compiling function: " <+> prettyTCM defName whenM ((withSig &&) <$> inRecordMod defName) $ - genericDocError =<< text "not supported by agda2hs: functions inside a record module" + agda2hsError "not supported: functions inside a record module" ifM (endsInSort defType) -- if the function type ends in Sort, it's a type alias! @@ -155,8 +154,8 @@ cs <- map (addPats paramPats) <$> mapMaybeM (compileClause m (Just defName) x typ) clauses - when (null cs) $ genericDocError - =<< text "Functions defined with absurd patterns exclusively are not supported." + when (null cs) $ agda2hsErrorM $ + text "Functions defined with absurd patterns exclusively are not supported." <+> text "Use function `error` from the Haskell.Prelude instead." return $ sig ++ [Hs.FunBind () cs] @@ -260,7 +259,7 @@ compilePats ty ((namedArg -> ProjP po pn):ps) = do reportSDoc "agda2hs.compile" 10 $ "compiling copattern: " <+> text (prettyShow pn) unlessM (asks copatternsEnabled `or2M` (isJust <$> isUnboxProjection pn)) $ - genericDocError =<< "not supported in Haskell: copatterns" + agda2hsError "not supported in Haskell: copatterns" ty <- fromMaybe __IMPOSSIBLE__ <$> getDefType pn ty (a, b) <- mustBePi ty @@ -279,7 +278,7 @@ DOTerm -> do checkNoAsPatterns pat (:) <$> compilePat (unDom a) pat <*> rest - where checkForced = when (isForcedPat pat) $ genericDocError =<< "not supported by agda2hs: forced (dot) patterns in non-erased positions" + where checkForced = when (isForcedPat pat) $ agda2hsError "not supported: forced (dot) patterns in non-erased positions" compilePat :: Type -> DeBruijnPattern -> C (Hs.Pat ()) @@ -309,7 +308,7 @@ -- nothing else is supported -compilePat _ p = genericDocError =<< "bad pattern:" prettyTCM p +compilePat _ p = agda2hsErrorM $ "bad pattern:" prettyTCM p compileErasedConP :: Type -> Strictness -> NAPs -> C (Hs.Pat ()) @@ -320,7 +319,7 @@ compileLitPat :: Literal -> C (Hs.Pat ()) compileLitPat = \case LitChar c -> return $ Hs.charP c - l -> genericDocError =<< "bad literal pattern:" prettyTCM l + l -> agda2hsErrorM $ "bad literal pattern:" prettyTCM l compileTupleConP :: Type -> Hs.Boxed -> NAPs -> C (Hs.Pat ()) compileTupleConP ty b ps = do @@ -389,7 +388,7 @@ checkTransparentTypeDef (Hs.DHApp _ _ (Hs.UnkindedVar _ x)) (Hs.TyVar _ y) | x == y = return () checkTransparentTypeDef _ _ = errNotTransparent - errNotTransparent = genericDocError =<< + errNotTransparent = agda2hsErrorM $ "Cannot make function" <+> prettyTCM (defName def) <+> "transparent." <+> "A transparent function must have exactly one non-erased argument and return it unchanged." @@ -400,11 +399,11 @@ let Function{funClauses = cs} = theDef def case filter (isJust . clauseBody) cs of [c] -> - unlessM (allowedPats (namedClausePats c)) $ genericDocError =<< + unlessM (allowedPats (namedClausePats c)) $ agda2hsErrorM $ "Cannot make function" <+> prettyTCM (defName def) <+> "inlinable." <+> "Inline functions can only use variable patterns or transparent record constructor patterns." _ -> - genericDocError =<< + agda2hsErrorM $ "Cannot make function" <+> prettyTCM f <+> "inlinable." <+> "An inline function must have exactly one clause." @@ -418,4 +417,4 @@ allowedPat _ = pure False allowedPats :: NAPs -> C Bool - allowedPats pats = allM pats (allowedPat . dget . dget) + allowedPats pats = allM (allowedPat . dget . dget) pats diff --git a/src/Agda2Hs/Compile/Function.hs-boot b/src/Agda2Hs/Compile/Function.hs-boot --- a/src/Agda2Hs/Compile/Function.hs-boot +++ b/src/Agda2Hs/Compile/Function.hs-boot @@ -1,6 +1,6 @@ module Agda2Hs.Compile.Function where -import qualified Language.Haskell.Exts.Syntax as Hs ( Match, Name ) +import qualified Agda2Hs.Language.Haskell as Hs ( Match, Name ) import Agda.Syntax.Internal ( Clause, ModuleName, QName, Type ) import Agda2Hs.Compile.Types ( C ) diff --git a/src/Agda2Hs/Compile/Imports.hs b/src/Agda2Hs/Compile/Imports.hs --- a/src/Agda2Hs/Compile/Imports.hs +++ b/src/Agda2Hs/Compile/Imports.hs @@ -2,12 +2,14 @@ import Data.Char ( isUpper ) import Data.List ( isPrefixOf ) +import qualified Data.List as L import Data.Map ( Map ) import qualified Data.Map as Map import Data.Set ( Set ) import qualified Data.Set as Set -import qualified Language.Haskell.Exts as Hs +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( validVarId, validConId, pp ) import Agda.Compiler.Backend import Agda.TypeChecking.Pretty ( text ) @@ -17,18 +19,18 @@ import Agda2Hs.Compile.Name import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils -import Agda2Hs.HsUtils -import qualified Data.List as L type ImportSpecMap = Map NamespacedName (Set NamespacedName) type ImportDeclMap = Map (Hs.ModuleName (), Qualifier) ImportSpecMap compileImports :: String -> Imports -> TCM [Hs.ImportDecl ()] compileImports top is0 = do - let is = filter (not . (top `isPrefixOf`) . Hs.prettyPrint . importModule) is0 + let is = filter ((top /=) . Hs.prettyPrint . importModule) is0 checkClashingImports is let imps = Map.toList $ groupModules is - return $ map (uncurry $ uncurry makeImportDecl) imps + reportSLn "agda2hs.import" 10 $ "All imported modules: " ++ show (map (pp . fst . fst) imps) + let decls = map (uncurry $ uncurry makeImportDecl) imps + return decls where mergeChildren :: ImportSpecMap -> ImportSpecMap -> ImportSpecMap mergeChildren = Map.unionWith Set.union @@ -38,18 +40,20 @@ makeSingle (Just p) q = Map.singleton p $ Set.singleton q groupModules :: [Import] -> ImportDeclMap - groupModules = foldr - (\(Import mod as p q ns) -> Map.insertWith mergeChildren (mod,as) - (makeSingle (parentNN p) (NamespacedName ns q))) - Map.empty - where - parentNN :: Maybe (Hs.Name ()) -> Maybe NamespacedName - parentNN (Just name@(Hs.Symbol _ _)) = Just $ NamespacedName (Hs.TypeNamespace ()) name - -- ^ for parents, if they are operators, we assume they are type operators - -- but actually, this will get lost anyway because of the structure of ImportSpec - -- the point is that there should not be two tuples with the same name and diffenrent namespaces - parentNN (Just name) = Just $ NamespacedName (Hs.NoNamespace ()) name - parentNN Nothing = Nothing + groupModules = flip foldr Map.empty $ \case + (Import mod as p q ns) -> + Map.insertWith mergeChildren (mod,as) + (makeSingle (parentNN p) (NamespacedName ns q)) + (ImportInstances mod) -> + Map.insertWith mergeChildren (mod,Unqualified) Map.empty + where + parentNN :: Maybe (Hs.Name ()) -> Maybe NamespacedName + parentNN (Just name@(Hs.Symbol _ _)) = Just $ NamespacedName (Hs.TypeNamespace ()) name + -- ^ for parents, if they are operators, we assume they are type operators + -- but actually, this will get lost anyway because of the structure of ImportSpec + -- the point is that there should not be two tuples with the same name and diffenrent namespaces + parentNN (Just name) = Just $ NamespacedName (Hs.NoNamespace ()) name + parentNN Nothing = Nothing -- TODO: avoid having to do this by having a CName instead of a -- Name in the Import datatype @@ -77,15 +81,17 @@ checkClashingImports [] = return () checkClashingImports (Import mod as p q _ : is) = case filter isClashing is of - (i : _) -> genericDocError =<< text (mkErrorMsg i) + (i : _) -> agda2hsStringError $ mkErrorMsg i [] -> checkClashingImports is where isClashing (Import _ as' p' q' _) = (as' == as) && (p' /= p) && (q' == q) + isClashing ImportInstances{} = False mkErrorMsg (Import _ _ p' q' _) = "Clashing import: " ++ pp q ++ " (both from " ++ prettyShow (pp <$> p) ++ " and " ++ prettyShow (pp <$> p') ++ ")" -- TODO: no range information as we only have Haskell names at this point + checkClashingImports (ImportInstances mod : is) = checkClashingImports is -- | Generate a prelude import considering prelude config options (hiding, implicit, etc). diff --git a/src/Agda2Hs/Compile/Name.hs b/src/Agda2Hs/Compile/Name.hs --- a/src/Agda2Hs/Compile/Name.hs +++ b/src/Agda2Hs/Compile/Name.hs @@ -8,12 +8,10 @@ import Data.Functor ( (<&>) ) import Data.Bifunctor ( bimap ) -import Data.List ( intercalate, isPrefixOf ) -import Data.Text ( unpack ) +import Data.List ( intercalate, isPrefixOf, stripPrefix ) +import qualified Data.Text as Text import qualified Data.Map.Strict as Map -import qualified Language.Haskell.Exts as Hs - import Agda.Compiler.Backend hiding ( topLevelModuleName ) import Agda.Compiler.Common ( topLevelModuleName ) @@ -31,17 +29,20 @@ import Agda.TypeChecking.Datatypes ( isDataOrRecordType ) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records ( isRecordConstructor ) +import Agda.TypeChecking.Warnings ( warning ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe ( isJust, isNothing, whenJust, fromMaybe, caseMaybeM ) -import Agda.Utils.Monad ( whenM ) +import Agda.Utils.Monad ( orM, whenM ) import Agda2Hs.AgdaUtils import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils -import Agda2Hs.HsUtils +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( hsName, hsModuleName, pp ) + isSpecialCon :: QName -> Maybe (Hs.QName ()) isSpecialCon = prettyShow >>> \case "Agda.Builtin.List.List" -> special Hs.ListCon @@ -64,7 +65,6 @@ defaultSpecialRules :: SpecialRules defaultSpecialRules = Map.fromList [ "Agda.Builtin.Nat.Nat" `to` "Natural" `importing` Just "Numeric.Natural" - , "Haskell.Control.Monad.guard" `to` "guard" `importing` Just "Control.Monad" , "Haskell.Prelude.coerce" `to` "unsafeCoerce" `importing` Just "Unsafe.Coerce" , "Agda.Builtin.Int.Int" `to` "Integer" `importing` Nothing , "Agda.Builtin.Word.Word64" `to` "Word" `importing` Nothing @@ -98,28 +98,50 @@ " to special constructor: " ++ Hs.prettyPrint c return c | otherwise = do - f <- isRecordConstructor f >>= return . \case + f <- isRecordConstructor f <&> \case Just (r, def) | not (_recNamedCon def) -> r -- use record name for unnamed constructors _ -> f hf0 <- compileName (qnameName f) - (hf, mimpBuiltin) <- fromMaybe (hf0, Nothing) <$> isSpecialName f + special <- isSpecialName f + let (hf, mimpBuiltin) = fromMaybe (hf0, Nothing) special + parent <- parentName f par <- traverse (compileName . qnameName) parent let mod0 = qnameModule $ fromMaybe f parent - mod <- compileModuleName mod0 - currMod <- hsTopLevelModuleName <$> asks currModule + (mkind, mod) <- compileModuleName mod0 + + existsInHaskell <- orM + [ pure $ isJust special + , pure $ mkind == PrimModule + , pure $ mkind == HsModule + , hasCompilePragma f + , isClassFunction f + , isWhereFunction f + , maybe (pure False) hasCompilePragma parent + ] + + unless existsInHaskell $ do + reportSDoc "agda2hs.name" 20 $ text "DOES NOT EXIST IN HASKELL" + typeError $ CustomBackendError "agda2hs" $ P.text $ + "Symbol " ++ Hs.prettyPrint hf ++ " is missing a COMPILE pragma or rewrite rule" + + currMod <- asks $ hsTopLevelModuleName . currModule let skipModule = mod == currMod || isJust mimpBuiltin || prettyShow mod0 `elem` primMonadModules - qual <- if | skipModule -> return Unqualified - | otherwise -> getQualifier (fromMaybe f parent) mod + qual <- if skipModule then return Unqualified + else getQualifier (fromMaybe f parent) mod -- we only calculate this when dealing with type operators; usually that's where 'type' prefixes are needed in imports - namespace <- (case hf of + namespace <- case hf of Hs.Symbol _ _ -> getNamespace f - Hs.Ident _ _ -> return (Hs.NoNamespace ())) + Hs.Ident _ _ -> return (Hs.NoNamespace ()) let - (mod', mimp) = mkImport mod qual par hf namespace - qf = qualify mod' hf qual + -- We generate import statements for everything except + -- unqualified prim modules (Prelude) + mimp = if mkind == PrimModule && not (isQualified qual) + then Nothing + else Just (Import mod qual par hf namespace) + qf = qualify mod hf qual -- add (possibly qualified) import whenM (asks writeImports) $ @@ -138,7 +160,7 @@ return qf where parentName :: QName -> C (Maybe QName) - parentName q = (theDef <$> getConstInfo q) >>= return . \case + parentName q = (theDef <$> getConstInfo q) <&> \case Constructor {conData = dt} -> Just dt Function {funProjection = proj} | Right (Projection {projProper = Just{}, projFromType = rt}) <- proj @@ -170,39 +192,44 @@ -- _getSort is not for that; e. g. a data has the same sort as its constructor. getNamespace :: QName -> C (Hs.Namespace ()) getNamespace qName = do - definition <- getConstInfo qName - case isSort $ unEl $ getResultType $ defType definition of - Just _ -> (reportSDoc "agda2hs.name" 25 $ text $ (prettyShow $ nameCanonical $ qnameName f) - ++ " is a type operator; will add \"type\" prefix before it") >> - return (Hs.TypeNamespace ()) - _ -> return (Hs.NoNamespace ()) + qType <- unEl . getResultType . defType <$> getConstInfo qName + if isJust $ isSort qType then do + let fname = nameCanonical $ qnameName f + reportSDoc "agda2hs.name" 25 $ pretty fname <+> + " is a type operator; will add \"type\" prefix before it" + return $ Hs.TypeNamespace () + else return $ Hs.NoNamespace () -- Gets the type of the result of the function (the type after the last "->"). getResultType :: Type -> Type - getResultType typ = case (unEl typ) of + getResultType typ = case unEl typ of (Pi _ absType) -> getResultType $ unAbs absType _ -> typ - mkImport mod qual par hf maybeIsType - -- make sure the Prelude is properly qualified - | any (`isPrefixOf` pp mod) primModules - = if isQualified qual then - let mod' = hsModuleName "Prelude" - in (mod', Just (Import mod' qual Nothing hf maybeIsType)) - else (mod, Nothing) - | otherwise - = (mod, Just (Import mod qual par hf maybeIsType)) +isWhereFunction :: QName -> C Bool +isWhereFunction f = do + whereMods <- asks whereModules + return $ any (qnameModule f `isLeChildModuleOf`) whereMods hsTopLevelModuleName :: TopLevelModuleName -> Hs.ModuleName () -hsTopLevelModuleName = hsModuleName . intercalate "." . map unpack +hsTopLevelModuleName = hsModuleName . Text.unpack . Text.intercalate "." . List1.toList . moduleNameParts -- | Given a module name (assumed to be a toplevel module), -- compute the associated Haskell module name. -compileModuleName :: ModuleName -> C (Hs.ModuleName ()) +compileModuleName :: ModuleName -> C (HsModuleKind, Hs.ModuleName ()) compileModuleName m = do tlm <- liftTCM $ hsTopLevelModuleName <$> getTopLevelModuleForModuleName m reportSDoc "agda2hs.name" 25 $ - text "Top-level module name for" <+> prettyTCM m <+> - text "is" <+> text (pp tlm) - return tlm + "Top-level module name for" <+> prettyTCM m <+> "is" <+> text (pp tlm) + case hsModuleKind tlm of + PrimModule -> return (PrimModule, Hs.ModuleName () "Prelude") + HsModule -> return (HsModule, dropHaskellPrefix tlm) + AgdaModule -> return (AgdaModule, tlm) + +importInstance :: QName -> C () +importInstance f = do + (kind, mod) <- compileModuleName $ qnameModule f + unless (kind == PrimModule) $ do + reportSLn "agda2hs.import" 20 $ "Importing instances from " ++ pp mod + tellImport $ ImportInstances mod diff --git a/src/Agda2Hs/Compile/Postulate.hs b/src/Agda2Hs/Compile/Postulate.hs --- a/src/Agda2Hs/Compile/Postulate.hs +++ b/src/Agda2Hs/Compile/Postulate.hs @@ -1,7 +1,5 @@ module Agda2Hs.Compile.Postulate where -import qualified Language.Haskell.Exts.Syntax as Hs - import Agda.Compiler.Backend import Agda.Syntax.Internal @@ -10,7 +8,9 @@ import Agda2Hs.Compile.Type ( compileType ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils -import Agda2Hs.HsUtils + +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( hsName, pp, hsError ) compilePostulate :: Definition -> C [Hs.Decl ()] compilePostulate def = do diff --git a/src/Agda2Hs/Compile/Record.hs b/src/Agda2Hs/Compile/Record.hs --- a/src/Agda2Hs/Compile/Record.hs +++ b/src/Agda2Hs/Compile/Record.hs @@ -8,15 +8,13 @@ import Data.Map ( Map ) import qualified Data.Map as Map -import qualified Language.Haskell.Exts as Hs - import Agda.Compiler.Backend -import Agda.Syntax.Common ( Arg(unArg), defaultArg ) +import Agda.Syntax.Common ( Arg(unArg), defaultArg, HasEta'(..) ) import Agda.Syntax.Internal import Agda.Syntax.Common.Pretty ( prettyShow ) -import Agda.TypeChecking.Pretty ( ($$), (<+>), text, vcat, prettyTCM ) +import Agda.TypeChecking.Pretty ( ($$), (<+>), text, vcat, prettyTCM, pretty, prettyList_ ) import Agda.TypeChecking.Substitute ( TelV(TelV), Apply(apply) ) import Agda.TypeChecking.Telescope @@ -29,8 +27,10 @@ import Agda2Hs.Compile.Type ( compileDomType, compileTeleBinds, compileDom, DomOutput(..) ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils -import Agda2Hs.HsUtils +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( hsName, definedName, pp, isQuantifiedAsst ) + -- | Primitive fields and default implementations type MinRecord = ([Hs.Name ()], Map (Hs.Name ()) (Hs.Decl ())) @@ -38,7 +38,10 @@ withMinRecord m = local $ \ e -> e { minRecordName = Just (qnameToMName m) } compileMinRecord :: [Hs.Name ()] -> QName -> C MinRecord -compileMinRecord fieldNames m = do +compileMinRecord fieldNames m = withMinRecord m $ do + reportSDoc "agda2hs.record.min" 20 $ + text "Compiling minimal record" <+> pretty m <+> + text "with field names" <+> prettyList_ (map (text . pp) fieldNames) rdef <- getConstInfo m definedFields <- classMemberNames rdef let Record{recPars = npars, recTel = tel} = theDef rdef @@ -48,9 +51,12 @@ -- We can't simply compileFun here for two reasons: -- * it has an explicit dictionary argument -- * it's using the fields and definitions from the minimal record and not the parent record - compiled <- withMinRecord m $ addContext (defaultDom rtype) $ compileLocal $ + compiled <- addContext (defaultDom rtype) $ compileLocal $ fmap concat $ traverse (compileFun False) defaults let declMap = Map.fromList [ (definedName c, def) | def@(Hs.FunBind _ (c : _)) <- compiled ] + reportSDoc "agda2hs.record.min" 20 $ + text "Done compiling minimal record" <+> pretty m <+> + text "defined fields: " <+> prettyList_ (map (text . pp) definedFields) return (definedFields, declMap) @@ -80,9 +86,9 @@ -- 2. assert that all default implementations are the same (for a certain field) let getUnique f (x :| xs) | all (x ==) xs = return x - | otherwise = genericDocError =<< do + | otherwise = agda2hsErrorM $ do text ("Conflicting default implementations for " ++ pp f ++ ":") $$ - vcat [ text "-" <+> multilineText (pp d) | d <- nub (x : xs) ] + vcat [ "-" <+> multilineText (pp d) | d <- nub (x : xs) ] decls <- Map.traverseWithKey getUnique $ Map.unionsWith (<>) $ (map . fmap) (:| []) defaults @@ -100,15 +106,19 @@ let fieldTel = snd $ splitTelescopeAt recPars recTel case target of ToClass ms -> do + when (length binds > 1) $ tellExtension Hs.MultiParamTypeClasses (classConstraints, classDecls) <- compileRecFields classDecl recFields fieldTel let context = case classConstraints of [] -> Nothing - [asst] -> Just (Hs.CxSingle () asst) + [asst] | not (isQuantifiedAsst asst) -> Just (Hs.CxSingle () asst) assts -> Just (Hs.CxTuple () assts) defaultDecls <- compileMinRecords def ms return $ Hs.ClassDecl () context hd [] (Just (classDecls ++ map (Hs.ClsDecl ()) defaultDecls)) ToRecord newtyp ds -> do checkValidConName cName + when (theEtaEquality recEtaEquality' == YesEta) $ agda2hsErrorM $ + "Agda records compiled to Haskell should have eta-equality disabled." <+> + "Add no-eta-equality to the definition of" <+> (text (pp rName) <> ".") (constraints, fieldDecls) <- compileRecFields fieldDecl recFields fieldTel when newtyp $ checkNewtypeCon cName fieldDecls let target = if newtyp then Hs.NewType () else Hs.DataType () @@ -123,10 +133,10 @@ -- record module has been opened. checkFieldInScope f = isInScopeUnqualified f >>= \case True -> return () - False -> setCurrentRangeQ f $ genericError $ - "Record projections (`" ++ prettyShow (qnameName f) ++ - "` in this case) must be brought into scope when compiling to Haskell record types. " ++ - "Add `open " ++ Hs.prettyPrint rName ++ " public` after the record declaration to fix this." + False -> setCurrentRangeQ f $ agda2hsErrorM $ + ("Record projections (`" <> prettyTCM (qnameName f) <>"` in this case)") <+> + "must be brought into scope when compiling to Haskell record types." <+> + "Add `open" <+> text (Hs.prettyPrint rName) <+> "public` after the record declaration to fix this." Record{..} = theDef def @@ -141,7 +151,7 @@ compileRecFields decl ns tel = case (ns, tel) of (_ , EmptyTel ) -> return ([], []) (n:ns, ExtendTel dom tel') -> do - hsDom <- compileDomType (absName tel') dom + hsDom <- withNestedType $ compileDomType (absName tel') dom (hsAssts, hsFields) <- underAbstraction dom tel' $ compileRecFields decl ns case hsDom of DomType s hsA -> do @@ -150,8 +160,10 @@ checkValidFunName fieldName return (hsAssts, decl fieldName fieldType : hsFields) DomConstraint hsA -> case target of - ToClass{} -> return (hsA : hsAssts , hsFields) - ToRecord{} -> genericError $ + ToClass{} -> do + when (isQuantifiedAsst hsA) $ tellExtension Hs.QuantifiedConstraints + return (hsA : hsAssts , hsFields) + ToRecord{} -> agda2hsError $ "Not supported: record/class with constraint fields" DomDropped -> return (hsAssts , hsFields) DomForall{} -> __IMPOSSIBLE__ @@ -176,24 +188,24 @@ -- recRecursive can be used again after agda 2.6.4.2 is released -- see agda/agda#7042 - unless (all null recMutual) $ genericDocError - =<< text "Unboxed record" <+> prettyTCM (defName def) - <+> text "cannot be recursive" + unless (all null recMutual) $ agda2hsErrorM $ + "Unboxed record" <+> prettyTCM (defName def) + <+> "cannot be recursive" TelV tel _ <- telViewUpTo recPars (defType def) addContext tel $ do pars <- getContextArgs let fieldTel = recTel `apply` pars fields <- nonErasedFields fieldTel - unless (length fields == 1) $ genericDocError - =<< text "Unboxed record" <+> prettyTCM (defName def) - <+> text "should have exactly one non-erased field" + unless (length fields == 1) $ agda2hsErrorM $ + "Unboxed record" <+> prettyTCM (defName def) + <+> "should have exactly one non-erased field" where nonErasedFields :: Telescope -> C [String] nonErasedFields EmptyTel = return [] nonErasedFields (ExtendTel a tel) = compileDom a >>= \case DODropped -> underAbstraction a tel nonErasedFields - DOType -> genericDocError =<< text "Type field in unboxed record not supported" - DOInstance -> genericDocError =<< text "Instance field in unboxed record not supported" + DOType -> agda2hsError "Type field in unboxed record not supported" + DOInstance -> agda2hsError "Instance field in unboxed record not supported" DOTerm -> (absName tel:) <$> underAbstraction a tel nonErasedFields diff --git a/src/Agda2Hs/Compile/Term.hs b/src/Agda2Hs/Compile/Term.hs --- a/src/Agda2Hs/Compile/Term.hs +++ b/src/Agda2Hs/Compile/Term.hs @@ -1,7 +1,8 @@ module Agda2Hs.Compile.Term where import Control.Arrow ( (>>>), (&&&), second ) -import Control.Monad ( unless, zipWithM ) +import Control.Monad ( zipWithM ) +import Control.Monad.Except import Control.Monad.Reader import Data.Foldable ( toList ) @@ -11,19 +12,22 @@ import qualified Data.Text as Text ( unpack ) import qualified Data.Set as Set ( singleton ) -import qualified Language.Haskell.Exts as Hs - import Agda.Syntax.Common.Pretty ( prettyShow ) import qualified Agda.Syntax.Common.Pretty as P import Agda.Syntax.Common import Agda.Syntax.Literal import Agda.Syntax.Internal +import Agda.TypeChecking.CheckInternal ( infer ) +import Agda.TypeChecking.Constraints ( noConstraints ) +import Agda.TypeChecking.Conversion ( equalTerm ) +import Agda.TypeChecking.InstanceArguments ( findInstance ) +import Agda.TypeChecking.MetaVars ( newInstanceMeta ) import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records ( shouldBeProjectible, isRecordType, recordFieldNames ) import Agda.TypeChecking.Datatypes ( getConType ) -import Agda.TypeChecking.Reduce ( unfoldDefinitionStep, instantiate ) +import Agda.TypeChecking.Reduce ( unfoldDefinitionStep, instantiate, reduce ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope ( telView, mustBePi, piApplyM, flattenTel ) import Agda.TypeChecking.ProjectionLike ( reduceProjectionLike ) @@ -35,14 +39,17 @@ import Agda.Utils.Size import Agda2Hs.AgdaUtils -import Agda2Hs.Compile.Name ( compileQName ) +import Agda2Hs.Compile.Name ( compileQName, importInstance ) import Agda2Hs.Compile.Type ( compileType, compileDom, DomOutput(..), compileTelSize ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils import Agda2Hs.Compile.Var ( compileDBVar ) -import Agda2Hs.HsUtils +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils + ( hsName, pp, eApp, hsLambda, hsUnqualName, hsVar ) + import {-# SOURCE #-} Agda2Hs.Compile.Function ( compileClause' ) import qualified Data.List as L @@ -101,7 +108,7 @@ -- fully applied b : t : f : es' -> return $ Hs.If () b t f `eApp` es' -- partially applied - _ -> genericError "if_then_else_ must be fully applied" + _ -> agda2hsError "if_then_else_ must be fully applied" -- | Compile @case_of_@ to Haskell @\case@ expression. @@ -114,7 +121,7 @@ let lam [] = id lam qs = Hs.Lambda () qs in return $ eApp (Hs.Case () e [Hs.Alt () p (Hs.UnGuardedRhs () $ lam ps b) Nothing]) es' - _ -> genericError "case_of_ must be fully applied to a lambda term" + _ -> agda2hsError "case_of_ must be fully applied to a lambda term" -- | Compile @the@ to an explicitly-annotated Haskell expression. @@ -123,14 +130,14 @@ annot <- compileType typ exp:args <- compileArgs ty args pure (Hs.ExpTypeSig () exp annot `eApp` args) -expTypeSig _ _ = genericError "`the` must be fully applied" +expTypeSig _ _ = agda2hsError "`the` must be fully applied" primWord64FromNat :: DefCompileRule primWord64FromNat ty args = compileArgs ty args >>= \case -- literal n@Hs.Lit{} : _ -> return n -- anything else - _ -> genericError "primWord64FromNat must be applied to a literal" + _ -> agda2hsError "primWord64FromNat must be applied to a literal" compileVar :: Int -> Type -> [Term] -> C (Hs.Exp ()) @@ -224,7 +231,7 @@ compileTupleProjection f b wty w ty args = do -- TODO: avoid redoing all of this work each time -- by storing the fields of each tuple type somewhere - when (b == Hs.Unboxed) $ genericError "projecting from unboxed tuples is not allowed" + when (b == Hs.Unboxed) $ agda2hsError "projecting from unboxed tuples is not allowed" reportSDoc "agda2hs.term.proj" 12 $ text "compiling tuple projection" (r, pars, def) <- lift $ fromMaybe __IMPOSSIBLE__ <$> isRecordType wty let fields = map unDom $ _recFields def @@ -233,8 +240,8 @@ [f1,f2] | f == f1 -> return $ hsName "fst" | f == f2 -> return $ hsName "snd" | otherwise -> __IMPOSSIBLE__ - fs' -> genericDocError =<< - text ("cannot project from tuple with " ++ show (size fs') ++ " fields") + fs' -> agda2hsStringError $ + "cannot project from tuple with " ++ show (size fs') ++ " fields" cw <- compileTerm wty w cargs <- compileArgs ty args return $ eApp (Hs.Var () $ Hs.UnQual () fname) (cw:cargs) @@ -247,8 +254,8 @@ compileTupleField f ty = compileDom ty >>= \case DODropped -> return Nothing DOTerm -> return (Just f) - DOType -> genericDocError =<< text "illegal type field in tuple record:" <+> prettyTCM f - DOInstance -> genericDocError =<< text "illegal instance field in tuple record:" <+> prettyTCM f + DOType -> agda2hsErrorM $ "illegal type field in tuple record:" <+> prettyTCM f + DOInstance -> agda2hsErrorM $ "illegal instance field in tuple record:" <+> prettyTCM f -- | Compile a projection(-like) definition @@ -382,7 +389,7 @@ int64Term :: ConCompileRule int64Term ty args = compileArgs ty args >>= \case n@Hs.Lit{} : _ -> return n - _ -> genericError "int64 must be applied to a literal" + _ -> agda2hsError "int64 must be applied to a literal" -- | @compileErasedApp@ compiles the application of unboxed constructors -- and transparent functions. @@ -451,8 +458,8 @@ v <- instantiate v - let bad s t = genericDocError =<< vcat - [ text "agda2hs: cannot compile" <+> text (s ++ ":") + let bad s t = agda2hsErrorM $ vcat + [ text "cannot compile" <+> text (s ++ ":") , nest 2 $ prettyTCM t ] @@ -503,8 +510,8 @@ -- usable domain, user-written lambda is preserved else if getOrigin argi == UserWritten then do - when (patternInTeleName `isPrefixOf` absName abs) $ genericDocError =<< - text "Record pattern translation not supported. Use a pattern matching lambda instead." + when (patternInTeleName `isPrefixOf` absName abs) $ agda2hsError $ + "Record pattern translation not supported. Use a pattern matching lambda instead." reportSDoc "agda2hs.compile" 17 $ text "compiling regular lambda" @@ -568,7 +575,7 @@ $ unfoldDefinitionStep (Def f [] `applys` args) f (Apply . defaultArg <$> args) case r of YesReduction _ t -> pure t - _ -> genericDocError =<< text "Could not reduce inline function" <+> prettyTCM f + _ -> agda2hsErrorM $ text "Could not reduce inline function" <+> prettyTCM f etaExpand (p:ps) ty args = do (dom, cod) <- mustBePi ty @@ -604,7 +611,7 @@ clauseToAlt :: Hs.Match () -> C (Hs.Alt ()) clauseToAlt (Hs.Match _ _ [p] rhs wh) = pure $ Hs.Alt () p rhs wh -clauseToAlt (Hs.Match _ _ ps _ _) = genericError "Pattern matching lambdas must take a single argument" +clauseToAlt (Hs.Match _ _ ps _ _) = agda2hsError "Pattern matching lambdas must take a single argument" clauseToAlt Hs.InfixMatch{} = __IMPOSSIBLE__ compileLiteral :: Literal -> C (Hs.Exp ()) @@ -614,4 +621,43 @@ compileLiteral (LitChar c) = return $ Hs.charE c compileLiteral (LitString t) = return $ Hs.Lit () $ Hs.String () s s where s = Text.unpack t -compileLiteral l = genericDocError =<< text "bad term:" prettyTCM (Lit l) +compileLiteral l = agda2hsErrorM $ text "bad term:" prettyTCM (Lit l) + + +checkInstance :: Term -> C () +checkInstance u = do + reportSDoc "agda2hs.checkInstance" 12 $ text "checkInstance" <+> prettyTCM u + reduce u >>= \case + Var x es -> do + unlessM (isInstance <$> domOfBV x) illegalInstance + checkInstanceElims es + Def f es -> do + unlessM (isJust . defInstance <$> getConstInfo f) illegalInstance + importInstance f + checkInstanceElims es + -- We need to compile applications of `fromNat`, `fromNeg`, and + -- `fromString` where the constraint type is ⊤ or IsTrue .... Ideally + -- this constraint would be marked as erased but this would involve + -- changing Agda builtins. + Con c _ _ + | prettyShow (conName c) == "Agda.Builtin.Unit.tt" || + prettyShow (conName c) == "Haskell.Prim.IsTrue.itsTrue" || + prettyShow (conName c) == "Haskell.Prim.IsFalse.itsFalse" -> return () + _ -> illegalInstance + + where + illegalInstance :: C () + illegalInstance = do + reportSDoc "agda2hs.checkInstance" 15 $ text "illegal instance: " <+> pretty u + agda2hsErrorM $ text "illegal instance: " <+> prettyTCM u + + checkInstanceElims :: Elims -> C () + checkInstanceElims = mapM_ checkInstanceElim + + checkInstanceElim :: Elim -> C () + checkInstanceElim (Apply v) = + when (isInstance v && usableQuantity v) $ + checkInstance $ unArg v + checkInstanceElim IApply{} = illegalInstance + checkInstanceElim (Proj _ f) = + unlessM (isInstance . defArgInfo <$> getConstInfo f) illegalInstance diff --git a/src/Agda2Hs/Compile/Type.hs b/src/Agda2Hs/Compile/Type.hs --- a/src/Agda2Hs/Compile/Type.hs +++ b/src/Agda2Hs/Compile/Type.hs @@ -11,10 +11,6 @@ import Data.Maybe ( mapMaybe, isJust ) import qualified Data.Set as Set ( singleton ) -import qualified Language.Haskell.Exts.Syntax as Hs -import qualified Language.Haskell.Exts.Extension as Hs -import qualified Language.Haskell.Exts.Pretty as Hs - import Agda.Compiler.Backend hiding ( Args ) import Agda.Syntax.Common @@ -38,7 +34,9 @@ import Agda2Hs.Compile.Utils import Agda2Hs.Compile.Var import Agda2Hs.AgdaUtils -import Agda2Hs.HsUtils +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils + ( Strictness(Lazy), hsName, tApp, constrainType, qualifyType ) -- | Type definitions from the prelude that get special translation rules. @@ -69,7 +67,7 @@ delayType :: Elims -> C (Hs.Type ()) delayType (Apply a : _) = compileType (unArg a) delayType (_ : _) = __IMPOSSIBLE__ -delayType [] = genericDocError =<< text "Cannot compile unapplied Delay type" +delayType [] = agda2hsError "Cannot compile unapplied Delay type" -- | Compile an Agda term into a Haskell type, along with its strictness. @@ -94,7 +92,7 @@ instantiate t >>= \case Pi a b -> do reportSDoc "agda2hs.compile.type" 13 $ text "Compiling pi type (" <+> prettyTCM (absName b) - <+> text ":" <+> prettyTCM a <+> text ") -> " <+> prettyTCM (unAbs b) + <+> text ":" <+> prettyTCM a <+> text ") -> " <+> underAbstraction a b prettyTCM let compileB = underAbstraction a b (compileType . unEl) compileDomType (absName b) a >>= \case DomType _ hsA -> Hs.TyFun () hsA <$> compileB @@ -105,8 +103,8 @@ Def f es -> maybeUnfoldCopy f es compileType $ \f es -> do def <- getConstInfo f if | not (usableModality def) -> - genericDocError - =<< text "Cannot use erased definition" <+> prettyTCM f + agda2hsErrorM $ + text "Cannot use erased definition" <+> prettyTCM f <+> text "in Haskell type" | Just semantics <- isSpecialType f -> setCurrentRange f $ semantics es | Just args <- allApplyElims es -> @@ -120,11 +118,11 @@ | otherwise -> fail Var x es | Just args <- allApplyElims es -> do - xi <- lookupBV x - unless (usableModality xi) $ genericDocError - =<< text "Cannot use erased variable" <+> prettyTCM (var x) + CtxVar _ ti <- lookupBV x + unless (usableModality ti) $ agda2hsErrorM $ + text "Cannot use erased variable" <+> prettyTCM (var x) <+> text "in Haskell type" - vs <- compileTypeArgs (snd $ unDom xi) args + vs <- compileTypeArgs (unDom ti) args x <- hsName <$> compileDBVar x return $ tApp (Hs.TyVar () x) vs @@ -144,10 +142,10 @@ -- Rewrite `\x -> f x` to `f` | Hs.TyApp _ f (Hs.TyVar _ y) <- body , y == x0 -> return f - | otherwise -> genericDocError =<< text "Not supported: type-level lambda" <+> prettyTCM t + | otherwise -> agda2hsErrorM $ text "Not supported: type-level lambda" <+> prettyTCM t _ -> fail - where fail = genericDocError =<< text "Bad Haskell type:" prettyTCM t + where fail = agda2hsErrorM $ text "Bad Haskell type:" prettyTCM t compileTypeArgs :: Type -> Args -> C [Hs.Type ()] @@ -158,7 +156,7 @@ reportSDoc "agda2hs.compile.type" 16 $ text " a =" <+> prettyTCM a reportSDoc "agda2hs.compile.type" 16 $ text " modality =" <+> prettyTCM (getModality a) let rest = compileTypeArgs (absApp b $ unArg x) xs - let fail msg = genericDocError =<< (text msg <> text ":") <+> parens (prettyTCM (absName b) <+> text ":" <+> prettyTCM (unDom a)) + let fail msg = agda2hsErrorM $ (text msg <> text ":") <+> parens (prettyTCM (absName b) <+> text ":" <+> prettyTCM (unDom a)) compileDom a >>= \case DODropped -> rest DOInstance -> fail "Type-level instance argument not supported" @@ -212,7 +210,7 @@ let [ Clause { namedClausePats = pats } ] = filter (isJust . clauseBody) cs - when (length args < length pats) $ genericDocError =<< + when (length args < length pats) $ agda2hsErrorM $ text "Cannot compile inlinable type alias" <+> prettyTCM f <+> text "as it must be fully applied." r <- liftReduce $ locallyReduceDefs (OnlyReduceDefs $ Set.singleton f) @@ -220,7 +218,7 @@ case r of YesReduction _ t -> compileType t - _ -> genericDocError =<< text "Could not reduce inline type alias " <+> prettyTCM f + _ -> agda2hsErrorM $ text "Could not reduce inline type alias " <+> prettyTCM f data DomOutput = DOInstance | DODropped | DOType | DOTerm @@ -270,14 +268,14 @@ compileTeleBinds EmptyTel = return [] compileTeleBinds (ExtendTel a tel) = do reportSDoc "agda2hs.compile.type" 15 $ text "Compiling type parameter: " <+> prettyTCM a - let fail msg = genericDocError =<< (text msg <> text ":") <+> parens (prettyTCM (absName tel) <+> text ":" <+> prettyTCM (unDom a)) + let fail msg = agda2hsErrorM $ (text msg <> text ":") <+> parens (prettyTCM (absName tel) <+> text ":" <+> prettyTCM (unDom a)) compileDom a >>= \case DODropped -> underAbstraction a tel compileTeleBinds DOType -> do ha <- compileKeptTeleBind (hsName $ absName tel) (unDom a) (ha:) <$> underAbstraction a tel compileTeleBinds - DOInstance -> fail "Constraint in type parameter not supported" - DOTerm -> fail "Term variable in type parameter not supported" + DOInstance -> agda2hsError "Constraint in type parameter not supported" + DOTerm -> agda2hsError "Term variable in type parameter not supported" compileKeptTeleBind :: Hs.Name () -> Type -> C (Hs.TyVarBind ()) compileKeptTeleBind x t = do @@ -295,4 +293,4 @@ DOInstance -> err _ -> err where - err = genericDocError =<< text "Not a valid Haskell kind: " <+> prettyTCM t + err = agda2hsErrorM $ text "Not a valid Haskell kind: " <+> prettyTCM t diff --git a/src/Agda2Hs/Compile/TypeDefinition.hs b/src/Agda2Hs/Compile/TypeDefinition.hs --- a/src/Agda2Hs/Compile/TypeDefinition.hs +++ b/src/Agda2Hs/Compile/TypeDefinition.hs @@ -4,8 +4,6 @@ import Data.Maybe ( fromMaybe ) -import qualified Language.Haskell.Exts.Syntax as Hs - import Agda.Compiler.Backend import Agda.Syntax.Common ( namedArg ) @@ -21,10 +19,11 @@ import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils import Agda2Hs.Compile.Var ( compileDBVar ) -import Agda2Hs.HsUtils import Agda.Syntax.Common.Pretty (prettyShow) import Agda.TypeChecking.Substitute +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( hsName ) compileTypeDef :: Hs.Name () -> Definition -> C [Hs.Decl ()] compileTypeDef name (Defn {..}) = do @@ -39,7 +38,7 @@ Function{..} = theDef singleClause = \case [cl] -> return cl - _ -> genericError "Not supported: type definition with several clauses" + _ -> agda2hsError "Not supported: type definition with several clauses" compileTypePatternArgs :: Type -> NAPs -> C [Hs.TyVarBind ()] compileTypePatternArgs ty naps = do @@ -49,11 +48,11 @@ assertIsTyVarBind :: Hs.Type () -> C (Hs.TyVarBind ()) assertIsTyVarBind = \case Hs.TyVar _ n -> pure $ Hs.UnkindedVar () n - _ -> genericError "Not supported: type definition by pattern matching" + _ -> agda2hsError "Not supported: type definition by pattern matching" compileTypeArg :: DeBruijnPattern -> C (Hs.TyVarBind ()) compileTypeArg p@(VarP o i) = do name <- hsName <$> compileDBVar (dbPatVarIndex i) checkValidTyVarName name return $ Hs.UnkindedVar () name -compileTypeArg _ = genericError "Not supported: type definition by pattern matching" +compileTypeArg _ = agda2hsError "Not supported: type definition by pattern matching" diff --git a/src/Agda2Hs/Compile/Types.hs b/src/Agda2Hs/Compile/Types.hs --- a/src/Agda2Hs/Compile/Types.hs +++ b/src/Agda2Hs/Compile/Types.hs @@ -14,18 +14,15 @@ import Data.Map ( Map ) import Data.String ( IsString(..) ) -import qualified Language.Haskell.Exts.SrcLoc as Hs -import qualified Language.Haskell.Exts.Syntax as Hs -import qualified Language.Haskell.Exts.Extension as Hs -import qualified Language.Haskell.Exts.Comments as Hs - import Agda.Compiler.Backend import Agda.Syntax.Position ( Range ) import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName ) +import Agda.TypeChecking.Warnings ( MonadWarning ) import Agda.Utils.Null import Agda.Utils.Impossible -import Agda2Hs.HsUtils ( Strictness ) +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( Strictness ) type ModuleEnv = TopLevelModuleName type ModuleRes = () @@ -107,16 +104,21 @@ -- | Encoding of a Haskell module import statement. data Import = Import - { importModule :: Hs.ModuleName () - , importQualified :: Qualifier - , importParent :: Maybe (Hs.Name ()) - , importName :: Hs.Name () - , importNamespace :: Hs.Namespace () + { _importModule :: Hs.ModuleName () + , _importQualified :: Qualifier + , _importParent :: Maybe (Hs.Name ()) + , _importName :: Hs.Name () + , _importNamespace :: Hs.Namespace () -- ^^ if this is a type or something like that, we can add a namespace qualifier to the import spec -- now it's only useful for differentiating type operators; so for others we always put Hs.NoNamespace () here -- (we don't calculate it if it's not necessary) } + | ImportInstances (Hs.ModuleName ()) +importModule :: Import -> Hs.ModuleName () +importModule (Import{ _importModule = mod }) = mod +importModule (ImportInstances mod) = mod + type Imports = [Import] -- | Output produced during the compilation of a module @@ -174,6 +176,7 @@ runStConcreteNames m = rwsT $ \r s -> runStConcreteNames $ StateT $ \ns -> do ((x, ns'), s', w) <- runRWST (runStateT m ns) r s pure ((x, s', w), ns') +instance MonadWarning C where instance IsString a => IsString (C a) where fromString = pure . fromString instance PureTCM C where instance Null a => Null (C a) where diff --git a/src/Agda2Hs/Compile/Utils.hs b/src/Agda2Hs/Compile/Utils.hs --- a/src/Agda2Hs/Compile/Utils.hs +++ b/src/Agda2Hs/Compile/Utils.hs @@ -7,12 +7,19 @@ import Control.Monad.Writer ( tell ) import Control.Monad.State ( put, modify ) +import Data.List ( isPrefixOf, stripPrefix ) import Data.Maybe ( isJust ) import qualified Data.Map as M +import Data.String ( IsString(..) ) +import GHC.Stack (HasCallStack) + import qualified Language.Haskell.Exts as Hs +import System.FilePath ( () ) + import Agda.Compiler.Backend hiding ( Args ) +import Agda.Compiler.Common ( compileDir ) import Agda.Syntax.Common import qualified Agda.Syntax.Concrete.Name as C @@ -20,6 +27,7 @@ import Agda.Syntax.Position ( noRange ) import Agda.Syntax.Scope.Base import Agda.Syntax.Scope.Monad ( bindVariable, freshConcreteName, isDatatypeModule ) +import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Common.Pretty ( prettyShow ) import qualified Agda.Syntax.Common.Pretty as P @@ -44,12 +52,30 @@ import AgdaInternals import Agda2Hs.AgdaUtils ( (~~) ) import Agda2Hs.Compile.Types -import Agda2Hs.HsUtils import Agda2Hs.Pragma import qualified Data.List as L import Agda.Utils.Impossible ( __IMPOSSIBLE__ ) +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils + ( Strictness(..), validVarName, validTypeName, validConName, hsName, pp ) +agda2hsError :: (HasCallStack, MonadTCError m) => Doc -> m a +agda2hsError msg = typeError $ CustomBackendError "agda2hs" msg + +agda2hsErrorM :: (HasCallStack, MonadTCError m) => m Doc -> m a +agda2hsErrorM msg = agda2hsError =<< msg + +agda2hsStringError :: (HasCallStack, MonadTCError m) => String -> m a +agda2hsStringError = agda2hsError . fromString + + +data HsModuleKind + = PrimModule + | HsModule + | AgdaModule + deriving (Eq) + -- | Primitive modules provided by the agda2hs library. -- None of those (and none of their children) will get processed. primModules = @@ -57,10 +83,18 @@ , "Agda.Primitive" , "Haskell.Prim" , "Haskell.Prelude" - , "Haskell.Law" ] +hsModuleKind :: Hs.ModuleName () -> HsModuleKind +hsModuleKind mod + | any (`isPrefixOf` pp mod) primModules = PrimModule + | "Haskell." `isPrefixOf` pp mod = HsModule + | otherwise = AgdaModule +dropHaskellPrefix :: Hs.ModuleName () -> Hs.ModuleName () +dropHaskellPrefix (Hs.ModuleName l s) = + Hs.ModuleName l $ fromMaybe s $ stripPrefix "Haskell." s + concatUnzip :: [([a], [b])] -> ([a], [b]) concatUnzip = (concat *** concat) . unzip @@ -102,7 +136,7 @@ Con c _ es | [] <- vis es, conName c ~~ nil -> return [] | [x, xs] <- vis es, conName c ~~ cons -> (x :) <$> makeList' nil cons err xs - _ -> genericDocError =<< err + _ -> agda2hsErrorM err where vis es = [ unArg a | Apply a <- es, visible a ] @@ -112,7 +146,7 @@ ConP c _ ps | [] <- vis ps, conName c ~~ nil -> return [] | [x, xs] <- vis ps, conName c ~~ cons -> (x :) <$> makeListP' nil cons err xs - _ -> genericDocError =<< err + _ -> agda2hsErrorM err where vis ps = [ namedArg p | p <- ps, visible p ] @@ -152,6 +186,18 @@ ] where b = El __DUMMY_SORT__ x +hasCompilePragma :: QName -> C Bool +hasCompilePragma q = processPragma q <&> \case + NoPragma{} -> False + InlinePragma{} -> True + DefaultPragma{} -> True + ClassPragma{} -> True + ExistingClassPragma{} -> True + UnboxPragma{} -> True + TransparentPragma{} -> True + NewTypePragma{} -> True + DerivePragma{} -> True + -- Exploits the fact that the name of the record type and the name of the record module are the -- same, including the unique name ids. isClassFunction :: QName -> C Bool @@ -189,6 +235,12 @@ True -> dropClassModule $ MName $ init ns False -> return m +-- Gets the path of the Haskell file to be generated +moduleFileName :: Options -> TopLevelModuleName -> TCM FilePath +moduleFileName opts name = do + outDir <- compileDir + return $ fromMaybe outDir (optOutDir opts) moduleNameToFileName name "hs" + isUnboxRecord :: QName -> C (Maybe Strictness) isUnboxRecord q = do getConstInfo q >>= \case @@ -237,44 +289,6 @@ (InlinePragma ==) <$> processPragma r _ -> return False -checkInstance :: Term -> C () -checkInstance u = do - reportSDoc "agda2hs.checkInstance" 12 $ text "checkInstance" <+> prettyTCM u - reduce u >>= \case - Var x es -> do - unlessM (isInstance <$> domOfBV x) illegalInstance - checkInstanceElims es - Def f es -> do - unlessM (isJust . defInstance <$> getConstInfo f) illegalInstance - checkInstanceElims es - -- We need to compile applications of `fromNat`, `fromNeg`, and - -- `fromString` where the constraint type is ⊤ or IsTrue .... Ideally - -- this constraint would be marked as erased but this would involve - -- changing Agda builtins. - Con c _ _ - | prettyShow (conName c) == "Agda.Builtin.Unit.tt" || - prettyShow (conName c) == "Haskell.Prim.IsTrue.itsTrue" || - prettyShow (conName c) == "Haskell.Prim.IsFalse.itsFalse" -> return () - _ -> illegalInstance - - where - illegalInstance :: C () - illegalInstance = do - reportSDoc "agda2hs.checkInstance" 15 $ text "illegal instance: " <+> pretty u - genericDocError =<< text "illegal instance: " <+> prettyTCM u - - checkInstanceElims :: Elims -> C () - checkInstanceElims = mapM_ checkInstanceElim - - checkInstanceElim :: Elim -> C () - checkInstanceElim (Apply v) = case getHiding v of - Instance{} -> checkInstance $ unArg v - Hidden -> return () - NotHidden -> return () - checkInstanceElim IApply{} = illegalInstance - checkInstanceElim (Proj _ f) = - unlessM (isInstance . defArgInfo <$> getConstInfo f) illegalInstance - withNestedType :: C a -> C a withNestedType = local $ \e -> e { isNestedInType = True } @@ -296,29 +310,29 @@ hsLCase = (incrementLCase >>) . return . Hs.LCase () ensureNoLocals :: String -> C () -ensureNoLocals msg = unlessM (null <$> asks locals) $ genericError msg +ensureNoLocals msg = unlessM (null <$> asks locals) $ agda2hsStringError msg withLocals :: LocalDecls -> C a -> C a withLocals ls = local $ \e -> e { locals = ls } checkValidVarName :: Hs.Name () -> C () -checkValidVarName x = unless (validVarName x) $ genericDocError =<< do +checkValidVarName x = unless (validVarName x) $ agda2hsErrorM $ do text "Invalid name for Haskell variable: " <+> text (Hs.prettyPrint x) checkValidTyVarName :: Hs.Name () -> C () -checkValidTyVarName x = unless (validVarName x) $ genericDocError =<< do +checkValidTyVarName x = unless (validVarName x) $ agda2hsErrorM $ do text "Invalid name for Haskell type variable: " <+> text (Hs.prettyPrint x) checkValidFunName :: Hs.Name () -> C () -checkValidFunName x = unless (validVarName x) $ genericDocError =<< do +checkValidFunName x = unless (validVarName x) $ agda2hsErrorM $ do text "Invalid name for Haskell function: " <+> text (Hs.prettyPrint x) checkValidTypeName :: Hs.Name () -> C () -checkValidTypeName x = unless (validTypeName x) $ genericDocError =<< do +checkValidTypeName x = unless (validTypeName x) $ agda2hsErrorM $ do text "Invalid name for Haskell type: " <+> text (Hs.prettyPrint x) checkValidConName :: Hs.Name () -> C () -checkValidConName x = unless (validConName x) $ genericDocError =<< do +checkValidConName x = unless (validConName x) $ agda2hsErrorM $ do text "Invalid name for Haskell constructor: " <+> text (Hs.prettyPrint x) tellImport :: Import -> C () @@ -342,7 +356,7 @@ addTyBang Lazy ty = return ty checkSingleElement :: Hs.Name () -> [b] -> String -> C () -checkSingleElement name fs s = unless (length fs == 1) $ genericDocError =<< do +checkSingleElement name fs s = unless (length fs == 1) $ agda2hsErrorM $ do text (s ++ ":") <+> text (Hs.prettyPrint name) checkNewtypeCon :: Hs.Name () -> [b] -> C () @@ -353,8 +367,8 @@ checkFixityLevel name Unrelated = pure Nothing checkFixityLevel name (Related lvl) = if lvl /= fromInteger (round lvl) || lvl < 0 - then genericDocError =<< text "Invalid fixity" <+> pretty lvl - <+> text "for operator" <+> prettyTCM name + then agda2hsErrorM $ text "Invalid fixity" <+> pretty lvl + <+> text "for operator" <+> prettyTCM name else pure (Just (round lvl)) maybePrependFixity :: QName -> Fixity -> C [Hs.Decl ()] -> C [Hs.Decl ()] @@ -385,7 +399,7 @@ where checkPatternInfo :: PatternInfo -> C () checkPatternInfo i = unless (null $ patAsNames i) $ - genericDocError =<< text "not supported by agda2hs: as patterns" + agda2hsError "not supported: as patterns" noWriteImports :: C a -> C a noWriteImports = local $ \e -> e { writeImports = False } diff --git a/src/Agda2Hs/Compile/Var.hs b/src/Agda2Hs/Compile/Var.hs --- a/src/Agda2Hs/Compile/Var.hs +++ b/src/Agda2Hs/Compile/Var.hs @@ -10,7 +10,7 @@ import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Syntax.Abstract.Name ( nameConcrete ) import Agda.TypeChecking.Pretty ( text ) -import Agda.TypeChecking.Monad.Base ( genericDocError ) +import Agda.TypeChecking.Monad.Base ( ContextEntry(..) ) import Agda.TypeChecking.Monad.Context ( lookupBV ) import Agda.Utils.Monad ( whenM ) @@ -18,5 +18,5 @@ -- | Compile a variable. compileDBVar :: Nat -> C String compileDBVar x = do - (d, n) <- (fmap snd &&& fst . unDom) <$> lookupBV x + n <- ceName <$> lookupBV x return $ prettyShow $ nameConcrete n diff --git a/src/Agda2Hs/Config.hs b/src/Agda2Hs/Config.hs --- a/src/Agda2Hs/Config.hs +++ b/src/Agda2Hs/Config.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -- Read additional configuration options from a file. module Agda2Hs.Config (checkConfig) where @@ -15,7 +14,9 @@ import Agda2Hs.Compile.Types import Agda2Hs.Compile.Name ( toNameImport ) -import Agda.TypeChecking.Monad.Base ( TCM, genericDocError ) +import Agda2Hs.Compile.Utils ( agda2hsError ) + +import Agda.TypeChecking.Monad.Base ( TCM ) import Agda.Syntax.Common.Pretty -- | Config file data. @@ -48,7 +49,7 @@ readConfigFile :: FilePath -> TCM Config readConfigFile src = do liftIO (Yaml.decodeFileEither src) >>= \case - Left err -> genericDocError $ vcat + Left err -> agda2hsError $ vcat [ text "An error occured while trying to parse config file " <> text src <>":" , multiLineText (Yaml.prettyPrintParseException err) ] diff --git a/src/Agda2Hs/HsUtils.hs b/src/Agda2Hs/HsUtils.hs deleted file mode 100644 --- a/src/Agda2Hs/HsUtils.hs +++ /dev/null @@ -1,316 +0,0 @@ - -module Agda2Hs.HsUtils where - -import Control.Monad ( guard ) - -import Data.Data ( Data ) -import Data.Generics ( listify, everywhere, mkT, extT ) -import Data.List ( foldl' ) -import Data.Map ( Map ) - -import qualified Data.Map as Map - -import Language.Haskell.Exts hiding ( Strict, Lazy ) - -import Agda.Syntax.Position - -import Agda.Utils.FileName ( mkAbsolute ) -import Agda.Utils.List ( initLast ) -import Agda.Utils.Maybe.Strict ( toStrict ) -import System.FilePath (isAbsolute) -import Agda.Utils.Maybe (boolToMaybe) - --- Names ------------------------------------------------------------------ - - -validVarId :: String -> Bool -validVarId s = case lexTokenStream s of - ParseOk [Loc _ VarId{}] -> True - _ -> False - -validConId :: String -> Bool -validConId s = case lexTokenStream s of - ParseOk [Loc _ ConId{}] -> True - _ -> False - -validVarSym :: String -> Bool -validVarSym s = case lexTokenStream s of - ParseOk [Loc _ VarSym{}] -> True - _ -> False - -validConSym :: String -> Bool -validConSym s = case lexTokenStream s of - ParseOk [Loc _ ConSym{}] -> True - _ -> False - -validVarName :: Name () -> Bool -validVarName (Ident _ s) = validVarId s -validVarName (Symbol _ s) = validVarSym s - -validTypeName :: Name () -> Bool -validTypeName (Ident _ s) = validConId s -validTypeName (Symbol _ s) = validVarSym s || validConSym s -- type operators need not start with a colon - -validConName :: Name () -> Bool -validConName (Ident _ s) = validConId s -validConName (Symbol _ s) = validConSym s - -isInfix :: String -> Maybe String -isInfix ('_' : f) = do - (op, '_') <- initLast f - guard $ not $ '_' `elem` op - return op -isInfix _ = Nothing - -hsName :: String -> Name () -hsName x - | Just op <- isInfix x = Symbol () op - | otherwise = Ident () (map underscore x) - where - -- Agda uses underscores for operators, which means that you can't have both mapM and mapM_ - -- without getting ambiguities. To work around this we translate subscript '-' to underscore. - underscore '₋' = '_' - underscore c = c - -extToName :: KnownExtension -> Name () -extToName = Ident () . show - -hsModuleName :: String -> ModuleName () -hsModuleName = ModuleName () - -isOp :: QName () -> Bool -isOp (UnQual _ Symbol{}) = True -isOp (Special _ Cons{}) = True -isOp _ = False - -isSpecial :: QName () -> Bool -isSpecial (Special _ _) = True -isSpecial _ = False - -unQual :: QName () -> Name () -unQual (UnQual _ n) = n -unQual (Qual _ _ n) = n -unQual (Special _ _) = error "Unexpected special con" - -definedName :: Match l -> Name l -definedName (Match _ f _ _ _) = f -definedName (InfixMatch _ _ f _ _ _) = f - -replaceName :: Data a => Name () -> Name () -> a -> a -replaceName pre post = everywhere (mkT go `extT` go') - where - go :: QName () -> QName () - go n | isSpecial n = n - | unQual n == pre = UnQual () post - | otherwise = n - - go' :: Match () -> Match () - go' m = case m of - (Match () n ps rhs bs) -> Match () (f n) ps rhs bs - (InfixMatch () p n ps rhs bs) -> InfixMatch () p (f n) ps rhs bs - where f n | n == pre = post - | otherwise = n - -dropPatterns :: Data a => Int -> a -> a -dropPatterns n = everywhere (mkT go) - where - go :: Match () -> Match () - go (Match () f ps rhs bs) = Match () f (drop n ps) rhs bs - go m = m - - --- Utilities for building Haskell constructs - -pp :: Pretty a => a -> String -pp = prettyPrintWithMode defaultMode{ spacing = False - , classIndent = 4 - , whereIndent = 2 - } - - --- exactPrint really looks at the line numbers (and we're using the locations from the agda source --- to report Haskell parse errors at the right location), so shift everything to start at line 1. -moveToTop :: Annotated ast => (ast SrcSpanInfo, [Comment]) -> (ast SrcSpanInfo, [Comment]) -moveToTop (x, cs) = (subtractLine l <$> x, [ Comment b (sub l r) str | Comment b r str <- cs ]) - where l = startLine (ann x) - 1 - subtractLine :: Int -> SrcSpanInfo -> SrcSpanInfo - subtractLine l (SrcSpanInfo s ss) = SrcSpanInfo (sub l s) (map (sub l) ss) - - sub :: Int -> SrcSpan -> SrcSpan - sub l (SrcSpan f l0 c0 l1 c1) = SrcSpan f (l0 - l) c0 (l1 - l) c1 - -getList :: Exp () -> Maybe [Exp ()] -getList (Con _ (Special _ ListCon{})) = Just [] -getList (List _ es) = Just es -getList _ = Nothing - -getListP :: Pat () -> Maybe [Pat ()] -getListP (PApp _ (Special _ ListCon{}) []) = Just [] -getListP (PList _ es) = Just es -getListP _ = Nothing - -pApp :: QName () -> [Pat ()] -> Pat () -pApp c@(UnQual () (Symbol () _)) [p, q] = PInfixApp () p c q -pApp (Special _ Cons{}) [p, q] | Just ps <- getListP q = PList () (p : ps) -pApp c@(Special () Cons{}) [p, q] = PInfixApp () p c q -pApp c ps = PApp () c ps - -getOp :: Exp () -> Maybe (QOp ()) -getOp (Var _ x) | isOp x = Just $ QVarOp () x -getOp (Con _ c) | isOp c = Just $ QConOp () c -getOp _ = Nothing - -eApp :: Exp () -> [Exp ()] -> Exp () -eApp f [a, b] | Just (QConOp () (Special _ Cons{})) <- getOp f, - Just as <- getList b = List () (a : as) -eApp f (a : b : as) | Just op <- getOp f = foldl (App ()) (InfixApp () a op b) as -eApp f [a] | Just op <- getOp f = LeftSection () a op -eApp f es = foldl (App ()) f es - -tApp :: Type () -> [Type ()] -> Type () -tApp (TyCon () (Special () ListCon{})) [a] = TyList () a -tApp t vs = foldl (TyApp ()) t vs - -hsLambda :: String -> Exp () -> Exp () -hsLambda x e = - case e of - Lambda l ps b -> Lambda l (p : ps) b - _ -> Lambda () [p] e - where - p = PVar () $ hsName x - -hsUnqualName :: String -> QName () -hsUnqualName = UnQual () . hsName - -hsVar :: String -> Exp () -hsVar = Var () . hsUnqualName - -hsUndefined :: Exp () -hsUndefined = hsVar "undefined" - -hsError :: String -> Exp () -hsError s = hsVar "error" `eApp` [strE s] - -cname :: CName l -> Name l -cname (VarName _ n) = n -cname (ConName _ n) = n - -cloc :: CName l -> l -cloc (VarName l _) = l -cloc (ConName l _) = l - -srcSpanToRange :: SrcSpan -> Range -srcSpanToRange (SrcSpan file l1 c1 l2 c2) = - intervalToRange (toStrict $ boolToMaybe (isAbsolute file) $ mkRangeFile (mkAbsolute file) Nothing) $ Interval (pos l1 c1) (pos l2 c2) - where pos l c = Pn () 0 (fromIntegral l) (fromIntegral c) - -srcLocToRange :: SrcLoc -> Range -srcLocToRange (SrcLoc file l c) = srcSpanToRange (SrcSpan file l c l c) - -srcSpanInfoToRange :: SrcSpanInfo -> Range -srcSpanInfoToRange = srcSpanToRange . srcInfoSpan - -allUsedTypes :: Data a => a -> [Type ()] -allUsedTypes = listify (const True) - -usedTypesOf :: Data a => String -> a -> [Type ()] -usedTypesOf s = listify $ (== s) . pp - -uses :: Data a => String -> a -> Bool -uses ty = not . null . usedTypesOf ty - --- Fixities - --- Ideally, our pretty-printing library should insert parenthesis where needed. --- However, hs-src-exts does not insert adequate parenthesis for infix --- operators so we need to insert some by hand (see issues #54 and #273 and #317). - --- | Properly parenthesize an expression with regards to the default fixities. -insertParens :: Data a => a -> a -insertParens = everywhere (mkT $ insertPars $ fixityMap baseFixities) - where - fixityMap fxs = Map.fromList [ (q, fx) | fx@(Fixity _ _ q) <- fxs ] - --- | Given fixities of operators, properly parenthesize an expression. -insertPars :: Map (QName ()) Fixity -> Exp () -> Exp () -insertPars fixs = \case - (InfixApp l e1 op e2) -> InfixApp l (parL op e1) op (parR op e2) - (LeftSection l e1 op) -> LeftSection l (parL op e1) op - (RightSection l op e2) -> RightSection l op (parR op e2) - e -> e - where - getFix op = Map.lookup (qopName op) fixs - - qopName (QVarOp _ x) = x - qopName (QConOp _ x) = x - - needParen same (Just (Fixity atop top _)) (Just (Fixity achild child _)) - | top > child = True - | top < child = False - | atop /= achild = True - | otherwise = same atop - needParen _ Nothing _ = True -- If we don't know, add parens - needParen _ _ Nothing = True - - needParenExpr (InfixApp _ _ _ e2) = needParenExpr e2 - needParenExpr Lambda{} = True - needParenExpr _ = False - - parL topOp e = - if needParenExpr e - then mkParen e - else par topOp (needParen (AssocLeft () /=)) e - parR topOp = par topOp (needParen (AssocRight () /=)) - - par topOp need e@(InfixApp _ _ op _) - | need (getFix topOp) (getFix op) = mkParen e - par _ _ e = e - -mkParen :: Exp () -> Exp () -mkParen e@Paren{} = e -mkParen e = Paren () e - - --- Patterns -patToExp :: Pat l -> Maybe (Exp l) -patToExp = \case - PVar l x -> Just $ Var l (UnQual l x) - PLit l s v -> Just $ Lit l v - PInfixApp l p f q -> InfixApp l <$> patToExp p <*> pure (QConOp l f) <*> patToExp q - PApp l x ps -> foldl' (App l) (Con l x) <$> traverse patToExp ps - PTuple l b ps -> Tuple l b <$> traverse patToExp ps - PUnboxedSum l i j p -> UnboxedSum l i j <$> patToExp p - PList l ps -> List l <$> traverse patToExp ps - PParen l p -> Paren l <$> patToExp p - PAsPat _ _ p -> patToExp p - PIrrPat _ p -> patToExp p - PatTypeSig _ p _ -> patToExp p - PBangPat _ p -> patToExp p - _ -> Nothing - - -data Strictness = Lazy | Strict - deriving (Eq, Show) - - --- | Add a class constraint to a Haskell type. -constrainType - :: Asst () -- ^ The class assertion. - -> Type () -- ^ The type to constrain. - -> Type () -constrainType c = \case - TyForall _ as (Just (CxTuple _ cs)) t -> TyForall () as (Just (CxTuple () (c:cs))) t - TyForall _ as (Just (CxSingle _ c')) t -> TyForall () as (Just (CxTuple () [c,c'])) t - TyForall _ as Nothing t -> TyForall () as (Just (CxSingle () c )) t - t -> TyForall () Nothing (Just (CxSingle () c )) t - - --- | Add explicit quantification over a variable to a Haskell type. -qualifyType - :: TyVarBind () -- ^ Name of the variable. - -> Type () -- ^ Type to quantify. - -> Type () -qualifyType a = \case - TyForall _ (Just as) cs t -> TyForall () (Just (a:as)) cs t - TyForall _ Nothing cs t -> TyForall () (Just [a] ) cs t - t -> TyForall () (Just [a] ) Nothing t diff --git a/src/Agda2Hs/Language/Haskell.hs b/src/Agda2Hs/Language/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Agda2Hs/Language/Haskell.hs @@ -0,0 +1,30 @@ +-- | Haskell syntax, parsing, pretty printing. +-- +-- This module contains those elements of the Haskell language +-- that are needed by Agda2hs. +-- +-- We are mainly re-exporting @haskell-src-exts@. +module Agda2Hs.Language.Haskell + ( module Language.Haskell.Exts.Build + , module Language.Haskell.Exts.Comments + , module Language.Haskell.Exts.ExactPrint + , module Language.Haskell.Exts.Extension + , module Language.Haskell.Exts.Parser + , module Language.Haskell.Exts.Pretty + , module Language.Haskell.Exts.SrcLoc + , module Language.Haskell.Exts.Syntax + , module Agda2Hs.Language.Haskell.Pretty + , module Agda2Hs.Language.Haskell.Utils + ) where + +import Agda2Hs.Language.Haskell.Pretty +import Agda2Hs.Language.Haskell.Utils + +import Language.Haskell.Exts.Comments (Comment) +import Language.Haskell.Exts.Build hiding (pApp) +import Language.Haskell.Exts.ExactPrint (exactPrint) +import Language.Haskell.Exts.Extension hiding (Strict, Lazy) +import Language.Haskell.Exts.Parser +import Language.Haskell.Exts.Pretty +import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) +import Language.Haskell.Exts.Syntax diff --git a/src/Agda2Hs/Language/Haskell/Pretty.hs b/src/Agda2Hs/Language/Haskell/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Agda2Hs/Language/Haskell/Pretty.hs @@ -0,0 +1,61 @@ +-- | Pretty printing tweaks for @haskell-src-exts@. +module Agda2Hs.Language.Haskell.Pretty + ( prettyShowImportDecl + ) where + +import Language.Haskell.Exts.Pretty as Hs +import Language.Haskell.Exts.Syntax as Hs + +import Agda2Hs.Language.Haskell.Utils ( pp ) + +-- | Custom implementation of 'prettyShow' for 'Hs.ImportDecl' +-- that supports type operators. +-- +-- Specifically, in the IThingAll and IThingWith import specs, +-- the "type" prefixes get before type operators if necessary. +-- See https://github.com/haskell-suite/haskell-src-exts/pull/475 +-- If this pull request gets merged, +-- this custom implementation will be unnecessary. +prettyShowImportDecl :: Hs.ImportDecl () -> String +prettyShowImportDecl (Hs.ImportDecl _ m qual src safe mbPkg mbName mbSpecs) = + unwords $ ("import" :) $ + (if src then ("{-# SOURCE #-}" :) else id) $ + (if safe then ("safe" :) else id) $ + (if qual then ("qualified" :) else id) $ + maybeAppend (\ str -> show str) mbPkg $ + (pp m :) $ + maybeAppend (\m' -> "as " ++ pp m') mbName $ + (case mbSpecs of {Just specs -> [prettyShowSpecList specs]; Nothing -> []}) + where + maybeAppend :: (a -> String) -> Maybe a -> ([String] -> [String]) + maybeAppend f (Just a) = (f a :) + maybeAppend _ Nothing = id + + prettyShowSpecList :: Hs.ImportSpecList () -> String + prettyShowSpecList (Hs.ImportSpecList _ b ispecs) = + (if b then "hiding " else "") + ++ parenList (map prettyShowSpec ispecs) + + parenList :: [String] -> String + parenList [] = "()" + parenList (x:xs) = '(' : (x ++ go xs) + where + go :: [String] -> String + go [] = ")" + go (x:xs) = ", " ++ x ++ go xs + + -- this is why we have rewritten it + prettyShowSpec :: Hs.ImportSpec () -> String + prettyShowSpec (Hs.IVar _ name ) = pp name + prettyShowSpec (Hs.IAbs _ ns name) = let ppns = pp ns in case ppns of + [] -> pp name -- then we don't write a space before it + _ -> ppns ++ (' ' : pp name) + prettyShowSpec (Hs.IThingAll _ name) = let rest = pp name ++ "(..)" in + case name of + -- if it's a symbol, append a "type" prefix to the beginning + (Hs.Symbol _ _) -> pp (Hs.TypeNamespace ()) ++ (' ' : rest) + (Hs.Ident _ _) -> rest + prettyShowSpec (Hs.IThingWith _ name nameList) = let rest = pp name ++ (parenList . map pp $ nameList) in + case name of + (Hs.Symbol _ _) -> pp (Hs.TypeNamespace ()) ++ (' ' : rest) + (Hs.Ident _ _) -> rest diff --git a/src/Agda2Hs/Language/Haskell/Utils.hs b/src/Agda2Hs/Language/Haskell/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Agda2Hs/Language/Haskell/Utils.hs @@ -0,0 +1,321 @@ + +module Agda2Hs.Language.Haskell.Utils where + +import Control.Monad ( guard ) + +import Data.Data ( Data ) +import Data.Generics ( listify, everywhere, mkT, extT ) +import Data.List ( foldl' ) +import Data.Map ( Map ) + +import qualified Data.Map as Map + +import Language.Haskell.Exts hiding ( Strict, Lazy ) + +import Agda.Syntax.Position + +import Agda.Utils.FileName ( mkAbsolute ) +import Agda.Utils.List ( initLast ) +import Agda.Utils.Maybe.Strict ( toStrict ) +import System.FilePath (isAbsolute) +import Agda.Utils.Maybe (boolToMaybe) + +-- Names ------------------------------------------------------------------ + + +validVarId :: String -> Bool +validVarId s = case lexTokenStream s of + ParseOk [Loc _ VarId{}] -> True + _ -> False + +validConId :: String -> Bool +validConId s = case lexTokenStream s of + ParseOk [Loc _ ConId{}] -> True + _ -> False + +validVarSym :: String -> Bool +validVarSym s = case lexTokenStream s of + ParseOk [Loc _ VarSym{}] -> True + _ -> False + +validConSym :: String -> Bool +validConSym s = case lexTokenStream s of + ParseOk [Loc _ ConSym{}] -> True + _ -> False + +validVarName :: Name () -> Bool +validVarName (Ident _ s) = validVarId s +validVarName (Symbol _ s) = validVarSym s + +validTypeName :: Name () -> Bool +validTypeName (Ident _ s) = validConId s +validTypeName (Symbol _ s) = validVarSym s || validConSym s -- type operators need not start with a colon + +validConName :: Name () -> Bool +validConName (Ident _ s) = validConId s +validConName (Symbol _ s) = validConSym s + +isInfix :: String -> Maybe String +isInfix ('_' : f) = do + (op, '_') <- initLast f + guard $ not $ '_' `elem` op + return op +isInfix _ = Nothing + +hsName :: String -> Name () +hsName x + | Just op <- isInfix x = Symbol () op + | otherwise = Ident () (map underscore x) + where + -- Agda uses underscores for operators, which means that you can't have both mapM and mapM_ + -- without getting ambiguities. To work around this we translate subscript '-' to underscore. + underscore '₋' = '_' + underscore c = c + +extToName :: KnownExtension -> Name () +extToName = Ident () . show + +hsModuleName :: String -> ModuleName () +hsModuleName = ModuleName () + +isOp :: QName () -> Bool +isOp (UnQual _ Symbol{}) = True +isOp (Special _ Cons{}) = True +isOp _ = False + +isSpecial :: QName () -> Bool +isSpecial (Special _ _) = True +isSpecial _ = False + +unQual :: QName () -> Name () +unQual (UnQual _ n) = n +unQual (Qual _ _ n) = n +unQual (Special _ _) = error "Unexpected special con" + +definedName :: Match l -> Name l +definedName (Match _ f _ _ _) = f +definedName (InfixMatch _ _ f _ _ _) = f + +replaceName :: Data a => Name () -> Name () -> a -> a +replaceName pre post = everywhere (mkT go `extT` go') + where + go :: QName () -> QName () + go n | isSpecial n = n + | unQual n == pre = UnQual () post + | otherwise = n + + go' :: Match () -> Match () + go' m = case m of + (Match () n ps rhs bs) -> Match () (f n) ps rhs bs + (InfixMatch () p n ps rhs bs) -> InfixMatch () p (f n) ps rhs bs + where f n | n == pre = post + | otherwise = n + +dropPatterns :: Data a => Int -> a -> a +dropPatterns n = everywhere (mkT go) + where + go :: Match () -> Match () + go (Match () f ps rhs bs) = Match () f (drop n ps) rhs bs + go m = m + + +-- Utilities for building Haskell constructs + +pp :: Pretty a => a -> String +pp = prettyPrintWithMode defaultMode{ spacing = False + , classIndent = 4 + , whereIndent = 2 + } + + +-- exactPrint really looks at the line numbers (and we're using the locations from the agda source +-- to report Haskell parse errors at the right location), so shift everything to start at line 1. +moveToTop :: Annotated ast => (ast SrcSpanInfo, [Comment]) -> (ast SrcSpanInfo, [Comment]) +moveToTop (x, cs) = (subtractLine l <$> x, [ Comment b (sub l r) str | Comment b r str <- cs ]) + where l = startLine (ann x) - 1 + subtractLine :: Int -> SrcSpanInfo -> SrcSpanInfo + subtractLine l (SrcSpanInfo s ss) = SrcSpanInfo (sub l s) (map (sub l) ss) + + sub :: Int -> SrcSpan -> SrcSpan + sub l (SrcSpan f l0 c0 l1 c1) = SrcSpan f (l0 - l) c0 (l1 - l) c1 + +getList :: Exp () -> Maybe [Exp ()] +getList (Con _ (Special _ ListCon{})) = Just [] +getList (List _ es) = Just es +getList _ = Nothing + +getListP :: Pat () -> Maybe [Pat ()] +getListP (PApp _ (Special _ ListCon{}) []) = Just [] +getListP (PList _ es) = Just es +getListP _ = Nothing + +pApp :: QName () -> [Pat ()] -> Pat () +pApp c@(UnQual () (Symbol () _)) [p, q] = PInfixApp () p c q +pApp (Special _ Cons{}) [p, q] | Just ps <- getListP q = PList () (p : ps) +pApp c@(Special () Cons{}) [p, q] = PInfixApp () p c q +pApp c ps = PApp () c ps + +getOp :: Exp () -> Maybe (QOp ()) +getOp (Var _ x) | isOp x = Just $ QVarOp () x +getOp (Con _ c) | isOp c = Just $ QConOp () c +getOp _ = Nothing + +eApp :: Exp () -> [Exp ()] -> Exp () +eApp f [a, b] | Just (QConOp () (Special _ Cons{})) <- getOp f, + Just as <- getList b = List () (a : as) +eApp f (a : b : as) | Just op <- getOp f = foldl (App ()) (InfixApp () a op b) as +eApp f [a] | Just op <- getOp f = LeftSection () a op +eApp f es = foldl (App ()) f es + +tApp :: Type () -> [Type ()] -> Type () +tApp (TyCon () (Special () ListCon{})) [a] = TyList () a +tApp t vs = foldl (TyApp ()) t vs + +hsLambda :: String -> Exp () -> Exp () +hsLambda x e = + case e of + Lambda l ps b -> Lambda l (p : ps) b + _ -> Lambda () [p] e + where + p = PVar () $ hsName x + +hsUnqualName :: String -> QName () +hsUnqualName = UnQual () . hsName + +hsVar :: String -> Exp () +hsVar = Var () . hsUnqualName + +hsUndefined :: Exp () +hsUndefined = hsVar "undefined" + +hsError :: String -> Exp () +hsError s = hsVar "error" `eApp` [strE s] + +cname :: CName l -> Name l +cname (VarName _ n) = n +cname (ConName _ n) = n + +cloc :: CName l -> l +cloc (VarName l _) = l +cloc (ConName l _) = l + +srcSpanToRange :: SrcSpan -> Range +srcSpanToRange (SrcSpan file l1 c1 l2 c2) = + intervalToRange (toStrict $ boolToMaybe (isAbsolute file) $ mkRangeFile (mkAbsolute file) Nothing) $ Interval () (pos l1 c1) (pos l2 c2) + where pos l c = Pn () 0 (fromIntegral l) (fromIntegral c) + +srcLocToRange :: SrcLoc -> Range +srcLocToRange (SrcLoc file l c) = srcSpanToRange (SrcSpan file l c l c) + +srcSpanInfoToRange :: SrcSpanInfo -> Range +srcSpanInfoToRange = srcSpanToRange . srcInfoSpan + +allUsedTypes :: Data a => a -> [Type ()] +allUsedTypes = listify (const True) + +usedTypesOf :: Data a => String -> a -> [Type ()] +usedTypesOf s = listify $ (== s) . pp + +uses :: Data a => String -> a -> Bool +uses ty = not . null . usedTypesOf ty + +-- Fixities + +-- Ideally, our pretty-printing library should insert parenthesis where needed. +-- However, hs-src-exts does not insert adequate parenthesis for infix +-- operators so we need to insert some by hand (see issues #54 and #273 and #317). + +-- | Properly parenthesize an expression with regards to the default fixities. +insertParens :: Data a => a -> a +insertParens = everywhere (mkT $ insertPars $ fixityMap baseFixities) + where + fixityMap fxs = Map.fromList [ (q, fx) | fx@(Fixity _ _ q) <- fxs ] + +-- | Given fixities of operators, properly parenthesize an expression. +insertPars :: Map (QName ()) Fixity -> Exp () -> Exp () +insertPars fixs = \case + (InfixApp l e1 op e2) -> InfixApp l (parL op e1) op (parR op e2) + (LeftSection l e1 op) -> LeftSection l (parL op e1) op + (RightSection l op e2) -> RightSection l op (parR op e2) + e -> e + where + getFix op = Map.lookup (qopName op) fixs + + qopName (QVarOp _ x) = x + qopName (QConOp _ x) = x + + needParen same (Just (Fixity atop top _)) (Just (Fixity achild child _)) + | top > child = True + | top < child = False + | atop /= achild = True + | otherwise = same atop + needParen _ Nothing _ = True -- If we don't know, add parens + needParen _ _ Nothing = True + + needParenExpr (InfixApp _ _ _ e2) = needParenExpr e2 + needParenExpr Lambda{} = True + needParenExpr _ = False + + parL topOp e = + if needParenExpr e + then mkParen e + else par topOp (needParen (AssocLeft () /=)) e + parR topOp = par topOp (needParen (AssocRight () /=)) + + par topOp need e@(InfixApp _ _ op _) + | need (getFix topOp) (getFix op) = mkParen e + par _ _ e = e + +mkParen :: Exp () -> Exp () +mkParen e@Paren{} = e +mkParen e = Paren () e + + +-- Patterns +patToExp :: Pat l -> Maybe (Exp l) +patToExp = \case + PVar l x -> Just $ Var l (UnQual l x) + PLit l s v -> Just $ Lit l v + PInfixApp l p f q -> InfixApp l <$> patToExp p <*> pure (QConOp l f) <*> patToExp q + PApp l x ps -> foldl' (App l) (Con l x) <$> traverse patToExp ps + PTuple l b ps -> Tuple l b <$> traverse patToExp ps + PUnboxedSum l i j p -> UnboxedSum l i j <$> patToExp p + PList l ps -> List l <$> traverse patToExp ps + PParen l p -> Paren l <$> patToExp p + PAsPat _ _ p -> patToExp p + PIrrPat _ p -> patToExp p + PatTypeSig _ p _ -> patToExp p + PBangPat _ p -> patToExp p + _ -> Nothing + + +data Strictness = Lazy | Strict + deriving (Eq, Show) + + +-- | Add a class constraint to a Haskell type. +constrainType + :: Asst () -- ^ The class assertion. + -> Type () -- ^ The type to constrain. + -> Type () +constrainType c = \case + TyForall _ as (Just (CxTuple _ cs)) t -> TyForall () as (Just (CxTuple () (c:cs))) t + TyForall _ as (Just (CxSingle _ c')) t -> TyForall () as (Just (CxTuple () [c,c'])) t + TyForall _ as Nothing t -> TyForall () as (Just (CxSingle () c )) t + t -> TyForall () Nothing (Just (CxSingle () c )) t + + +-- | Add explicit quantification over a variable to a Haskell type. +qualifyType + :: TyVarBind () -- ^ Name of the variable. + -> Type () -- ^ Type to quantify. + -> Type () +qualifyType a = \case + TyForall _ (Just as) cs t -> TyForall () (Just (a:as)) cs t + TyForall _ Nothing cs t -> TyForall () (Just [a] ) cs t + t -> TyForall () (Just [a] ) Nothing t + +isQuantifiedAsst :: Asst () -> Bool +isQuantifiedAsst (TypeA _ TyForall{}) = True +isQuantifiedAsst (IParam _ _ TyForall{}) = True +isQuantifiedAsst _ = False diff --git a/src/Agda2Hs/Pragma.hs b/src/Agda2Hs/Pragma.hs --- a/src/Agda2Hs/Pragma.hs +++ b/src/Agda2Hs/Pragma.hs @@ -3,23 +3,23 @@ import Data.List ( isPrefixOf ) import Data.Maybe ( fromMaybe ) import qualified Data.Map as Map - -import qualified Language.Haskell.Exts.Syntax as Hs -import qualified Language.Haskell.Exts.Parser as Hs -import qualified Language.Haskell.Exts.Extension as Hs +import qualified Data.Text as Text import Agda.Compiler.Backend import Agda.Compiler.Common ( curIF ) import Agda.Syntax.Position +import Agda.TypeChecking.Pretty (text) import Agda.Utils.FileName ( filePath ) import Agda.Utils.Maybe.Strict ( toLazy ) -import Agda2Hs.HsUtils import Agda2Hs.Compile.Types -pragmaName :: String +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils ( Strictness(..), srcLocToRange ) + +pragmaName :: Text.Text pragmaName = "AGDA2HS" languagePragmas :: Code -> [Hs.Extension] @@ -43,7 +43,7 @@ Just l -> "{-# LINE " ++ show l ++ show file ++ " #-}\n" Nothing -> "" case Hs.parseWithComments pmode (line ++ code) of - Hs.ParseFailed loc msg -> setCurrentRange (srcLocToRange loc) $ genericError msg + Hs.ParseFailed loc msg -> setCurrentRange (srcLocToRange loc) $ typeError <$> CustomBackendError "agda2hs" =<< text msg Hs.ParseOk m -> ((r, m) :) <$> getCode (exts ++ languagePragmas m) pragmas data ParsedPragma @@ -77,7 +77,7 @@ -- dummy datatype and then only keeping the deriving part case Hs.parseDecl ("data X = X " ++ d) of Hs.ParseFailed loc msg -> do - setCurrentRange r $ genericError msg + setCurrentRange r $ typeError <$> CustomBackendError "agda2hs" =<< text msg Hs.ParseOk (Hs.DataDecl _ _ _ _ _ ds) -> return $ pragma (map (() <$) ds) Hs.ParseOk _ -> return $ pragma [] diff --git a/src/Agda2Hs/Render.hs b/src/Agda2Hs/Render.hs --- a/src/Agda2Hs/Render.hs +++ b/src/Agda2Hs/Render.hs @@ -9,17 +9,10 @@ import Data.Set ( Set ) import qualified Data.Set as Set -import System.FilePath ( takeDirectory, () ) +import System.FilePath ( takeDirectory ) import System.Directory ( createDirectoryIfMissing ) -import qualified Language.Haskell.Exts.SrcLoc as Hs -import qualified Language.Haskell.Exts.Syntax as Hs -import qualified Language.Haskell.Exts.Build as Hs -import qualified Language.Haskell.Exts.ExactPrint as Hs -import qualified Language.Haskell.Exts.Extension as Hs - import Agda.Compiler.Backend -import Agda.Compiler.Common ( compileDir ) import Agda.TypeChecking.Pretty import qualified Agda.Syntax.Concrete.Name as C @@ -32,12 +25,12 @@ import Agda2Hs.Compile import Agda2Hs.Compile.Types import Agda2Hs.Compile.Imports -import Agda2Hs.Compile.Utils ( primModules ) -import Agda2Hs.HsUtils +import Agda2Hs.Compile.Utils ( primModules, moduleFileName ) +import qualified Agda2Hs.Language.Haskell as Hs +import Agda2Hs.Language.Haskell.Utils + ( extToName, pp, moveToTop, insertParens ) import Agda2Hs.Pragma ( getForeignPragmas ) -import Language.Haskell.Exts as Hs (prettyPrint, prelude_mod) - -- Rendering -------------------------------------------------------------- type Block = Ranged [String] @@ -71,62 +64,30 @@ -- Generating the files ------------------------------------------------------- -moduleFileName :: Options -> TopLevelModuleName -> TCM FilePath -moduleFileName opts name = do - outDir <- compileDir - return $ fromMaybe outDir (optOutDir opts) moduleNameToFileName name "hs" - - ensureDirectory :: FilePath -> IO () ensureDirectory = createDirectoryIfMissing True . takeDirectory --- We have to rewrite this so that in the IThingAll and IThingWith import specs, --- the "type" prefixes get before type operators if necessary. --- But see haskell-src-exts, PR #475. If it gets merged, this will be unnecessary. -prettyShowImportDecl :: Hs.ImportDecl () -> String -prettyShowImportDecl (Hs.ImportDecl _ m qual src safe mbPkg mbName mbSpecs) = - unwords $ ("import" :) $ - (if src then ("{-# SOURCE #-}" :) else id) $ - (if safe then ("safe" :) else id) $ - (if qual then ("qualified" :) else id) $ - maybeAppend (\ str -> show str) mbPkg $ - (pp m :) $ - maybeAppend (\m' -> "as " ++ pp m') mbName $ - (case mbSpecs of {Just specs -> [prettyShowSpecList specs]; Nothing -> []}) - where - maybeAppend :: (a -> String) -> Maybe a -> ([String] -> [String]) - maybeAppend f (Just a) = (f a :) - maybeAppend _ Nothing = id - - prettyShowSpecList :: Hs.ImportSpecList () -> String - prettyShowSpecList (Hs.ImportSpecList _ b ispecs) = - (if b then "hiding " else "") - ++ parenList (map prettyShowSpec ispecs) - - parenList :: [String] -> String - parenList [] = "" - parenList (x:xs) = '(' : (x ++ go xs) - where - go :: [String] -> String - go [] = ")" - go (x:xs) = ", " ++ x ++ go xs +-- | Compile the full import list, +-- with special handling for the @Prelude@ as prescribed by 'Options'. +compileImportsWithPrelude + :: Options -> String -> Imports -> TCM [Hs.ImportDecl ()] +compileImportsWithPrelude opts mod imps = do + -- if the prelude is supposed to be implicit, + -- or the prelude imports have been fixed in the config file, + -- we remove it from the list of imports + let filteredImps = + if not preludeImplicit && isNothing preludeImports + then imps + else filter ((/= Hs.prelude_mod ()) . importModule) imps - -- this is why we have rewritten it - prettyShowSpec :: Hs.ImportSpec () -> String - prettyShowSpec (Hs.IVar _ name ) = pp name - prettyShowSpec (Hs.IAbs _ ns name) = let ppns = pp ns in case ppns of - [] -> pp name -- then we don't write a space before it - _ -> ppns ++ (' ' : pp name) - prettyShowSpec (Hs.IThingAll _ name) = let rest = pp name ++ "(..)" in - case name of - -- if it's a symbol, append a "type" prefix to the beginning - (Hs.Symbol _ _) -> pp (Hs.TypeNamespace ()) ++ (' ' : rest) - (Hs.Ident _ _) -> rest - prettyShowSpec (Hs.IThingWith _ name nameList) = let rest = pp name ++ (parenList . map pp $ nameList) in - case name of - (Hs.Symbol _ _) -> pp (Hs.TypeNamespace ()) ++ (' ' : rest) - (Hs.Ident _ _) -> rest + -- then we try to add it back + if (not preludeImplicit && isNothing preludeImports) || null preludeHiding + then compileImports mod filteredImps + else (preludeImportDecl preOpts:) <$> compileImports mod filteredImps + where + preOpts@PreludeOpts{..} = optPrelude opts +-- | Render the @.hs@ module as a 'String' and write it to a file. writeModule :: Options -> ModuleEnv -> IsMain -> TopLevelModuleName -> [(CompiledDef, CompileOutput)] -> TCM ModuleRes writeModule opts _ isMain m outs = do @@ -142,24 +103,8 @@ let unlines' [] = [] unlines' ss = unlines ss ++ "\n" - let preOpts@PreludeOpts{..} = optPrelude opts - - -- if the prelude is supposed to be implicit, - -- or the prelude imports have been fixed in the config file, - -- we remove it from the list of imports - let filteredImps = - if not preludeImplicit && isNothing preludeImports - then imps - else filter ((/= Hs.prelude_mod ()) . importModule) imps - - -- then we try to add it back - let autoImportList = - if (not preludeImplicit && isNothing preludeImports) || null preludeHiding - then compileImports mod filteredImps - else (preludeImportDecl preOpts:) <$> compileImports mod filteredImps - - -- Add automatic imports - autoImports <- (unlines' . map prettyShowImportDecl) <$> autoImportList + autoImports <- unlines' . map Hs.prettyShowImportDecl + <$> compileImportsWithPrelude opts mod imps -- The comments make it hard to generate and pretty print a full module hsFile <- moduleFileName opts m diff --git a/src/AgdaInternals.hs b/src/AgdaInternals.hs --- a/src/AgdaInternals.hs +++ b/src/AgdaInternals.hs @@ -38,15 +38,6 @@ applySubst rhoP d@Defn{..} = d {defType = applyPatSubst rhoP defType, theDef = applySubst rhoP theDef} -instance (Monoid r, MonadFresh i m) => MonadFresh i (WriterT r m) -instance (Monoid r, MonadInteractionPoints m) => MonadInteractionPoints (WriterT r m) -instance (Monoid r, MonadStConcreteNames m) => MonadStConcreteNames (WriterT r m) where - --runStConcreteNames :: StateT ConcreteNames (WriterT r m) a -> WriterT r m a - runStConcreteNames m = WriterT $ runStConcreteNames $ StateT $ \s -> do - ((x,s'),ns) <- runWriterT $ runStateT m s - return ((x,ns),s') -instance (Monoid r, Monad m, IsString (m a)) => IsString (WriterT r m a) where - fromString s = WriterT $ fmap (,mempty) $ fromString s instance (Monoid r, MonadBlock m) => MonadBlock (WriterT r m) where catchPatternErr h m = WriterT $ catchPatternErr (runWriterT . h) (runWriterT m) instance MonadBlock m => MonadBlock (StateT s m) where diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,26 +1,25 @@ module Main where import Data.Maybe ( fromMaybe ) +import qualified Data.Text as Text import Data.Version ( showVersion ) import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import System.Console.GetOpt import System.Environment ( getArgs ) -import qualified Language.Haskell.Exts.Syntax as Hs -import qualified Language.Haskell.Exts.Build as Hs -import qualified Language.Haskell.Exts.Parser as Hs -import qualified Language.Haskell.Exts.Extension as Hs - import Agda.Main import Agda.Compiler.Backend +import Agda.Utils.GetOpt +import Agda2Hs.AgdaUtils import Agda2Hs.Compile.Name ( defaultSpecialRules ) import Agda2Hs.Compile import Agda2Hs.Config ( checkConfig ) import Agda2Hs.Compile.Types import Agda2Hs.Render +import qualified Agda2Hs.Language.Haskell as Hs + import Paths_agda2hs ( version, getDataFileName ) @@ -53,7 +52,7 @@ backend :: Backend' Options Options ModuleEnv ModuleRes (CompiledDef, CompileOutput) backend = Backend' { backendName = "agda2hs" - , backendVersion = Just (showVersion version) + , backendVersion = Just $ Text.pack $ showVersion version , options = defaultOptions , commandLineFlags = [ Option ['d'] ["disable-backend"] (NoArg disableOpt) @@ -75,15 +74,18 @@ , compileDef = compile , scopeCheckingSuffices = False , mayEraseType = \ _ -> return True + , backendInteractTop = Nothing + , backendInteractHole = Nothing } where verifyAndWriteModule opts env isM m out = verifyOutput opts env isM m out >> writeModule opts env isM m out --- | Parse command-line arguments to check whether we are in interactive mode. -isInteractive :: IO Bool -isInteractive = do +-- | Parse command-line arguments to check whether we are in interactive mode +-- or the user is just requesting information. +shouldDisable :: IO Bool +shouldDisable = do let interactionFlag = Option ['I'] ["interactive", "interaction", "interaction-json"] (NoArg ()) "" - (i , _ , _) <- getOpt Permute [interactionFlag] <$> getArgs + (i , _ , _) <- getOpt Permute (interactionFlag:infoFlags) <$> getArgs return $ not $ null i main = do @@ -91,11 +93,9 @@ -- Issue #370: `agda2hs locate` will print out the path to the prelude agda-lib file if args == ["locate"] then - putStrLn =<< getDataFileName "agda2hs.agda-lib" + putStrLn =<< getDataFileName "lib/base/base.agda-lib" else do -- Issue #201: disable backend when run in interactive mode - isInt <- isInteractive + disable <- shouldDisable - if isInt - then runAgda [Backend backend{isEnabled = const False}] - else runAgda [Backend backend] + runAgda [Backend backend{isEnabled = const $ not disable }]