packages feed

agda2hs 1.2 → 1.3

raw patch · 111 files changed

+7324/−970 lines, 111 filesdep +monad-controldep +transformersdep ~Agdadep ~aesondep ~base

Dependencies added: monad-control, transformers

Dependency ranges changed: Agda, aeson, base, mtl

Files

CHANGELOG.md view
@@ -1,22 +1,36 @@-Release notes for agda2hs v1.2+Release notes for agda2hs v1.3 ==============================  Changes ------- -- Increased bounds to support GHC 9.6.3-- Changed flag `--rewrite-rules` to `--config`.-- Deprecated `Tuple` (#228). Now there are distinct 2-uples (`_×_`) and 3-uples (`_×_×_`).-  Only 2-uples can be pattern-matched inside of let bindings.-- Experimental support for *erased module parameters* (#229).-- Support for erased hidden type parameters.-- Functions with no clause throw a hard error when getting compiled.-- Unboxed records can preserve any field -- not only the first one.-- Improved documentation.+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 -See https://github.com/agda/agda2hs/issues?q=milestone%3A1.2+is%3Apr for the full list of changes.+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 +See https://github.com/agda/agda2hs/issues?q=milestone%3A1.3+is%3Apr for the full list of changes.+ Fixed issues ------------ -See https://github.com/agda/agda2hs/issues?q=milestone%3A1.2+is%3Aissue for the full list of fixed issues.+See https://github.com/agda/agda2hs/issues?q=milestone%3A1.3+is%3Aissue for the full list of fixed issues.
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2023 Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, and Henry Blanchette.+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.  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:
README.md view
@@ -2,40 +2,14 @@  # agda2hs -Agda2hs is a tool for producing verified and readable Haskell code by-extracting it from a (lightly annotated) Agda program. For example,-the following Agda program encodes well-formed binary search trees:--```agda-open import Haskell.Prelude--_≤_ : {{Ord a}} → a → a → Set-x ≤ y = (x <= y) ≡ True--data BST (a : Set) {{@0 _ : Ord a}} (@0 lower upper : a) : Set where-  Leaf : (@0 pf : lower ≤ upper) → BST a lower upper-  Node : (x : a) (l : BST a lower x) (r : BST a x upper) → BST a lower upper--{-# COMPILE AGDA2HS BST #-}-```--agda2hs translates this to the following Haskell datatype:--```haskell-module BST where--data BST a = Leaf-           | Node a (BST a) (BST a)-```--## Objective--The goal of this project is *not* to translate arbitrary Agda code to Haskell.-Rather it is to carve out a common sublanguage between Agda and Haskell,-with a straightforward translation from the Agda side to the Haskell side.-This lets you write your program in the Agda fragment, using full Agda-to prove properties about it, and then translate it to nice looking readable-Haskell code that you can show your Haskell colleagues without shame.+Agda2hs is a tool for producing verified and readable Haskell code by extracting+it from a (lightly annotated) Agda program. The goal of this project is *not* to+translate arbitrary Agda code to Haskell. Rather it is to carve out a common+sublanguage between Agda and Haskell, with a straightforward translation from+the Agda side to the Haskell side. This lets you write your program in the Agda+fragment, using full Agda to prove properties about it, and then translate it to+nice looking readable Haskell code that you can show your Haskell colleagues+without shame.  ## Documentation
+ agda2hs.agda-lib view
@@ -0,0 +1,4 @@+name: agda2hs+depend:+include: lib+flags: -W noUnsupportedIndexedMatch --erasure
agda2hs.cabal view
@@ -1,11 +1,11 @@-cabal-version:       2.2+cabal-version:       2.4 name:                agda2hs-version:             1.2+version:             1.3 license:             BSD-3-Clause license-file:        LICENSE-author:              Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette+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 maintainer:          jesper@sikanda.be-copyright:           2023 Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette+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 category:            Language, Compiler build-type:          Simple synopsis:            Compiling Agda code to readable Haskell.@@ -18,6 +18,9 @@ extra-doc-files:    CHANGELOG.md                     README.md +data-files: agda2hs.agda-lib+            lib/**/*.agda+ source-repository head   type:     git   location: https://github.com/agda/agda2hs.git@@ -39,6 +42,7 @@                        Agda2Hs.Compile.TypeDefinition,                        Agda2Hs.Compile.Types,                        Agda2Hs.Compile.Utils,+                       Agda2Hs.Compile.Var,                        Agda2Hs.Config,                        Agda2Hs.HsUtils,                        Agda2Hs.Pragma,@@ -46,20 +50,23 @@                        AgdaInternals,                        Paths_agda2hs   autogen-modules:     Paths_agda2hs-  build-depends:       base >= 4.10 && < 4.20,-                       Agda >= 2.6.4 && < 2.6.5,-                       bytestring >= 0.11.5 && < 0.13,-                       containers >= 0.6 && < 0.8,-                       unordered-containers >= 0.2.19 && < 0.3,-                       mtl >= 2.2.2 && < 2.4,-                       directory >= 1.2.6.2 && < 1.4,-                       filepath >= 1.4.1.0 && < 1.5,-                       haskell-src-exts >= 1.23 && < 1.25,-                       syb >= 0.7.2 && < 0.8,-                       text >= 2.0.2 && < 2.2,-                       deepseq >= 1.4.4 && < 1.6,-                       yaml >= 0.11 && < 0.12,-                       aeson >= 2.2 && < 2.3,+  build-depends:       base                 >= 4.13    && < 4.21,+                       Agda                 >= 2.7.0   && < 2.8.0,+                       bytestring           >= 0.11.5  && < 0.13,+                       containers           >= 0.6     && < 0.8,+                       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,+                       haskell-src-exts     >= 1.23    && < 1.25,+                       syb                  >= 0.7.2   && < 0.8,+                       text                 >= 2.0.2   && < 2.2,+                       deepseq              >= 1.4.4   && < 1.6,+                       yaml                 >= 0.11    && < 0.12,+                       aeson                >= 2.0.3   && < 2.3,   default-language:    Haskell2010   default-extensions:  LambdaCase                        RecordWildCards@@ -67,3 +74,8 @@                        MultiWayIf                        TupleSections                        ScopedTypeVariables+                       ViewPatterns+                       NamedFieldPuns+                       PatternSynonyms+                       NondecreasingIndentation+  ghc-options:         -rtsopts
+ lib/Haskell/Control/Monad.agda view
@@ -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"
+ lib/Haskell/Extra/Dec.agda view
@@ -0,0 +1,48 @@+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 #-}
+ lib/Haskell/Extra/Delay.agda view
@@ -0,0 +1,39 @@+{-# 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
+ lib/Haskell/Extra/Erase.agda view
@@ -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 : 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)
+ lib/Haskell/Extra/Loop.agda view
@@ -0,0 +1,26 @@++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 #-}
+ lib/Haskell/Extra/Refinement.agda view
@@ -0,0 +1,28 @@+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 #-}
+ lib/Haskell/Extra/Sigma.agda view
@@ -0,0 +1,17 @@+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
+ lib/Haskell/Law.agda view
@@ -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
+ lib/Haskell/Law/Applicative.agda view
@@ -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
+ lib/Haskell/Law/Applicative/Def.agda view
@@ -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 : 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 ×_)
+ lib/Haskell/Law/Applicative/Either.agda view
@@ -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 }
+ lib/Haskell/Law/Applicative/IO.agda view
@@ -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
+ lib/Haskell/Law/Applicative/List.agda view
@@ -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 : 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
+ lib/Haskell/Law/Applicative/Maybe.agda view
@@ -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 }
+ lib/Haskell/Law/Bool.agda view
@@ -0,0 +1,86 @@+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
+ lib/Haskell/Law/Def.agda view
@@ -0,0 +1,6 @@+module Haskell.Law.Def where++open import Haskell.Prim++Injective : (a → b) → Set _+Injective f = ∀ {x y} → f x ≡ f y → x ≡ y
+ lib/Haskell/Law/Either.agda view
@@ -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
+ lib/Haskell/Law/Eq.agda view
@@ -0,0 +1,4 @@+module Haskell.Law.Eq where++open import Haskell.Law.Eq.Def       public+open import Haskell.Law.Eq.Instances public
+ lib/Haskell/Law/Eq/Def.agda view
@@ -0,0 +1,68 @@+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+
+ lib/Haskell/Law/Eq/Instances.agda view
@@ -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
+ lib/Haskell/Law/Equality.agda view
@@ -0,0 +1,67 @@+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 #-}
+ lib/Haskell/Law/Function.agda view
@@ -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 : 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)             ∎
+ lib/Haskell/Law/Functor.agda view
@@ -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
+ lib/Haskell/Law/Functor/Def.agda view
@@ -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 : 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 ×_)
+ lib/Haskell/Law/Functor/Either.agda view
@@ -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 }
+ lib/Haskell/Law/Functor/IO.agda view
@@ -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
+ lib/Haskell/Law/Functor/List.agda view
@@ -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
+ lib/Haskell/Law/Functor/Maybe.agda view
@@ -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 }
+ lib/Haskell/Law/Int.agda view
@@ -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
+ lib/Haskell/Law/Integer.agda view
@@ -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
+ lib/Haskell/Law/List.agda view
@@ -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 : 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))
+ lib/Haskell/Law/Maybe.agda view
@@ -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
+ lib/Haskell/Law/Monad.agda view
@@ -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
+ lib/Haskell/Law/Monad/Def.agda view
@@ -0,0 +1,46 @@+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 ×_)
+ lib/Haskell/Law/Monad/Either.agda view
@@ -0,0 +1,34 @@+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+      }
+ lib/Haskell/Law/Monad/IO.agda view
@@ -0,0 +1,12 @@+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
+ lib/Haskell/Law/Monad/List.agda view
@@ -0,0 +1,48 @@+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+
+ lib/Haskell/Law/Monad/Maybe.agda view
@@ -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+  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+      }+
+ lib/Haskell/Law/Monoid.agda view
@@ -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
+ lib/Haskell/Law/Monoid/Def.agda view
@@ -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 : 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)+
+ lib/Haskell/Law/Monoid/List.agda view
@@ -0,0 +1,29 @@+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
+ lib/Haskell/Law/Monoid/Maybe.agda view
@@ -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
+ lib/Haskell/Law/Nat.agda view
@@ -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 → 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)
+ lib/Haskell/Law/Num.agda view
@@ -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
+ lib/Haskell/Law/Num/Def.agda view
@@ -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 : 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ᵃ ∎
+ lib/Haskell/Law/Num/Int.agda view
@@ -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
+ lib/Haskell/Law/Num/Integer.agda view
@@ -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
+ lib/Haskell/Law/Num/Nat.agda view
@@ -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
+ lib/Haskell/Law/Num/Word.agda view
@@ -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
+ lib/Haskell/Law/Ord.agda view
@@ -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
+ lib/Haskell/Law/Ord/Bool.agda view
@@ -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+
+ lib/Haskell/Law/Ord/Def.agda view
@@ -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 : 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)
+ lib/Haskell/Law/Ord/Maybe.agda view
@@ -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+
+ lib/Haskell/Law/Ord/Ordering.agda view
@@ -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+
+ lib/Haskell/Law/Semigroup/Def.agda view
@@ -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 : 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)+
+ lib/Haskell/Law/Semigroup/Either.agda view
@@ -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 }
+ lib/Haskell/Law/Semigroup/List.agda view
@@ -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
+ lib/Haskell/Law/Semigroup/Maybe.agda view
@@ -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
+ lib/Haskell/Prelude.agda view
@@ -0,0 +1,142 @@+{-# 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
+ lib/Haskell/Prim.agda view
@@ -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+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
+ lib/Haskell/Prim/Absurd.agda view
@@ -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
+ lib/Haskell/Prim/Applicative.agda view
@@ -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 : 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
+ lib/Haskell/Prim/Bool.agda view
@@ -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
+ lib/Haskell/Prim/Bounded.agda view
@@ -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 : 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
+ lib/Haskell/Prim/Char.agda view
@@ -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)
+ lib/Haskell/Prim/Double.agda view
@@ -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)
+ lib/Haskell/Prim/Either.agda view
@@ -0,0 +1,20 @@++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
+ lib/Haskell/Prim/Enum.agda view
@@ -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 ⦄ → 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)
+ lib/Haskell/Prim/Eq.agda view
@@ -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 : 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
+ lib/Haskell/Prim/Foldable.agda view
@@ -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 : 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}
+ lib/Haskell/Prim/Functor.agda view
@@ -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 : 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
+ lib/Haskell/Prim/IO.agda view
@@ -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} → 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 ⊤
+ lib/Haskell/Prim/Int.agda view
@@ -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 : 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
+ lib/Haskell/Prim/Integer.agda view
@@ -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 → Set+IsNonNegativeInteger (pos _)      = ⊤+IsNonNegativeInteger n@(negsuc _) =+  TypeError (primStringAppend (primShowInteger n) (" is negative"))
+ lib/Haskell/Prim/List.agda view
@@ -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 : 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
+ lib/Haskell/Prim/Maybe.agda view
@@ -0,0 +1,17 @@++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
+ lib/Haskell/Prim/Monad.agda view
@@ -0,0 +1,129 @@++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
+ lib/Haskell/Prim/Monoid.agda view
@@ -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 : 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 ._<>_ → _||_)}
+ lib/Haskell/Prim/Num.agda view
@@ -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 : 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 ._<>_ → _*_+ )}
+ lib/Haskell/Prim/Ord.agda view
@@ -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 : 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}
+ lib/Haskell/Prim/Show.agda view
@@ -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 : 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₃}
+ lib/Haskell/Prim/Strict.agda view
@@ -0,0 +1,12 @@++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 #-}
+ lib/Haskell/Prim/String.agda view
@@ -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
+ lib/Haskell/Prim/Thunk.agda view
@@ -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 → Set ℓ) (@0 i : Size) : Set ℓ where+  constructor delay+  coinductive+  field force : {@0 j : Size< i} → a j+open Thunk public++{-# COMPILE AGDA2HS Thunk unboxed #-}
+ lib/Haskell/Prim/Traversable.agda view
@@ -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 : 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
+ lib/Haskell/Prim/Tuple.agda view
@@ -0,0 +1,45 @@++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
+ lib/Haskell/Prim/Word.agda view
@@ -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)
src/Agda2Hs/AgdaUtils.hs view
@@ -3,7 +3,7 @@ import Data.Data import Data.Monoid ( Any(..) ) import qualified Data.Map as Map-import Data.Maybe ( fromMaybe )+import Data.Maybe ( fromMaybe, isJust )  import Agda.Compiler.Backend hiding ( Args ) @@ -20,7 +20,9 @@  import Agda.TypeChecking.Monad ( topLevelModuleName ) import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Sort import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope import Agda.TypeChecking.Reduce ( reduceDefCopy )  import Agda.Utils.Either ( isRight )@@ -120,3 +122,24 @@   reduceDefCopy f es >>= \case     NoReduction ()   -> onDef f es     YesReduction _ t -> onTerm t++-- | Check whether the given definition comes from a record module.+inRecordMod :: MonadTCM m => QName -> m Bool+inRecordMod = liftTCM . fmap isJust . isDatatypeModule . qnameModule+++-- | Check whether a pattern is forced.+isForcedPat :: DeBruijnPattern -> Bool+isForcedPat = \case+  VarP{}        -> False+  DotP{}        -> True+  ConP c cpi ps -> conPLazy cpi+  LitP{}        -> False+  ProjP{}       -> False+  IApplyP{}     -> False+  DefP{}        -> False++endsInSort :: (PureTCM m, MonadBlock m) => Type -> m Bool+endsInSort t = do+  TelV tel b <- telView t+  addContext tel $ ifIsSort b (\_ -> return True) (return False)
src/Agda2Hs/Compile.hs view
@@ -1,101 +1,137 @@ module Agda2Hs.Compile where -import Control.Monad.Reader ( ReaderT(runReaderT) )-import Control.Monad.Writer ( WriterT(runWriterT) )-import Control.Monad.State ( StateT, evalStateT, get )+import Control.Monad.Trans.RWS.CPS ( evalRWST )+import Control.Monad.State ( gets )+import Control.Arrow ((>>>))+import Data.Functor+import Data.List ( isPrefixOf, group, sort )  import qualified Data.Map as M  import Agda.Compiler.Backend+import Agda.Compiler.Common ( curIF ) import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName )+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Monad.Signature ( isInlineFun )+import Agda.Utils.Impossible+import Agda.Utils.List import Agda.Utils.Null-import Agda.Utils.Monad ( whenM )+import Agda.Utils.Monad ( whenM, anyM, when )  import qualified Language.Haskell.Exts.Extension as Hs  import Agda2Hs.Compile.ClassInstance ( compileInstance ) import Agda2Hs.Compile.Data ( compileData )-import Agda2Hs.Compile.Function ( compileFun, checkTransparentPragma )+import Agda2Hs.Compile.Function ( compileFun, checkTransparentPragma, checkInlinePragma ) import Agda2Hs.Compile.Postulate ( compilePostulate ) import Agda2Hs.Compile.Record ( compileRecord, checkUnboxPragma ) import Agda2Hs.Compile.Types-import Agda2Hs.Compile.Utils ( setCurrentRangeQ, tellExtension )+import Agda2Hs.Compile.Utils ( setCurrentRangeQ, tellExtension, primModules, isClassName ) import Agda2Hs.Pragma+import qualified Language.Haskell.Exts.Syntax as Hs+import qualified Language.Haskell.Exts.Pretty as Hs --- Needs a list of rewrite rules too.+ initCompileEnv :: TopLevelModuleName -> SpecialRules -> CompileEnv initCompileEnv tlm rewrites = CompileEnv-  { currModule = tlm-  , minRecordName = Nothing-  , locals = []+  { currModule        = tlm+  , minRecordName     = Nothing+  , isNestedInType    = False+  , locals            = []+  , compilingLocal    = False+  , whereModules      = []   , copatternsEnabled = False-  , checkVar = False-  , rewrites = rewrites+  , rewrites          = rewrites+  , writeImports      = True   }  initCompileState :: CompileState initCompileState = CompileState { lcaseUsed = 0 }  runC :: TopLevelModuleName -> SpecialRules -> C a -> TCM (a, CompileOutput)-runC tlm rewrites = runWriterT-     . flip runReaderT (initCompileEnv tlm rewrites)-     . flip evalStateT initCompileState+runC tlm rewrites c = evalRWST c (initCompileEnv tlm rewrites) initCompileState +moduleSetup :: Options -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile ModuleEnv ModuleRes)+moduleSetup _ _ m _ = 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+ -- Main compile function ------------------------ -compile :: Options -> ModuleEnv -> IsMain -> Definition ->-  TCM (CompiledDef, CompileOutput)-compile opts tlm _ def = withCurrentModule (qnameModule $ defName def) $ runC tlm (optRewrites opts) $-  compileAndTag <* postCompile+compile+  :: Options -> ModuleEnv -> IsMain -> Definition+  -> TCM (CompiledDef, CompileOutput)+compile opts tlm _ def =+  withCurrentModule (qnameModule qname)+    $ runC tlm (optRewrites opts)+    $ setCurrentRangeQ qname+    $ compileAndTag <* postCompile   where-    tag code = [(nameBindingSite $ qnameName $ defName def, code)]-    single x = [x]+    qname = defName def +    tag []   = []+    tag code = [(nameBindingSite $ qnameName qname, code)]+     compileAndTag :: C CompiledDef-    compileAndTag = processPragma (defName def) >>= \ p -> -      setCurrentRangeQ (defName def) $ do-        reportSDoc "agda2hs.compile" 5 $-          text "Compiling definition: " <+> prettyTCM (defName def)-        reportSDoc "agda2hs.compile" 45 $-          text "Pragma: " <+> text (show p)-        reportSDoc "agda2hs.compile" 45 $-          text "Compiling definition: " <+> pretty (theDef def)-        case (p , defInstance def , theDef def) of-          (NoPragma, _, _) ->-            return []-          (ExistingClassPragma, _, _) ->-            return [] -- No code generation, but affects how projections are compiled-          (UnboxPragma s, _, defn) ->-            checkUnboxPragma defn >> return [] -- also no code generation-          (TransparentPragma  , _, Function{}) ->-            checkTransparentPragma def >> return [] -- also no code generation-          (ClassPragma ms, _, Record{}) ->-            tag . single <$> compileRecord (ToClass ms) def-          (NewTypePragma ds, _, Record{}) ->-            tag . single <$> compileRecord (ToRecordNewType ds) def-          (NewTypePragma ds, _, Datatype{}) ->-            tag <$> compileData ToDataNewType ds def-          (DefaultPragma ds, _, Datatype{}) ->-            tag <$> compileData ToData ds def-          (DerivePragma s, Just _, _) ->-            tag . single <$> compileInstance (ToDerivation s) def-          (DefaultPragma _, Just _, Axiom{}) ->-            tag . single <$> compileInstance (ToDerivation Nothing) def-          (DefaultPragma _, Just _, _) ->-            tag . single <$> compileInstance ToDefinition def-          (DefaultPragma _, _, Axiom{}) ->-            tag <$> compilePostulate def-          (DefaultPragma _, _, Function{}) ->-            tag <$> compileFun True def-          (DefaultPragma ds, _, Record{}) ->-            tag . single <$> compileRecord (ToRecord ds) def-          _ ->-            genericDocError =<< do-            text "Don't know how to compile" <+> prettyTCM (defName def)+    compileAndTag = tag <$> do+      p <- processPragma qname +      reportSDoc "agda2hs.compile" 5  $ text "Compiling definition:" <+> prettyTCM qname+      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++      reportSDoc "agda2hs.compile" 15  $ text "Is instance?" <+> prettyTCM isInstance++      case (p , theDef def) of+        (NoPragma            , _         ) -> return []+        (ExistingClassPragma , _         ) -> return []+        (UnboxPragma s       , Record{}  ) -> [] <$ checkUnboxPragma def+        (TransparentPragma   , Function{}) -> [] <$ checkTransparentPragma def+        (InlinePragma        , Function{}) -> [] <$ checkInlinePragma def+        (TuplePragma b       , Record{}  ) -> return []++        (ClassPragma ms      , Record{}  ) -> pure <$> compileRecord (ToClass ms) def+        (NewTypePragma ds    , Record{}  ) -> pure <$> compileRecord (ToRecord True ds) def+        (NewTypePragma ds    , Datatype{}) -> compileData True ds def+        (DefaultPragma ds    , Datatype{}) -> compileData False ds def+        (DerivePragma s      , _         ) | isInstance -> pure <$> compileInstance (ToDerivation s) def+        (DefaultPragma _     , Axiom{}   ) | isInstance -> pure <$> compileInstance (ToDerivation Nothing) def+        (DefaultPragma _     , _         ) | isInstance -> pure <$> compileInstance ToDefinition def+        (DefaultPragma _     , Axiom{}   ) -> compilePostulate def+        (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)+     postCompile :: C ()-    postCompile =-      whenM ((> 0) . lcaseUsed <$> get) $-        tellExtension Hs.LambdaCase+    postCompile = whenM (gets $ lcaseUsed >>> (> 0)) $ tellExtension Hs.LambdaCase++verifyOutput ::+  Options -> ModuleEnv -> IsMain -> TopLevelModuleName+  -> [(CompiledDef, CompileOutput)] -> TCM Bool+verifyOutput _ _ _ m ls = do+  reportSDoc "agda2hs.compile" 5 $ text "Checking generated output before rendering: " <+> prettyTCM m+  ensureUniqueConstructors+  where+    ensureUniqueConstructors = do+      let allCons = do+            (r, _) <- ls+            (_, a) <- r+            Hs.DataDecl _ _ _ _ cons _ <- a+            Hs.QualConDecl _ _ _ con <- cons+            return $ case con of+              Hs.ConDecl _ n _ -> n+              Hs.InfixConDecl _ _ n _ -> n+              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)
src/Agda2Hs/Compile/ClassInstance.hs view
@@ -1,14 +1,14 @@ module Agda2Hs.Compile.ClassInstance where  import Control.Monad ( when, filterM, unless )-import Control.Monad.Reader ( local )+import Control.Monad.Reader ( asks, local )  import Data.Foldable ( toList ) import Data.List ( nub ) import Data.Maybe ( isNothing, mapMaybe ) import qualified Data.HashMap.Strict as HMap -import qualified Language.Haskell.Exts.Syntax as Hs+import qualified Language.Haskell.Exts as Hs import Language.Haskell.Exts.Extension as Hs  import Agda.Compiler.Backend@@ -18,16 +18,19 @@  import Agda.Syntax.Common hiding ( Ranged ) import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern ( patternToTerm ) import Agda.Syntax.Position ( noRange ) import Agda.Syntax.Scope.Base import Agda.Syntax.Scope.Monad ( resolveName ) import Agda.Syntax.Common.Pretty ( prettyShow )  import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Substitute ( Apply(applyE) )+import Agda.TypeChecking.Substitute ( Apply(applyE), absBody, absApp, apply ) import Agda.TypeChecking.Records+import Agda.TypeChecking.Telescope ( mustBePi, piApplyM )  import Agda.Utils.Lens+import Agda.Utils.Monad ( ifNotM ) import Agda.Utils.Impossible ( __IMPOSSIBLE__ )  import Agda2Hs.AgdaUtils@@ -38,63 +41,91 @@ import Agda2Hs.Compile.Utils import Agda2Hs.HsUtils + enableCopatterns :: C a -> C a enableCopatterns = local $ \e -> e { copatternsEnabled = True }  disableCopatterns :: C a -> C a disableCopatterns = local $ \e -> e { copatternsEnabled = False } -enableStrategies :: Maybe (Hs.DerivStrategy ()) -> C ()-enableStrategies Nothing = return ()-enableStrategies (Just s) = do++-- | Enable the approriate extensions for a given Haskell deriving strategy.+enableStrategy :: Maybe (Hs.DerivStrategy ()) -> C ()+enableStrategy Nothing = return ()+enableStrategy (Just s) = do   tellExtension Hs.DerivingStrategies-  enableStrategy s+  case s of+    Hs.DerivStock ()    -> return () -- is included in GHC+    Hs.DerivAnyclass () -> tellExtension Hs.DeriveAnyClass -- since 7.10.1+    Hs.DerivNewtype ()  -> tellExtension Hs.GeneralizedNewtypeDeriving -- since 6.8.1.+    Hs.DerivVia () t    -> tellExtension Hs.DerivingVia -- since 8.6.1 -enableStrategy :: Hs.DerivStrategy () -> C ()-enableStrategy (Hs.DerivStock ())    = return () -- is included in GHC-enableStrategy (Hs.DerivAnyclass ()) = tellExtension Hs.DeriveAnyClass -- since 7.10.1-enableStrategy (Hs.DerivNewtype ())  = tellExtension Hs.GeneralizedNewtypeDeriving -- since 6.8.1.-enableStrategy (Hs.DerivVia () t)    = tellExtension Hs.DerivingVia -- since 8.6.1  compileInstance :: InstanceTarget -> Definition -> C (Hs.Decl ())+ compileInstance (ToDerivation strategy) def@Defn{..} =   setCurrentRangeQ defName $ do+    reportSDoc "agda2hs.compile.instance" 13 $ +      text "compiling instance" <+> prettyTCM defName <+> text "to standalone deriving"     tellExtension Hs.StandaloneDeriving-    enableStrategies strategy+    enableStrategy strategy     ir <- compileInstRule [] (unEl defType)     return $ Hs.DerivDecl () strategy Nothing ir+ compileInstance ToDefinition def@Defn{..} =   enableCopatterns $ setCurrentRangeQ defName $ do+    reportSDoc "agda2hs.compile.instance" 13 $ +      text "compiling instance" <+> prettyTCM defName <+> text "to instance definition"     ir <- compileInstRule [] (unEl defType)     withFunctionLocals defName $ do-      (ds, rs) <- concatUnzip-              <$> mapM (compileInstanceClause (qnameModule defName)) funClauses-      when (length (nub rs) > 1) $-        genericDocError =<< fsep (pwords "More than one minimal record used.")-      return $ Hs.InstDecl () Nothing ir (Just ds)+      reportSDoc "agda2hs.compile.instance" 20 $ vcat $+        text "compileInstance clauses: " :+        map (nest 2 . prettyTCM) funClauses+      let mod = qnameModule defName+      reportSDoc "agda2hs.compile.instance" 25 $ text "compileInstance module: " <+> prettyTCM mod+      tel <- lookupSection mod+      addContext tel $ do+        liftTCM $ setModuleCheckpoint mod+        pars <- getContextArgs+        ty <- defType `piApplyM` pars+        let clauses = funClauses `apply` pars+        (ds, rs) <- concatUnzip+                <$> mapM (\c -> withClauseLocals mod c $ compileInstanceClause mod ty c) clauses+        reportSDoc "agda2hs.compile.instance" 20 $ vcat $+          text "compileInstance compiled clauses: " :+          map (nest 2 . text . pp) ds+        when (length (nub rs) > 1) $+          genericDocError =<< fsep (pwords "More than one minimal record used.")+        return $ Hs.InstDecl () Nothing ir (Just ds)     where Function{..} = theDef + compileInstRule :: [Hs.Asst ()] -> Term -> C (Hs.InstRule ())-compileInstRule cs ty = case unSpine1 ty of-  Def f es | Just args <- allApplyElims es -> do-    vs <- mapM (compileType . unArg) $ filter keepArg args-    f <- compileQName f-    return $-      Hs.IRule () Nothing (ctx cs) $ foldl (Hs.IHApp ()) (Hs.IHCon () f) (map pars vs)-    where ctx [] = Nothing-          ctx cs = Just (Hs.CxTuple () cs)-          -- put parens around anything except a var or a constant-          pars :: Hs.Type () -> Hs.Type ()-          pars t@(Hs.TyVar () _) = t-          pars t@(Hs.TyCon () _) = t-          pars t = Hs.TyParen () t-  Pi a b -> compileDom (absName b) a >>= \case-    DomDropped -> underAbstr a b (compileInstRule cs . unEl)-    DomConstraint hsA ->-      underAbstraction a b (compileInstRule (cs ++ [hsA]) . unEl)-    DomType _ t -> __IMPOSSIBLE__-  _ -> __IMPOSSIBLE__+compileInstRule cs ty = do+  reportSDoc "agda2hs.compile.instance" 20 $ text "compileInstRule" <+> prettyTCM ty+  case unSpine1 ty of+    Def f es | Just args <- allApplyElims es -> do+      fty <- defType <$> getConstInfo f+      vs <- compileTypeArgs fty args+      f <- compileQName f+      return $+        Hs.IRule () Nothing (ctx cs) $ foldl (Hs.IHApp ()) (Hs.IHCon () f) (map pars vs)+      where ctx [] = Nothing+            ctx cs = Just (Hs.CxTuple () cs)+            -- put parens around anything except a var or a constant+            pars :: Hs.Type () -> Hs.Type ()+            pars t@(Hs.TyVar () _) = t+            pars t@(Hs.TyCon () _) = t+            pars t = Hs.TyParen () t+    Pi a b -> compileDomType (absName b) a >>= \case+      DomDropped -> underAbstr a b (compileInstRule cs . unEl)+      DomConstraint hsA ->+        underAbstraction a b (compileInstRule (cs ++ [hsA]) . unEl)+      DomType _ t -> __IMPOSSIBLE__+      DomForall _ -> __IMPOSSIBLE__+    _ -> __IMPOSSIBLE__ + -- Plan: --  - ✓ Eta-expand if no copatterns (top-level) --  - ✓ drop default implementations and chase definitions of primitive methods in minimal records + *checks*@@ -105,6 +136,7 @@ --  - ✓ all primitives of the minimal are projected from the same dictionary --  - ✓ default implementation that get dropped are also projected from that same dictionary + etaExpandClause :: Clause -> C [Clause] etaExpandClause cl@Clause{clauseBody = Nothing} =   genericError "Instance definition with absurd pattern!"@@ -120,91 +152,155 @@       "Type class instances must be defined using copatterns (or top-level" ++       " records) and cannot be defined using helper functions.") -compileInstanceClause :: ModuleName -> Clause -> C ([Hs.InstDecl ()], [QName])-compileInstanceClause curModule c = withClauseLocals curModule c $ do-  -- abuse compileClause:-  -- 1. drop any patterns before record projection to suppress the instance arg-  -- 2. use record proj. as function name-  -- 3. process remaing patterns as usual -  -- TODO: check that the things we drop here are not doing any matching-  case dropWhile (isNothing . isProjP) (namedClausePats c) of-    [] ->-      concatUnzip <$> (mapM (compileInstanceClause curModule) =<< etaExpandClause c)-    p : ps -> do-      let c' = c {namedClausePats = ps}-          ProjP _ q = namedArg p+compileInstanceClause :: ModuleName -> Type -> Clause -> C ([Hs.InstDecl ()], [QName])+compileInstanceClause curModule ty c = ifNotM (keepClause c) (return ([], [])) $ do -      -- We want the actual field name, not the instance-opened projection.-      (q, _, _) <- origProjection q-      arg <- fieldArgInfo q+  let naps = namedClausePats c -      reportSDoc "agda2hs.compile.instance" 15 $-        text "Compiling instance clause for" <+> prettyTCM (Arg arg $ Def q [])+  -- there are no projection patterns: we need to eta-expand the clause+  if all (isNothing . isProjP) naps then do+    cs <- etaExpandClause c+    reportSDoc "agda2hs.compile.instance" 20 $ vcat $+      text "compileInstance expanded clauses: " :+      map (nest 2 . prettyTCM) cs+    concatUnzip <$> mapM (compileInstanceClause curModule ty) cs -      let uf = hsName $ prettyShow $ nameConcrete $ qnameName q+  -- otherwise we seek the first projection pattern+  else addContext (KeepNames $ clauseTel c) $+    compileInstanceClause' curModule ty naps c { clauseTel = EmptyTel } -      let-        (.~) :: QName -> QName -> Bool-        x .~ y = nameConcrete (qnameName x) == nameConcrete (qnameName y)+-- abuse compileClause:+-- 1. drop any patterns before record projection to suppress the instance arg+-- 2. use record proj. as function name+-- 3. process remaing patterns as usual+compileInstanceClause' :: ModuleName -> Type -> NAPs -> Clause -> C ([Hs.InstDecl ()], [QName])+compileInstanceClause' curModule ty [] c = __IMPOSSIBLE__+compileInstanceClause' curModule ty (p:ps) c -        resolveExtendedLambda :: QName -> C QName-        resolveExtendedLambda n | isExtendedLambdaName n = defName <$> getConstInfo n-                                | otherwise              = return n+  -- reached record projection+  | ProjP _ q <- namedArg p = do -        chaseDef :: QName -> C Definition-        chaseDef n = do-          d <- getConstInfo n-          let Function {..} = theDef d-          case funClauses of-            [ Clause {clauseBody = Just (Def n' [])} ] -> do-              chaseDef n'-            _ -> return d+    -- we put back the remaining patterns in the original clause +    let c' = c {namedClausePats = ps} -      if-        | isInstance arg, usableModality arg -> do-            unless (null ps) $ genericDocError =<< text "not allowed: explicitly giving superclass"-            body <- case clauseBody c' of-              Nothing -> genericDocError =<< text "not allowed: absurd clause for superclass"-              Just b  -> return b-            addContext (clauseTel c') $ checkInstance body-            return ([], [])-        | not (keepArg arg) -> return ([], [])-        -- Projection of a primitive field: chase down definition and inline as instance clause.-        | Clause {namedClausePats = [], clauseBody = Just (Def n es)} <- c'-        , [(_, f)] <- mapMaybe isProjElim es-        , f .~ q -> do-          reportSDoc "agda2hs.compile.instance" 20 $-            text "Instance clause is projected from" <+> prettyTCM (Def n [])-          reportSDoc "agda2hs.compile.instance" 20 $-            text $ "raw projection:" ++ prettyShow (Def n [])-          d <- chaseDef n-          fc <- compileFun False d-          let hd = hsName $ prettyShow $ nameConcrete $ qnameName $ defName d-          let fc' = dropPatterns 1 $ replaceName hd uf fc-          return (map (Hs.InsDecl ()) fc', [n])+    -- We want the actual field name, not the instance-opened projection.+    (q, _, _) <- origProjection q+    arg <- fieldArgInfo q -         -- Projection of a default implementation: drop while making sure these are drawn from the-         -- same (minimal) dictionary as the primitive fields.-        | Clause {namedClausePats = [], clauseBody = Just (Def n es)} <- c'-        , n .~ q -> do-          case map unArg . filter keepArg <$> allApplyElims es of-            Just [ Def f _ ] -> do-              reportSDoc "agda2hs.compile.instance" 20 $ vcat-                  [ text "Dropping default instance clause" <+> prettyTCM c'-                  , text "with minimal dictionary" <+> prettyTCM f-                  ]-              reportSDoc "agda2hs.compile.instance" 40 $-                  text $ "raw dictionary:" ++ prettyShow f-              return ([], [f])-            _ -> genericDocError =<< text "illegal instance declaration: instances using default methods should use a named definition or an anonymous `λ where`." -        -- No minimal dictionary used, proceed with compiling as a regular clause.-        | otherwise -> do-          reportSDoc "agda2hs.compile.instance" 20 $ text "Compiling instance clause" <+> prettyTCM c'-          ms <- disableCopatterns $ compileClause curModule uf c'-          return ([Hs.InsDecl () (Hs.FunBind () (toList ms))], [])+    reportSDoc "agda2hs.compile.instance" 15 $+      text "Compiling instance clause for" <+> prettyTCM (Arg arg $ Def q []) +    reportSDoc "agda2hs.compile.instance" 15 $+      text "Instance type: " <+> prettyTCM ty++    -- 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, +    -- so we can just use a dummy term instead+    let instanceHead = __DUMMY_TERM__ +        ty' = b `absApp` instanceHead++    reportSDoc "agda2hs.compile.instance" 15 $+      text "Clause type: " <+> prettyTCM ty'++    reportSDoc "agda2hs.compile.instance" 15 $+      text "Clause patterns:" <+> prettyTCM (namedArg <$> ps)++    reportSDoc "agda2hs.compile.instance" 18 $ text "Current module:" <+> prettyTCM curModule+    ls <- asks locals+    reportSDoc "agda2hs.compile.instance" 18 $ text "Clause locals:" <+> prettyTCM ls++    let uf = hsName $ prettyShow $ nameConcrete $ qnameName q++    let+      (.~) :: QName -> QName -> Bool+      x .~ y = nameConcrete (qnameName x) == nameConcrete (qnameName y)++    if+      -- Instance field: check canonicity.+      | isInstance arg -> do+          unless (null ps) $ genericDocError =<< text "not allowed: explicitly giving superclass"+          body <- case clauseBody c' of+            Nothing -> genericDocError =<< text "not allowed: absurd clause for superclass"+            Just b  -> return b+          addContext (clauseTel c) $ do+            liftTCM $ setModuleCheckpoint curModule+            checkInstance body+          reportSDoc "agda2hs.compile.instance" 20 $ vcat+            [ text "compileInstanceClause dropping clause"+            , nest 2 $ prettyTCM c+            ]+          return ([], [])++      -- Projection of a primitive field: chase down definition and inline as instance clause.+      | Clause {namedClausePats = [], clauseBody = Just (Def n es)} <- c'+      , [(_, f)] <- mapMaybe isProjElim es+      , f .~ q -> do+        reportSDoc "agda2hs.compile.instance" 20 $+          text "Instance clause is projected from" <+> prettyTCM (Def n [])+        reportSDoc "agda2hs.compile.instance" 40 $+          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 hd = hsName $ prettyShow $ nameConcrete $ qnameName defName+        let fc' = {- dropPatterns 1 $ -} replaceName hd uf fc+        reportSDoc "agda2hs.compile.instance" 6 $ vcat $+          text "compileInstanceClause compiled clause: " :+          map (nest 2 . text . pp) fc'+        return (fc', n:rs)++       -- Projection of a default implementation: drop while making sure these are drawn from the+       -- 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`."+            filterArgs :: Type -> [Term] -> C [Term]+            filterArgs ty [] = return []+            filterArgs ty (v:vs) = do+              reportSDoc "agda2hs.compile.instance" 25 $ text "filterArgs: v =" <+> prettyTCM v+              (a,b) <- mustBePi ty+              reportSDoc "agda2hs.compile.instance" 25 $ text "filterArgs: a =" <+> prettyTCM a+              let rest = underAbstraction a b $ \b' -> filterArgs b' vs+              compileDom a >>= \case+                DODropped -> rest+                DOType -> rest+                DOTerm -> (v:) <$> rest+                DOInstance -> err+        ty <- defType <$> getConstInfo n+        traverse (filterArgs ty) (map unArg <$> allApplyElims es) >>= \case+          Just [ Def f _ ] -> do+            reportSDoc "agda2hs.compile.instance" 20 $ vcat+                [ text "Dropping default instance clause" <+> prettyTCM c'+                , text "with minimal dictionary" <+> prettyTCM f+                ]+            reportSDoc "agda2hs.compile.instance" 40 $+                text $ "raw dictionary:" ++ prettyShow f+            return ([], [f])+          _ -> err++      -- No minimal dictionary used, proceed with compiling as a regular clause.+      | otherwise -> do+        reportSDoc "agda2hs.compile.instance" 20 $ text "Compiling instance clause" <+> prettyTCM c'+        ms <- disableCopatterns $ compileClause curModule Nothing uf ty' c'+        let cc = Hs.FunBind () (toList ms)+        reportSDoc "agda2hs.compile.instance" 20 $ vcat+          [ text "compileInstanceClause compiled clause"+          , nest 2 $ text $ pp cc+          ]+        return ([Hs.InsDecl () cc], [])++-- finding a pattern other than a projection: we skip+-- NOTE(flupe): actually I think we may want to throw hard errors here+--              if there is something other than erased parameters+compileInstanceClause' curModule ty (p:ps) c = do+  (a, b) <- mustBePi ty+  compileInstanceClause' curModule (absApp b (patternToTerm $ namedArg p)) ps c+ fieldArgInfo :: QName -> C ArgInfo fieldArgInfo f = do   r <- maybe badness return =<< liftTCM (getRecordOfField f)@@ -215,21 +311,24 @@   where     badness = genericDocError =<< text "Not a record field:" <+> prettyTCM f + findDefinitions :: (QName -> Definition -> C Bool) -> ModuleName -> C [Definition] findDefinitions p m = do-  localDefs    <- (^. sigDefinitions) <$> (^. stSignature) <$> getTCState-  importedDefs <- (^. sigDefinitions) <$> (^. stImports)   <$> getTCState+  localDefs    <- (^. sigDefinitions) . (^. stSignature) <$> getTCState+  importedDefs <- (^. sigDefinitions) . (^. stImports)   <$> getTCState   let allDefs = HMap.union localDefs importedDefs       inMod = [ (x, def) | (x, def) <- HMap.toList allDefs, isInModule x m ]   map snd <$> filterM (uncurry p) inMod + resolveStringName :: String -> C QName resolveStringName s = do   cqname <- liftTCM $ parseName noRange s-  rname <- liftTCM $ resolveName cqname+  rname  <- liftTCM $ resolveName cqname   case rname of     DefinedName _ aname _ -> return $ anameName aname     _ -> genericDocError =<< text ("Couldn't find " ++ s)+  lookupDefaultImplementations :: QName -> [Hs.Name ()] -> C [Definition] lookupDefaultImplementations recName fields = do
src/Agda2Hs/Compile/Data.hs view
@@ -2,6 +2,7 @@  import qualified Language.Haskell.Exts.Syntax as Hs +import Control.Monad ( when ) import Agda.Compiler.Backend import Agda.Syntax.Common import Agda.Syntax.Internal@@ -14,7 +15,7 @@  import Agda.Utils.Impossible ( __IMPOSSIBLE__ ) -import Agda2Hs.Compile.Type ( compileDom, compileTeleBinds )+import Agda2Hs.Compile.Type ( compileDomType, compileTeleBinds ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils import Agda2Hs.HsUtils@@ -22,42 +23,41 @@ checkNewtype :: Hs.Name () -> [Hs.QualConDecl ()] -> C () checkNewtype name cs = do   checkSingleElement name cs "Newtype must have exactly one constructor in definition"-  case head cs of-    Hs.QualConDecl () _ _ (Hs.ConDecl () cName types)-      -> checkSingleElement cName types "Newtype must have exactly one field in constructor"+  case cs of+    (Hs.QualConDecl () _ _ (Hs.ConDecl () cName types):_) -> checkNewtypeCon cName types+    _ -> __IMPOSSIBLE__ -compileData :: DataTarget -> [Hs.Deriving ()] -> Definition -> C [Hs.Decl ()]-compileData target ds def = do+compileData :: AsNewType -> [Hs.Deriving ()] -> Definition -> C [Hs.Decl ()]+compileData newtyp ds def = do   let d = hsName $ prettyShow $ qnameName $ defName def   checkValidTypeName d-  case theDef def of-    Datatype{dataPars = n, dataIxs = numIxs, dataCons = cs} -> do-      TelV tel t <- telViewUpTo n (defType def)-      reportSDoc "agda2hs.data" 10 $ text "Datatype telescope:" <+> prettyTCM tel-      allIndicesErased t-      let params = teleArgs tel-      addContext tel $ do-        binds <- compileTeleBinds tel-        cs <- mapM (compileConstructor params) cs-        let hd = foldl (Hs.DHApp ()) (Hs.DHead () d) binds+  let Datatype{dataPars = n, dataIxs = numIxs, dataCons = cs} = theDef def+  TelV tel t <- telViewUpTo n (defType def)+  reportSDoc "agda2hs.data" 10 $ text "Datatype telescope:" <+> prettyTCM tel+  allIndicesErased t+  let params = teleArgs tel+  addContext tel $ do+    binds <- compileTeleBinds tel+    cs <- mapM (compileConstructor params) cs+    let hd = foldl (Hs.DHApp ()) (Hs.DHead () d) binds -        case target of-          ToData -> return [Hs.DataDecl () (Hs.DataType ()) Nothing hd cs ds]-          ToDataNewType -> do-            checkNewtype d cs-            return [Hs.DataDecl () (Hs.NewType ()) Nothing hd cs ds]-    _ -> __IMPOSSIBLE__+    let target = if newtyp then Hs.NewType () else Hs.DataType ()++    when newtyp (checkNewtype d cs)++    return [Hs.DataDecl () target Nothing hd cs ds]   where     allIndicesErased :: Type -> C ()     allIndicesErased t = reduce (unEl t) >>= \case-      Pi dom t -> compileDom (absName t) dom >>= \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"       _ -> return ()  compileConstructor :: [Arg Term] -> QName -> C (Hs.QualConDecl ())-compileConstructor params c = checkingVars $ do+compileConstructor params c = do   reportSDoc "agda2hs.data.con" 15 $ text "compileConstructor" <+> prettyTCM c   reportSDoc "agda2hs.data.con" 20 $ text "  params = " <+> prettyTCM params   ty <- (`piApplyM` params) . defType =<< getConstInfo c@@ -70,9 +70,10 @@  compileConstructorArgs :: Telescope -> C [Hs.Type ()] compileConstructorArgs EmptyTel = return []-compileConstructorArgs (ExtendTel a tel) = compileDom (absName tel) a >>= \case+compileConstructorArgs (ExtendTel a tel) = compileDomType (absName tel) a >>= \case   DomType s hsA     -> do     ty <- addTyBang s hsA     (ty :) <$> underAbstraction a tel compileConstructorArgs   DomConstraint hsA -> genericDocError =<< text "Not supported: constructors with class constraints"   DomDropped        -> underAbstraction a tel compileConstructorArgs+  DomForall{}       -> __IMPOSSIBLE__
src/Agda2Hs/Compile/Function.hs view
@@ -1,69 +1,87 @@ {-# LANGUAGE OverloadedStrings #-} module Agda2Hs.Compile.Function where +import Control.Arrow ( (***) ) import Control.Monad ( (>=>), filterM, forM_ )-import Control.Monad.Reader ( asks )+import Control.Monad.Reader ( asks, local )  import Data.Generics import Data.List import Data.Maybe ( fromMaybe, isJust ) import qualified Data.Text as Text -import qualified Language.Haskell.Exts.Syntax as Hs-import qualified Language.Haskell.Exts.Build as Hs+import qualified Language.Haskell.Exts as Hs  import Agda.Compiler.Backend import Agda.Compiler.Common  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern ( patternToTerm ) import Agda.Syntax.Literal import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Syntax.Scope.Monad ( isDatatypeModule )  import Agda.TypeChecking.Pretty import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope ( telView )+import Agda.TypeChecking.Telescope ( telView, mustBePi, piApplyM ) import Agda.TypeChecking.Sort ( ifIsSort )+import Agda.TypeChecking.Datatypes ( getConType, isDataOrRecord )+import Agda.TypeChecking.Records ( getDefType )+import Agda.TypeChecking.Reduce ( reduce ) -import Agda.Utils.Functor ( (<&>) )+import Agda.Utils.Functor ( (<&>), dget) import Agda.Utils.Impossible ( __IMPOSSIBLE__ )+import Agda.Utils.Lens ((^.)) import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad+import Agda.Utils.Size ( Sized(size) )  import Agda2Hs.AgdaUtils import Agda2Hs.Compile.Name ( compileQName )-import Agda2Hs.Compile.Term ( compileTerm, compileVar )-import Agda2Hs.Compile.Type ( compileTopLevelType )+import Agda2Hs.Compile.Term ( compileTerm, usableDom )+import Agda2Hs.Compile.Type ( compileType, compileDom, DomOutput(..), compileDomType ) import Agda2Hs.Compile.TypeDefinition ( compileTypeDef ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils+import Agda2Hs.Compile.Var ( compileDBVar ) import Agda2Hs.HsUtils-import Agda.TypeChecking.Datatypes (isDataOrRecord) -isSpecialPat :: QName -> Maybe (ConHead -> ConPatternInfo -> [NamedArg DeBruijnPattern] -> C (Hs.Pat ()))-isSpecialPat qn = case prettyShow qn of-  "Haskell.Prim.Tuple._,_"         -> Just tuplePat-  "Haskell.Prim.Tuple._×_×_._,_,_" -> Just tuplePat-  "Agda.Builtin.Int.Int.pos" -> Just posIntPat-  "Agda.Builtin.Int.Int.negsuc" -> Just negSucIntPat-  s | s `elem` badConstructors -> Just $ \ _ _ _ -> genericDocError =<<-    "constructor `" <> prettyTCM qn <> "` not supported in patterns"-  _ -> Nothing++-- | Compilation rules for specific constructors in patterns.+isSpecialCon :: QName -> Maybe (Type -> NAPs -> C (Hs.Pat ()))+isSpecialCon qn = case prettyShow qn of+  s | s `elem` badConstructors     -> Just itsBad+  "Agda.Builtin.Int.Int.pos"       -> Just posIntPat+  "Agda.Builtin.Int.Int.negsuc"    -> Just negSucIntPat+  _                                -> Nothing   where     badConstructors =       [ "Agda.Builtin.Nat.Nat.zero"       , "Agda.Builtin.Nat.Nat.suc"+      , "Haskell.Extra.Delay.Delay.now"+      , "Haskell.Extra.Delay.Delay.later"       ] -isUnboxCopattern :: DeBruijnPattern -> C Bool-isUnboxCopattern (ProjP _ q) = isJust <$> isUnboxProjection q-isUnboxCopattern _           = return False+    itsBad :: Type -> NAPs -> C (Hs.Pat ())+    itsBad _ _ = genericDocError =<< "constructor `" <> prettyTCM qn <> "` not supported in patterns" -tuplePat :: ConHead -> ConPatternInfo -> [NamedArg DeBruijnPattern] -> C (Hs.Pat ())-tuplePat cons i ps = mapM (compilePat . namedArg) ps <&> Hs.PTuple () Hs.Boxed+-- | Translate Int.pos pattern.+posIntPat :: Type -> NAPs -> C (Hs.Pat ())+posIntPat ty [p] = do+  n <- compileLitNatPat (namedArg p)+  return $ Hs.PLit () (Hs.Signless ()) (Hs.Int () n (show n))+posIntPat _ _ = __IMPOSSIBLE__ ++-- | Translate Int.negsuc pattern.+negSucIntPat :: Type -> NAPs -> C (Hs.Pat ())+negSucIntPat ty [p] = do+  n <- (1+) <$> compileLitNatPat (namedArg p)+  return $ Hs.PLit () (Hs.Negative ()) (Hs.Int () n (show (negate n)))+negSucIntPat _ _ = __IMPOSSIBLE__+ -- Agda2Hs does not support natural number patterns directly (since -- they don't exist in Haskell), however they occur as part of -- patterns of type Integer, so we need to compile literal natural@@ -76,85 +94,146 @@     , [p] <- ps -> (1+) <$> compileLitNatPat (namedArg p)   p -> genericDocError =<< "not a literal natural number pattern:" <?> prettyTCM p -posIntPat :: ConHead -> ConPatternInfo -> [NamedArg DeBruijnPattern] -> C (Hs.Pat ())-posIntPat c i [p] = do-  n <- compileLitNatPat (namedArg p)-  return $ Hs.PLit () (Hs.Signless ()) (Hs.Int () n (show n))-posIntPat _ _ _ = __IMPOSSIBLE__ -negSucIntPat :: ConHead -> ConPatternInfo -> [NamedArg DeBruijnPattern] -> C (Hs.Pat ())-negSucIntPat c i [p] = do-  n <- (1+) <$> compileLitNatPat (namedArg p)-  return $ Hs.PLit () (Hs.Negative ()) (Hs.Int () n (show (negate n)))-negSucIntPat _ _ _ = __IMPOSSIBLE__+compileFun, compileFun'+  :: Bool -- ^ Whether the type signature shuuld also be generated+  -> Definition -> C [Hs.Decl ()] --- The bool argument says whether we also want the type signature or just the body-compileFun, compileFun' :: Bool -> Definition -> C [Hs.Decl ()]--- initialize locals when first stepping into a function-compileFun withSig def@Defn{..} = withFunctionLocals defName $ compileFun' withSig def+compileFun withSig def@Defn{..} =+  setCurrentRangeQ defName+    $ maybePrependFixity defName (defName ^. lensFixity)+    -- initialize locals when first stepping into a function+    $ withFunctionLocals defName+    $ compileFun' withSig def+ -- inherit existing (instantiated) locals-compileFun' withSig def@(Defn {..}) = do+compileFun' withSig def@Defn{..} = inTopContext $ withCurrentModule m $ do   reportSDoc "agda2hs.compile" 6 $ "Compiling function: " <+> prettyTCM defName-  when withSig $ whenJustM (liftTCM $ isDatatypeModule $ qnameModule defName) $ \_ ->++  whenM ((withSig &&) <$> inRecordMod defName) $     genericDocError =<< text "not supported by agda2hs: functions inside a record module"-  let keepClause = maybe False keepArg . clauseType-  withCurrentModule m $ do-    ifM (endsInSort defType)-        -- if the function type ends in Sort, it's a type alias!-        (ensureNoLocals err >> compileTypeDef x def) -        -- otherwise, we have to compile clauses.-        $ do-      when withSig $ checkValidFunName x-      compileTopLevelType withSig defType $ \ty -> do-        let filtered = filter keepClause funClauses-        weAreOnTop <- isJust <$> liftTCM  (currentModule >>= isTopLevelModule)-        pars <- getContextArgs-        -- We only instantiate the clauses to the current module parameters-        -- if the current module isn't the toplevel module-        unless weAreOnTop $-          reportSDoc "agda2hs.compile.type" 6 $ "Applying module parameters to clauses: " <+> prettyTCM pars-        let clauses = if weAreOnTop then filtered else filtered `apply` pars-        cs <- mapMaybeM (compileClause (qnameModule defName) x) clauses -        when (null cs) $ genericDocError-          =<< text "Functions defined with absurd patterns exclusively are not supported."-          <+> text "Use function `error` from the Haskell.Prelude instead."+  ifM (endsInSort defType)+    -- if the function type ends in Sort, it's a type alias!+    (ensureNoLocals err >> compileTypeDef x def)+    -- otherwise, we have to compile clauses.+    $ do+    tel <- lookupSection m -        return $ [Hs.TypeSig () [x] ty | withSig ] ++ [Hs.FunBind () cs]+    -- If this is a top-level function, we compile the module parameters so+    -- we can add them to the type signature and patterns.+    (paramTy , paramPats) <- ifM (asks compilingLocal) (return (id, [])) $ compileModuleParams tel++    addContext tel $ do++      -- Jesper: we need to set the checkpoint for the current module so that+      -- the canonicity check for typeclass instances picks up the+      -- module parameters (see https://github.com/agda/agda2hs/issues/305).+      liftTCM $ setModuleCheckpoint m++      -- We apply the function clause to the module parameters from the context.+      -- In case of a projection-like function, the clause is already+      -- (partially or fully) applied so we should not apply again+      -- (see https://github.com/agda/agda2hs/issues/359)+      let droppedPars = case funProjection of+            Left{} -> 0+            Right proj -> size $ getProjLams $ projLams proj+      pars <- drop droppedPars <$> getContextArgs+      reportSDoc "agda2hs.compile.type" 8 $ "Function module parameters: " <+> prettyTCM pars++      reportSDoc "agda2hs.compile.type" 8 $ "Function type (before instantiation): " <+> inTopContext (prettyTCM defType)+      typ <- piApplyM defType pars+      reportSDoc "agda2hs.compile.type" 8 $ "Function type (after instantiation): " <+> prettyTCM typ++      sig <- if not withSig then return [] else do+        checkValidFunName x+        ty <- paramTy <$> compileType (unEl typ)+        reportSDoc "agda2hs.compile.type" 8 $ "Compiled function type: " <+> text (Hs.prettyPrint ty)+        return [Hs.TypeSig () [x] ty]++      let clauses = funClauses `apply` pars+      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."+        <+> text "Use function `error` from the Haskell.Prelude instead."++      return $ sig ++ [Hs.FunBind () cs]   where     Function{..} = theDef     m = qnameModule defName     n = qnameName defName     x = hsName $ prettyShow n-    endsInSort t = do-      TelV tel b <- telView t-      addContext tel $ ifIsSort b (\_ -> return True) (return False)     err = "Not supported: type definition with `where` clauses" -compileClause :: ModuleName -> Hs.Name () -> Clause -> C (Maybe (Hs.Match ()))-compileClause mod x c = withClauseLocals mod c $ compileClause' mod x c+    addPats :: [Hs.Pat ()] -> Hs.Match () -> Hs.Match ()+    addPats [] cl = cl+    addPats ps (Hs.Match l f qs rhs bs) = Hs.Match l f (ps++qs) rhs bs+    addPats (p:ps) (Hs.InfixMatch l q f qs rhs bs) = Hs.InfixMatch l p f (ps++q:qs) rhs bs -compileClause' :: ModuleName -> Hs.Name () -> Clause -> C (Maybe (Hs.Match ()))-compileClause' curModule x c@Clause{clauseBody = Nothing} = pure Nothing-compileClause' curModule x c@Clause{..} = do-  reportSDoc "agda2hs.compile" 7 $ "compiling clause: " <+> prettyTCM c-  reportSDoc "agda2hs.compile" 17 $ "Old context: " <+> (prettyTCM =<< getContext)-  reportSDoc "agda2hs.compile" 17 $ "Clause telescope: " <+> prettyTCM clauseTel-  addContext (KeepNames clauseTel) $ do-    ps <- compilePats namedClausePats+compileModuleParams :: Telescope -> C (Hs.Type () -> Hs.Type () , [Hs.Pat ()])+compileModuleParams EmptyTel = return (id, [])+compileModuleParams (ExtendTel a tel) = do+  (f , p) <- compileDomType (absName tel) a >>= \case+    DomDropped -> return (id, [])+    DomConstraint c -> return (constrainType c, [])+    DomForall a -> return (qualifyType a, [])+    DomType s a -> do+      let n = hsName $ absName tel+      checkValidVarName n+      return (Hs.TyFun () a, [Hs.PVar () n])+  ((f .) *** (p++)) <$> underAbstraction a tel compileModuleParams++compileClause :: ModuleName -> Maybe QName -> Hs.Name () -> Type -> Clause -> C (Maybe (Hs.Match ()))+compileClause curModule mproj x t c =+  withClauseLocals curModule c $ do+    compileClause' curModule mproj x t c++compileClause' :: ModuleName -> Maybe QName -> Hs.Name () -> Type -> Clause -> C (Maybe (Hs.Match ()))+compileClause' curModule projName x ty c@Clause{..} = do+  reportSDoc "agda2hs.compile" 7  $ "compiling clause: " <+> prettyTCM c++  ifNotM (keepClause c) (pure Nothing) $ addContext (KeepNames clauseTel) $ do+    reportSDoc "agda2hs.compile" 17 $ "Old context: "      <+> (inTopContext . prettyTCM =<< getContext)+    reportSDoc "agda2hs.compile" 17 $ "Clause telescope: " <+> inTopContext (prettyTCM clauseTel)+    reportSDoc "agda2hs.compile" 17 $ "Clause type:      " <+> prettyTCM clauseType+    reportSDoc "agda2hs.compile" 17 $ "Function type:    " <+> prettyTCM ty+    reportSDoc "agda2hs.compile" 17 $ "Clause patterns:  " <+> text (prettyShow namedClausePats)+    reportSDoc "agda2hs.compile" 18 $ "Clause module:" <+> prettyTCM curModule+    ls <- asks locals+    reportSDoc "agda2hs.compile" 18 $ "Clause locals:" <+> prettyTCM ls++    toDrop <- case projName of+      Nothing -> pure 0+      Just q  -> maybe 0 (pred . projIndex) <$> isProjection q++    reportSDoc "agda2hs.compile" 17 $ "Args to drop (proj-like): " <+> prettyTCM toDrop++    -- NOTE(flupe: for projection-like definitions, we drop the first parameters)+    let ntel = size clauseTel+    ty <- ty `piApplyM` [Var (ntel - k - 1) [] | k <- [0.. (toDrop - 1)]]++    reportSDoc "agda2hs.compile" 17 $ "Corrected type: " <+> prettyTCM ty++    ps <- compilePats ty namedClausePats+     let isWhereDecl = not . isExtendedLambdaName           /\ (curModule `isFatherModuleOf`) . qnameModule-    children <- filter isWhereDecl <$> asks locals-    whereDecls <- mapM (getConstInfo >=> compileFun' True) children-    -- Jesper, 2023-10-30: We should compile the body in the module of the-    -- `where` declarations (if there are any) in order to drop the arguments-    -- that correspond to the pattern variables of this clause from the calls to-    -- the functions defined in the `where` block.-    let inWhereModule = case children of-          [] -> id-          (c:_) -> withCurrentModule $ qnameModule c-    body <- inWhereModule $ compileTerm $ fromMaybe __IMPOSSIBLE__ clauseBody-    let rhs = Hs.UnGuardedRhs () body++    children   <- filter isWhereDecl <$> asks locals+    -- TODO: remove this when Agda exposes where-provenance in 'Internal' syntax+    let withWhereModule = case children of+          []    -> id+          (c:_) -> addWhereModule $ qnameModule c+    whereDecls <- withWhereModule $ compileLocal $ mapM (getConstInfo >=> compileFun' True) children++    let Just body            = clauseBody+        Just (unArg -> typ)  = clauseType++    hsBody <- withWhereModule $ compileTerm typ body++    let rhs = Hs.UnGuardedRhs () hsBody         whereBinds | null whereDecls = Nothing                    | otherwise       = Just $ Hs.BDecls () (concat whereDecls)         match = case (x, ps) of@@ -162,73 +241,80 @@           _                         -> Hs.Match () x ps rhs whereBinds     return $ Just match -noAsPatterns :: DeBruijnPattern -> C ()-noAsPatterns = \case-    VarP i _ -> checkPatternInfo i-    DotP i _ -> checkPatternInfo i-    ConP _ cpi ps -> do-      checkPatternInfo $ conPInfo cpi-      forM_ ps $ noAsPatterns . namedArg-    LitP i _ -> checkPatternInfo i-    ProjP{} -> return ()-    IApplyP i _ _ _ -> checkPatternInfo i-    DefP i _ ps -> do-      checkPatternInfo i-      forM_ ps $ noAsPatterns . namedArg-  where-    checkPatternInfo i = unless (null $ patAsNames i) $-      genericDocError =<< "not supported by agda2hs: as patterns"+keepClause :: Clause -> C Bool+keepClause c@Clause{..} = case (clauseBody, clauseType) of+  (Nothing, _) -> pure False+  (_, Nothing) -> pure False+  (Just body, Just cty) -> compileDom (domFromArg cty) <&> \case+    DODropped  -> False+    DOInstance -> True+    DOType     -> __IMPOSSIBLE__+    DOTerm     -> True -compilePats :: NAPs -> C [Hs.Pat ()]-compilePats ps = mapM (compilePat . namedArg) =<< filterM keepPat ps-  where-    keepPat :: NamedArg DeBruijnPattern -> C Bool-    keepPat p = do-      keep <- return (keepArg p) `and2M` (not <$> isUnboxCopattern (namedArg p))-      when keep $ noAsPatterns $ namedArg p-      -- We do not allow forced (dot) patterns for non-erased arguments (see issue #142).-      when (usableModality p && isForcedPat (namedArg p)) $-        genericDocError =<< "not supported by agda2hs: forced (dot) patterns in non-erased positions"-      return keep -    isForcedPat :: DeBruijnPattern -> Bool-    isForcedPat = \case-      VarP{}        -> False-      DotP{}        -> True-      ConP c cpi ps -> conPLazy cpi-      LitP{}        -> False-      ProjP{}       -> False-      IApplyP{}     -> False-      DefP{}        -> False+-- TODO(flupe): projection-like definitions are missing the first (variable) patterns+--             (that are however present in the type)+--             so we should drop the first parameters in the input type (using funProjection.projLams)+compilePats :: Type -> NAPs -> C [Hs.Pat ()]+compilePats _ [] = pure []+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" +  ty     <- fromMaybe __IMPOSSIBLE__ <$> getDefType pn ty+  (a, b) <- mustBePi ty -compilePat :: DeBruijnPattern -> C (Hs.Pat ())-compilePat p@(VarP o x)+  compilePats (absBody b) ps++compilePats ty ((namedArg -> pat):ps) = do+  (a, b) <- mustBePi ty+  reportSDoc "agda2hs.compile.pattern" 10 $ text "Compiling pattern:" <+> prettyTCM pat+  let rest = compilePats (absApp b (patternToTerm pat)) ps+  when (usableDom a) checkForced+  compileDom a >>= \case+    DOInstance -> rest+    DODropped  -> rest+    DOType     -> rest+    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"+++compilePat :: Type -> DeBruijnPattern -> C (Hs.Pat ())++-- variable pattern+compilePat ty p@(VarP o x)   | PatOWild <- patOrigin o = return $ Hs.PWildCard ()-  | otherwise               = do-      n <- hsName <$> compileVar (dbPatVarIndex x)+  | otherwise = do+      n <- hsName <$> compileDBVar (dbPatVarIndex x)       checkValidVarName n       return $ Hs.PVar () n-compilePat (ConP h i ps)-  | Just semantics <- isSpecialPat (conName h) = setCurrentRange h $ semantics h i ps-compilePat (ConP h _ ps) = isUnboxConstructor (conName h) >>= \case-  Just s -> compileErasedConP ps >>= addPatBang s-  Nothing -> do-    ps <- compilePats ps-    c <- compileQName (conName h)++-- special constructor pattern+compilePat ty (ConP ch i ps) = do+  Just ((_, _, _), ty) <- getConType ch =<< reduce ty+  let c = conName ch++  ifJust (isSpecialCon c) (\semantics -> setCurrentRange ch $ semantics ty ps) $ do+  ifJustM (isUnboxConstructor c) (\s -> compileErasedConP ty s ps) $ do+  ifJustM (isTupleConstructor c) (\b -> compileTupleConP ty b ps) $ do+    ps <- compilePats ty ps+    c <- compileQName (conName ch)     return $ pApp c ps-compilePat (LitP _ l) = compileLitPat l-compilePat (ProjP _ q) = do-  reportSDoc "agda2hs.compile" 6 $ "compiling copattern: " <+> text (prettyShow q)-  unlessM (asks copatternsEnabled) $-    genericDocError =<< "not supported in Haskell: copatterns"-  let x = hsName $ prettyShow q-  return $ Hs.PVar () x-compilePat p = genericDocError =<< "bad pattern:" <?> prettyTCM p -compileErasedConP :: NAPs -> C (Hs.Pat ())-compileErasedConP ps = compilePats ps <&> \case-  [p] -> p+-- literal patterns+compilePat ty (LitP _ l) = compileLitPat l+++-- nothing else is supported+compilePat _ p = genericDocError =<< "bad pattern:" <?> prettyTCM p+++compileErasedConP :: Type -> Strictness -> NAPs -> C (Hs.Pat ())+compileErasedConP ty s ps = compilePats ty ps >>= \case+  [p] -> addPatBang s p   _   -> __IMPOSSIBLE__  compileLitPat :: Literal -> C (Hs.Pat ())@@ -236,10 +322,16 @@   LitChar c -> return $ Hs.charP c   l -> genericDocError =<< "bad literal pattern:" <?> prettyTCM l +compileTupleConP :: Type -> Hs.Boxed -> NAPs -> C (Hs.Pat ())+compileTupleConP ty b ps = do+  ps <- compilePats ty ps+  return $ Hs.PTuple () b ps+ -- Local (where) declarations --------------------------------------------- --- | Before checking a function, grab all of its local declarations.+ -- TODO: simplify this when Agda exposes where-provenance in 'Internal' syntax+-- | Run a computation with all the local declarations in the state. withFunctionLocals :: QName -> C a -> C a withFunctionLocals q k = do   ls <- takeWhile (isAnonymousModuleName . qnameModule)@@ -250,10 +342,12 @@   reportSDoc "agda2hs.compile.locals" 17 $ "Function locals: "<+> prettyTCM ls   withLocals ls k --- | Retain only those local declarations that belong to current clause's module.++-- | Filter local declarations that belong to the given module. zoomLocals :: ModuleName -> LocalDecls -> LocalDecls zoomLocals mname = filter ((mname `isLeParentModuleOf`) . qnameModule) + -- | Before checking a clause, grab all of its local declarations. -- TODO: simplify this when Agda exposes where-provenance in 'Internal' syntax withClauseLocals :: ModuleName -> Clause -> C a -> C a@@ -267,13 +361,17 @@     nonExtLamUses = qnameModule <$> filter (not . isExtendedLambdaName) uses     whereModuleName       | null uses = Nothing-      | otherwise = Just $ head (nonExtLamUses ++ [curModule])+      | otherwise = Just $ case nonExtLamUses ++ [curModule] of+          (x:_) -> x+          _ -> __IMPOSSIBLE__     ls' = case whereModuleName of       Nothing -> []       Just m  -> zoomLocals m ls   reportSDoc "agda2hs.compile.locals" 18 $ "Clause locals: "<+> prettyTCM ls'   withLocals ls' k ++-- | Ensure a definition can be defined as transparent. checkTransparentPragma :: Definition -> C () checkTransparentPragma def = compileFun False def >>= \case     [Hs.FunBind _ cls] ->@@ -294,3 +392,30 @@     errNotTransparent = genericDocError =<<       "Cannot make function" <+> prettyTCM (defName def) <+> "transparent." <+>       "A transparent function must have exactly one non-erased argument and return it unchanged."+++-- | Ensure a definition can be defined as inline.+checkInlinePragma :: Definition -> C ()+checkInlinePragma def@Defn{defName = f} = do+  let Function{funClauses = cs} = theDef def+  case filter (isJust . clauseBody) cs of+    [c] ->+      unlessM (allowedPats (namedClausePats c)) $ genericDocError =<<+        "Cannot make function" <+> prettyTCM (defName def) <+> "inlinable." <+>+        "Inline functions can only use variable patterns or transparent record constructor patterns."+    _ ->+      genericDocError =<<+        "Cannot make function" <+> prettyTCM f <+> "inlinable." <+>+        "An inline function must have exactly one clause."++  where allowedPat :: DeBruijnPattern -> C Bool+        allowedPat VarP{} = pure True+        -- only allow matching on (unboxed) record constructors+        allowedPat (ConP ch ci cargs) =+          isUnboxConstructor (conName ch) >>= \case+            Just _  -> allowedPats cargs+            Nothing -> pure False+        allowedPat _ = pure False++        allowedPats :: NAPs -> C Bool+        allowedPats pats = allM pats (allowedPat . dget . dget)
src/Agda2Hs/Compile/Function.hs-boot view
@@ -1,7 +1,7 @@ module Agda2Hs.Compile.Function where  import qualified Language.Haskell.Exts.Syntax as Hs ( Match, Name )-import Agda.Syntax.Internal ( Clause, ModuleName )+import Agda.Syntax.Internal ( Clause, ModuleName, QName, Type ) import Agda2Hs.Compile.Types ( C ) -compileClause' :: ModuleName -> Hs.Name () -> Clause -> C (Maybe (Hs.Match ()))+compileClause' :: ModuleName -> Maybe QName -> Hs.Name () -> Type -> Clause -> C (Maybe (Hs.Match ()))
src/Agda2Hs/Compile/Imports.hs view
@@ -18,6 +18,7 @@ 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@@ -54,10 +55,10 @@     -- Name in the Import datatype     makeCName :: Hs.Name () -> Hs.CName ()     makeCName n@(Hs.Ident _ s)-      | isUpper (head s) = Hs.ConName () n+      | Just True == (isUpper . fst <$> L.uncons s) = Hs.ConName () n       | otherwise        = Hs.VarName () n     makeCName n@(Hs.Symbol _ s)-      | head s == ':' = Hs.ConName () n+      | (fst <$> L.uncons s) == Just ':' = Hs.ConName () n       | otherwise     = Hs.VarName () n      makeImportSpec :: NamespacedName -> Set NamespacedName -> Hs.ImportSpec ()
src/Agda2Hs/Compile/Name.hs view
@@ -34,12 +34,14 @@  import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe ( isJust, isNothing, whenJust, fromMaybe, caseMaybeM )+import Agda.Utils.Monad ( whenM )  import Agda2Hs.AgdaUtils import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils import Agda2Hs.HsUtils + isSpecialCon :: QName -> Maybe (Hs.QName ()) isSpecialCon = prettyShow >>> \case     "Agda.Builtin.List.List"     -> special Hs.ListCon@@ -72,6 +74,9 @@   , "Haskell.Prim._∘_"              `to` "_._"          `importing` Nothing   , "Haskell.Prim.Monad.Dont._>>=_" `to` "_>>=_"        `importing` Nothing   , "Haskell.Prim.Monad.Dont._>>_"  `to` "_>>_"         `importing` Nothing+  , "Haskell.Prim.Tuple.first"      `to` "first"        `importing` Just "Control.Arrow"+  , "Haskell.Prim.Tuple.second"     `to` "second"       `importing` Just "Control.Arrow"+  , "Haskell.Prim.Tuple._***_"      `to` "_***_"        `importing` Just "Control.Arrow"   ]   where infixr 6 `to`, `importing`         to = (,)@@ -94,8 +99,8 @@     return c   | otherwise = do     f <- isRecordConstructor f >>= return . \case-      Just (r, Record{recNamedCon = False}) -> r -- use record name for unnamed constructors-      _                                     -> f+      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     parent <- parentName f@@ -117,7 +122,8 @@       qf = qualify mod' hf qual      -- add (possibly qualified) import-    whenJust (mimpBuiltin <|> mimp) tellImport+    whenM (asks writeImports) $+      whenJust (mimpBuiltin <|> mimp) tellImport      reportSDoc "agda2hs.name" 25 $ text        $ "-------------------------------------------------"@@ -158,7 +164,6 @@       (QualifiedAs as) -> Hs.Qual () (fromMaybe mod as) n       Unqualified      -> Hs.UnQual () n -    primModules = ["Agda.Builtin", "Haskell.Prim", "Haskell.Prelude"]     primMonadModules = ["Haskell.Prim.Monad.Dont", "Haskell.Prim.Monad.Do"]      -- Determine whether it is a type operator or an "ordinary" operator.@@ -192,7 +197,7 @@ hsTopLevelModuleName = hsModuleName . intercalate "." . map unpack                      . List1.toList . moduleNameParts --- | Given a module name (assumed to be a toplevel module), +-- | Given a module name (assumed to be a toplevel module), -- compute the associated Haskell module name. compileModuleName :: ModuleName -> C (Hs.ModuleName ()) compileModuleName m = do
src/Agda2Hs/Compile/Record.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE NamedFieldPuns #-} module Agda2Hs.Compile.Record where -import Control.Monad ( unless )+import Control.Monad ( unless, when ) import Control.Monad.Reader ( MonadReader(local) )  import Data.List ( (\\), nub )@@ -17,16 +16,17 @@ import Agda.Syntax.Internal import Agda.Syntax.Common.Pretty ( prettyShow ) -import Agda.TypeChecking.Pretty ( ($$), (<+>), text, vcat )+import Agda.TypeChecking.Pretty ( ($$), (<+>), text, vcat, prettyTCM ) import Agda.TypeChecking.Substitute ( TelV(TelV), Apply(apply) ) import Agda.TypeChecking.Telescope +import Agda.Utils.Singleton import Agda.Utils.Impossible ( __IMPOSSIBLE__ )  import Agda2Hs.AgdaUtils import Agda2Hs.Compile.ClassInstance import Agda2Hs.Compile.Function ( compileFun )-import Agda2Hs.Compile.Type ( compileDom, compileTeleBinds )+import Agda2Hs.Compile.Type ( compileDomType, compileTeleBinds, compileDom, DomOutput(..) ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils import Agda2Hs.HsUtils@@ -48,11 +48,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) $+  compiled <- withMinRecord m $ addContext (defaultDom rtype) $ compileLocal $     fmap concat $ traverse (compileFun False) defaults   let declMap = Map.fromList [ (definedName c, def) | def@(Hs.FunBind _ (c : _)) <- compiled ]   return (definedFields, declMap) + compileMinRecords :: Definition -> [String] -> C [Hs.Decl ()] compileMinRecords def sls = do @@ -88,10 +89,11 @@   -- TODO: order default implementations differently?   return ([minPragma | not (null prims)] ++ Map.elems decls) + compileRecord :: RecordTarget -> Definition -> C (Hs.Decl ()) compileRecord target def = do   TelV tel _ <- telViewUpTo recPars (defType def)-  addContext tel $ checkingVars $ do+  addContext tel $ do     checkValidTypeName rName     binds <- compileTeleBinds tel     let hd = foldl (Hs.DHApp ()) (Hs.DHead () rName) binds@@ -105,15 +107,12 @@               assts  -> Just (Hs.CxTuple () assts)         defaultDecls <- compileMinRecords def ms         return $ Hs.ClassDecl () context hd [] (Just (classDecls ++ map (Hs.ClsDecl ()) defaultDecls))-      ToRecord ds -> do-        checkValidConName cName-        (constraints, fieldDecls) <- compileRecFields fieldDecl recFields fieldTel-        compileDataRecord constraints fieldDecls (Hs.DataType ()) hd ds-      ToRecordNewType ds -> do+      ToRecord newtyp ds -> do         checkValidConName cName         (constraints, fieldDecls) <- compileRecFields fieldDecl recFields fieldTel-        checkSingleElement cName fieldDecls "Newtype must have exactly one field in constructor"-        compileDataRecord constraints fieldDecls (Hs.NewType ()) hd ds+        when newtyp $ checkNewtypeCon cName fieldDecls+        let target = if newtyp then Hs.NewType () else Hs.DataType ()+        compileDataRecord constraints fieldDecls target hd ds    where     rName = hsName $ prettyShow $ qnameName $ defName def@@ -142,7 +141,7 @@     compileRecFields decl ns tel = case (ns, tel) of       (_   , EmptyTel          ) -> return ([], [])       (n:ns, ExtendTel dom tel') -> do-        hsDom <- compileDom (absName tel') dom+        hsDom <- compileDomType (absName tel') dom         (hsAssts, hsFields) <- underAbstraction dom tel' $ compileRecFields decl ns         case hsDom of           DomType s hsA -> do@@ -155,25 +154,46 @@             ToRecord{} -> genericError $               "Not supported: record/class with constraint fields"           DomDropped -> return (hsAssts , hsFields)+          DomForall{} -> __IMPOSSIBLE__       (_, _) -> __IMPOSSIBLE__ -    compileDataRecord :: [Hs.Asst ()] -> [Hs.FieldDecl ()] -- compiled rec fields-                         -> Hs.DataOrNew () -- whether to compile to data or newtype-                         -> Hs.DeclHead () -- the head of the type declaration-                         -> [Hs.Deriving ()] -- data extracted from the pragma-                         -> C (Hs.Decl ())+    compileDataRecord+      :: [Hs.Asst ()]+      -> [Hs.FieldDecl ()] -- ^ compiled rec fields+      -> Hs.DataOrNew ()   -- ^ whether to compile to data or newtype+      -> Hs.DeclHead ()    -- ^ the head of the type declaration+      -> [Hs.Deriving ()]  -- ^ data extracted from the pragma+      -> C (Hs.Decl ())     compileDataRecord constraints fieldDecls don hd ds = do       unless (null constraints) __IMPOSSIBLE__ -- no constraints for records       mapM_ checkFieldInScope (map unDom recFields)       let conDecl = Hs.QualConDecl () Nothing Nothing $ Hs.RecDecl () cName fieldDecls       return $ Hs.DataDecl () don Nothing hd [conDecl] ds -checkUnboxPragma :: Defn -> C ()-checkUnboxPragma def-  | Record{recFields} <- def-  , length (filter keepArg recFields) == 1-  , not (recRecursive def)-  = return ()+checkUnboxPragma :: Definition -> C ()+checkUnboxPragma def = do+  let Record{..} = theDef def -  | otherwise-  = genericError "An unboxed type must be a non-recursive record type with exactly one non-erased field."+  -- 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"++  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"++  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"+      DOTerm -> (absName tel:) <$> underAbstraction a tel nonErasedFields
src/Agda2Hs/Compile/Term.hs view
@@ -1,12 +1,15 @@ module Agda2Hs.Compile.Term where -import Control.Arrow ( (>>>), (&&&) )-import Control.Monad ( unless )+import Control.Arrow ( (>>>), (&&&), second )+import Control.Monad ( unless, zipWithM ) import Control.Monad.Reader +import Data.Foldable ( toList )+import Data.Functor ( ($>) ) import Data.List ( isPrefixOf ) import Data.Maybe ( fromMaybe, isJust ) import qualified Data.Text as Text ( unpack )+import qualified Data.Set as Set ( singleton )  import qualified Language.Haskell.Exts as Hs @@ -18,125 +21,323 @@  import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce ( instantiate )-import Agda.TypeChecking.Substitute ( Apply(applyE) )+import Agda.TypeChecking.Records ( shouldBeProjectible, isRecordType, recordFieldNames )+import Agda.TypeChecking.Datatypes ( getConType )+import Agda.TypeChecking.Reduce ( unfoldDefinitionStep, instantiate )+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope ( telView, mustBePi, piApplyM, flattenTel )+import Agda.TypeChecking.ProjectionLike ( reduceProjectionLike )  import Agda.Utils.Lens- import Agda.Utils.Impossible ( __IMPOSSIBLE__ )+import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Size  import Agda2Hs.AgdaUtils import Agda2Hs.Compile.Name ( compileQName )++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 {-# SOURCE #-} Agda2Hs.Compile.Function ( compileClause' )+import qualified Data.List as L -isSpecialTerm :: QName -> Maybe (QName -> Elims -> C (Hs.Exp ()))-isSpecialTerm q = case prettyShow q of-  _ | isExtendedLambdaName q                    -> Just lambdaCase-  "Haskell.Prim.if_then_else_"                  -> Just ifThenElse++-- * Compilation of special definitions++type DefCompileRule = Type -> [Term] -> C (Hs.Exp ())++isSpecialDef :: QName -> Maybe DefCompileRule+isSpecialDef q = case prettyShow q of+  _ | isExtendedLambdaName q     -> Just (lambdaCase q)+  "Haskell.Prim.if_then_else_"   -> Just ifThenElse+  "Haskell.Prim.case_of_"        -> Just caseOf+  "Haskell.Prim.the"             -> Just expTypeSig+  "Haskell.Extra.Delay.runDelay" -> Just compileErasedApp+  "Agda.Builtin.Word.primWord64FromNat" -> Just primWord64FromNat+  _                              -> Nothing+++-- | Compile a @\where@ to the equivalent @\case@ expression.+lambdaCase :: QName -> DefCompileRule+lambdaCase q ty args = compileLocal $ setCurrentRangeQ q $ do+  Function+    { funClauses = cls+    , funExtLam  = Just ExtLamInfo {extLamModule = mname}+    } <- theDef <$> getConstInfo q++  npars <- size <$> lookupSection mname++  let (pars, rest) = splitAt npars args+      cs           = applys cls pars++  ty' <- piApplyM ty pars++  cs <- mapMaybeM (compileClause' mname (Just q) (hsName "(lambdaCase)") ty') cs++  case cs of+    -- If there is a single clause and all proper patterns got erased,+    -- we turn the remaining arguments into normal lambdas.+    [Hs.Match _ _ ps (Hs.UnGuardedRhs _ rhs) _]+      | null ps -> return rhs+      | all isVarPat ps -> return $ Hs.Lambda () ps rhs+    _ -> do+      lcase <- hsLCase =<< mapM clauseToAlt cs -- Pattern lambdas cannot have where blocks+      eApp lcase <$> compileArgs ty' rest+      -- undefined -- compileApp lcase (undefined, undefined, rest)++  where+    isVarPat :: Hs.Pat () -> Bool+    isVarPat Hs.PVar{} = True+    isVarPat _ = False++-- | Compile @if_then_else_@ to a Haskell @if ... then ... else ... @ expression.+ifThenElse :: DefCompileRule+ifThenElse ty args = compileArgs ty args >>= \case+  -- fully applied+  b : t : f : es' -> return $ Hs.If () b t f `eApp` es'+  -- partially applied+  _               -> genericError "if_then_else_ must be fully applied"+++-- | Compile @case_of_@ to Haskell @\case@ expression.+caseOf :: DefCompileRule+caseOf ty args = compileArgs ty args >>= \case+  -- applied to pattern lambda (that we remove, hence decrementLCase)+  e : Hs.LCase _ alts : es' -> decrementLCase $> eApp (Hs.Case () e alts) es'+  -- applied to regular lambda+  e : Hs.Lambda _ (p : ps) b : es' ->+    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"+++-- | Compile @the@ to an explicitly-annotated Haskell expression.+expTypeSig :: DefCompileRule+expTypeSig ty args@(_:typ:_:_) = do+    annot    <- compileType typ+    exp:args <- compileArgs ty args+    pure (Hs.ExpTypeSig () exp annot `eApp` args)+expTypeSig _ _ = genericError "`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"+++compileVar :: Int -> Type -> [Term] -> C (Hs.Exp ())+compileVar i ty es = do+  reportSDoc "agda2hs.compile.term" 15 $ text "Reached variable"+  name <- compileDBVar i+  compileApp (hsVar name) ty es++-- | Compile constructors, defs and vars by+-- carefully moving projections out of elims and calling compileProj.+compileSpined+      :: ([Term] -> C (Hs.Exp ()))  -- Compilation continuation+      -> (Elims -> Term)            -- Term begin constructed+      -> Type                       -- Type of term+      -> Elims                      -- Elims the term is applied to+      -> C (Hs.Exp ())+compileSpined c tm ty [] = c []+compileSpined c tm ty (e@(Proj o q):es) = do+  let t = tm []+  ty' <- shouldBeProjectible t ty o q+  compileSpined (compileProj q ty t ty') (tm . (e:)) ty' es+compileSpined c tm ty (e@(Apply (unArg -> x)):es) = do+  (a, b) <- mustBePi ty+  compileSpined (c . (x:)) (tm . (e:)) (absApp b x) es+compileSpined _ _ _ _ = __IMPOSSIBLE__++-- | Compile a definition.+compileDef :: QName -> Type -> [Term] -> C (Hs.Exp ())+compileDef f ty args | Just sem <- isSpecialDef f = do+  reportSDoc "agda2hs.compile.term" 12 $ text "Compiling application of special function"+  sem ty args++compileDef f ty args =+  ifM (isTransparentFunction f) (compileErasedApp ty args) $+  ifM (isInlinedFunction f) (compileInlineFunctionApp f ty args) $ do+    reportSDoc "agda2hs.compile.term" 12 $ text "Compiling application of regular function:" <+> prettyTCM f++    let defMod = qnameModule f++    minRecord <- asks minRecordName+    -- TODO: simplify this when Agda exposes where-provenance in 'Internal' syntax+    outerWhereModules <- asks whereModules++    (ty', args') <-++      -- if the function comes from a where-clause+      -- or is a class-method for the class we are currently defining,+      -- we drop the module parameters+      if defMod `elem` outerWhereModules || Just defMod == minRecord then do+        npars <- size <$> lookupSection defMod+        let (pars, rest) = splitAt npars args+        ty' <- piApplyM ty pars+        pure (ty', rest)+      else pure (ty, args)++    reportSDoc "agda2hs.compile.term" 15 $ text "module args" <+> prettyTCM ty'+    reportSDoc "agda2hs.compile.term" 15 $ text "args to def: " <+> prettyTCM args'++    hsName <- compileQName f++    compileApp (Hs.Var () hsName) ty' args'+++-- * Compilation of projection(-like) definitions++type ProjCompileRule = Type -> Term -> Type -> [Term] -> C (Hs.Exp ())+++isSpecialProj :: QName -> Maybe ProjCompileRule+isSpecialProj q = case prettyShow q of+  "Agda.Builtin.FromNat.Number.fromNat"         -> Just fromNat   "Haskell.Prim.Enum.Enum.enumFrom"             -> Just mkEnumFrom   "Haskell.Prim.Enum.Enum.enumFromTo"           -> Just mkEnumFromTo   "Haskell.Prim.Enum.Enum.enumFromThen"         -> Just mkEnumFromThen   "Haskell.Prim.Enum.Enum.enumFromThenTo"       -> Just mkEnumFromThenTo-  "Haskell.Prim.case_of_"                       -> Just caseOf-  "Haskell.Prim.Monad.Do.Monad._>>=_"           -> Just bind-  "Haskell.Prim.Monad.Do.Monad._>>_"            -> Just sequ-  "Agda.Builtin.FromNat.Number.fromNat"         -> Just fromNat+  "Haskell.Prim.Monad.Do.Monad._>>=_"           -> Just monadBind+  "Haskell.Prim.Monad.Do.Monad._>>_"            -> Just monadSeq   "Agda.Builtin.FromNeg.Negative.fromNeg"       -> Just fromNeg   "Agda.Builtin.FromString.IsString.fromString" -> Just fromString   _                                             -> Nothing -isSpecialCon :: QName -> Maybe (ConHead -> ConInfo -> Elims -> C (Hs.Exp ()))-isSpecialCon = prettyShow >>> \case-  "Haskell.Prim.Tuple._,_"         -> Just tupleTerm-  "Haskell.Prim.Tuple._×_×_._,_,_" -> Just tupleTerm-  _ -> Nothing -tupleTerm :: ConHead -> ConInfo -> Elims -> C (Hs.Exp ())-tupleTerm cons i es = compileElims es <&> Hs.Tuple () Hs.Boxed+compileClassFun :: QName -> ProjCompileRule+compileClassFun q _ w ty args = do+  hf     <- compileQName q+  curMod <- currentModule+  unless (curMod `isLeChildModuleOf` qnameModule q) $ checkInstance w+  eApp (Hs.Var () hf) <$> compileArgs ty args -ifThenElse :: QName -> Elims -> C (Hs.Exp ())-ifThenElse _ es = compileElims es >>= \case-  -- fully applied-  b : t : f : es' -> return $ Hs.If () b t f `eApp` es'-  -- partially applied-  _ -> genericError $ "if_then_else must be fully applied"+compileTupleProjection :: QName -> Hs.Boxed -> ProjCompileRule+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"+  reportSDoc "agda2hs.term.proj" 12 $ text "compiling tuple projection"+  (r, pars, def) <- lift $ fromMaybe __IMPOSSIBLE__ <$> isRecordType wty+  let fields = map unDom $ _recFields def+      fieldTypes = flattenTel $ _recTel def `apply` pars+  fname <- compileTupleFields fields fieldTypes >>= \case+    [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")+  cw <- compileTerm wty w+  cargs <- compileArgs ty args+  return $ eApp (Hs.Var () $ Hs.UnQual () fname) (cw:cargs) -specialClassFunction :: Hs.Exp () -> ([Hs.Exp ()] -> Hs.Exp ()) -> Elims -> C (Hs.Exp ())-specialClassFunction v f [] = return v-specialClassFunction v f (Apply w : es) = do-  checkInstance $ unArg w-  f <$> compileElims es-specialClassFunction v f (_ : _) = __IMPOSSIBLE__+  where+    compileTupleFields :: [QName] -> [Dom Type] -> C [QName]+    compileTupleFields fs tys = catMaybes <$> zipWithM compileTupleField fs tys -specialClassFunction1 :: Hs.Exp () -> (Hs.Exp () -> Hs.Exp ()) -> Elims -> C (Hs.Exp ())-specialClassFunction1 v f = specialClassFunction v $ \case+    compileTupleField :: QName -> Dom Type -> C (Maybe QName)+    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+++-- | Compile a projection(-like) definition+compileProj+  :: QName  -- ^ Name of the projection+  -> Type   -- ^ Type of the term the projection is being applied to+  -> Term   -- ^ Term the projection is being applied to+  -> Type   -- ^ Return type of the projection+  -> [Term] -- ^ Arguments the projection of the term is applied to+  -> C (Hs.Exp ())+compileProj q tty t ty args | Just rule <- isSpecialProj q = rule tty t ty args+compileProj q tty t ty args =+  -- unboxed projection: we drop the projection+  ifM (isJust <$> isUnboxProjection q) (eApp <$> compileTerm tty t <*> compileArgs ty args) $+  -- class projection: we check the instance and drop it+  ifM (isClassFunction q) (compileClassFun q tty t ty args) $+  ifJustM (isTupleProjection q) (\b -> compileTupleProjection q b tty t ty args) $+  do+  -- NOTE(flupe): maybe we want Dom Type for the record arg+    name <- compileQName q+    arg  <- compileTerm tty t+    compileApp (Hs.Var () name `eApp` [arg]) ty args++-- | Utility for translating class methods to special Haskell counterpart.+-- This runs an instance check.+specialClassFunction :: ([Hs.Exp ()] -> Hs.Exp ()) -> ProjCompileRule+specialClassFunction f = specialClassFunctionM (pure . f)++specialClassFunctionM :: ([Hs.Exp ()] -> C (Hs.Exp ())) -> ProjCompileRule+specialClassFunctionM f _ w ty args = checkInstance w >> (f =<< compileArgs ty args)++specialClassFunction1 :: Hs.Exp () -> (Hs.Exp () -> Hs.Exp ()) -> ProjCompileRule+specialClassFunction1 v f = specialClassFunction $ \case   (a : es) -> f a `eApp` es   []       -> v -specialClassFunction2 :: Hs.Exp () -> (Hs.Exp () -> Hs.Exp () -> Hs.Exp ()) -> Elims -> C (Hs.Exp ())-specialClassFunction2 v f = specialClassFunction v $ \case+specialClassFunction2 :: Hs.Exp () -> (Hs.Exp () -> Hs.Exp () -> Hs.Exp ()) -> ProjCompileRule+specialClassFunction2 v f = specialClassFunction $ \case   (a : b : es) -> f a b `eApp` es   es           -> v `eApp` es -specialClassFunction3 :: Hs.Exp () -> (Hs.Exp () -> Hs.Exp () -> Hs.Exp () -> Hs.Exp ()) -> Elims -> C (Hs.Exp ())-specialClassFunction3 v f = specialClassFunction v $ \case+specialClassFunction3 :: Hs.Exp () -> (Hs.Exp () -> Hs.Exp () -> Hs.Exp () -> Hs.Exp ()) -> ProjCompileRule+specialClassFunction3 v f = specialClassFunction $ \case   (a : b : c : es) -> f a b c `eApp` es   es               -> v `eApp` es -fromNat :: QName -> Elims -> C (Hs.Exp ())-fromNat _ = specialClassFunction1 (hsVar "fromIntegral") $ \case+-- Note: currently the second (instance) argument {{_ : Constraint n}}+-- is compiled and then dropped here, ideally it would not be compiled+-- at all.+fromNat :: ProjCompileRule+fromNat = specialClassFunction2 (hsVar "fromIntegral") $ \v _ -> case v of   n@Hs.Lit{} -> n   v          -> hsVar "fromIntegral" `eApp` [v] -fromNeg :: QName -> Elims -> C (Hs.Exp ())-fromNeg _ = specialClassFunction1 negFromIntegral $ \case+mkEnumFrom :: ProjCompileRule+mkEnumFrom = specialClassFunction1 (hsVar "enumFrom") $ Hs.EnumFrom ()++mkEnumFromTo :: ProjCompileRule+mkEnumFromTo = specialClassFunction2 (hsVar "enumFromTo") $ Hs.EnumFromTo ()++mkEnumFromThen :: ProjCompileRule+mkEnumFromThen = specialClassFunction2 (hsVar "enumFromThen") $ Hs.EnumFromThen ()++mkEnumFromThenTo :: ProjCompileRule+mkEnumFromThenTo = specialClassFunction3 (hsVar "enumFromThenTo") $ Hs.EnumFromThenTo ()++-- Same comment as for fromNat+fromNeg :: ProjCompileRule+fromNeg = specialClassFunction2 negFromIntegral $ \v _ -> case v of   n@Hs.Lit{} -> Hs.NegApp () n   v          -> negFromIntegral `eApp` [v]   where     negFromIntegral = hsVar "negate" `o` hsVar "fromIntegral"+    -- TODO: move this to HsUtils     f `o` g = Hs.InfixApp () f (Hs.QVarOp () $ hsUnqualName "_._") g -fromString :: QName -> Elims -> C (Hs.Exp ())-fromString _ = specialClassFunction1 (hsVar "fromString") $ \case+-- Same comment as for fromNat+fromString :: ProjCompileRule+fromString = specialClassFunction2 (hsVar "fromString") $ \v _ -> case v of   s@Hs.Lit{} -> s   v          -> hsVar "fromString" `eApp` [v] -mkEnumFrom :: QName -> Elims -> C (Hs.Exp ())-mkEnumFrom _ = specialClassFunction1 (hsVar "enumFrom") $-  \a -> Hs.EnumFrom () a--mkEnumFromTo :: QName -> Elims -> C (Hs.Exp ())-mkEnumFromTo _ = specialClassFunction2 (hsVar "enumFromTo") $-  \a b -> Hs.EnumFromTo () a b--mkEnumFromThen :: QName -> Elims -> C (Hs.Exp ())-mkEnumFromThen _ = specialClassFunction2 (hsVar "enumFromThen") $-  \a b -> Hs.EnumFromThen () a b--mkEnumFromThenTo :: QName -> Elims -> C (Hs.Exp ())-mkEnumFromThenTo _ = specialClassFunction3 (hsVar "enumFromThenTo") $-  \a b c -> Hs.EnumFromThenTo () a b c--delay :: QName -> Elims -> C (Hs.Exp ())-delay _ = compileErasedApp--force :: QName -> Elims -> C (Hs.Exp ())-force _ = compileErasedApp--bind :: QName -> Elims -> C (Hs.Exp ())-bind q (e:es) = do-  checkInstance $ unArg $ isApplyElim' __IMPOSSIBLE__ e-  compileElims es >>= \case-    [u, Hs.Lambda _ [p] v] -> return (bind' u p v)-    [u, Hs.LCase () [Hs.Alt () p (Hs.UnGuardedRhs () v) Nothing]] ->-      decrementLCase >> return (bind' u p v)-    vs -> return $ hsVar "_>>=_" `eApp` vs+-- | Compile monadic bind operator _>>=_ to Haskell do notation.+monadBind :: ProjCompileRule+monadBind = specialClassFunctionM $ \case+  [u, Hs.Lambda _ [p] v] -> pure $ bind' u p v+  [u, Hs.LCase () [Hs.Alt () p (Hs.UnGuardedRhs () v) Nothing]] ->+    decrementLCase >> return (bind' u p v)+  vs -> pure $ hsVar "_>>=_" `eApp` vs   where     bind' :: Hs.Exp () -> Hs.Pat () -> Hs.Exp () -> Hs.Exp ()     bind' u p v =@@ -144,53 +345,266 @@       case v of         Hs.Do _ stmts -> Hs.Do () (stmt1 : stmts)         _             -> Hs.Do () [stmt1, Hs.Qualifier () v]-bind q [] = return $ hsVar "_>>=_" -sequ :: QName -> Elims -> C (Hs.Exp ())-sequ q (e:es) = do-  checkInstance $ unArg $ isApplyElim' __IMPOSSIBLE__ e-  compileElims es >>= \case-    (u : v : vs) -> do-      let stmt1 = Hs.Qualifier () u-      case v of-        Hs.Do _ stmts -> return $ Hs.Do () (stmt1 : stmts)-        _             -> return $ Hs.Do () [stmt1, Hs.Qualifier () v]-    vs -> return $ hsVar "_>>_" `eApp` vs-sequ q [] = return $ hsVar "_>>_"+-- | Compile monadic bind operator _>>_ to Haskell do notation.+monadSeq :: ProjCompileRule-- TElims -> C (Hs.Exp ())+monadSeq = specialClassFunction $ \case+  (u : v : vs) -> do+    let stmt1 = Hs.Qualifier () u+    case v of+      Hs.Do _ stmts -> Hs.Do () (stmt1 : stmts)+      _             -> Hs.Do () [stmt1, Hs.Qualifier () v]+  vs -> hsVar "_>>_" `eApp` vs -caseOf :: QName -> Elims -> C (Hs.Exp ())-caseOf _ es = compileElims es >>= \case-  -- applied to pattern lambda-  e : Hs.LCase _ alts : es' -> do-    decrementLCase-    return $ eApp (Hs.Case () e alts) es'-  -- applied to regular lambda-  e : Hs.Lambda _ (p : ps) b : es' -> do-    let lam [] = id-        lam qs = Hs.Lambda () qs-    return $ eApp (Hs.Case () e [Hs.Alt () p (Hs.UnGuardedRhs () $ lam ps b) Nothing]) es'-  -- applied to non-lambda / partially applied-  _ -> genericError $ "case_of_ must be fully applied to a lambda" -lambdaCase :: QName -> Elims -> C (Hs.Exp ())-lambdaCase q es = setCurrentRangeQ q $ do-  Function{funClauses = cls, funExtLam = Just ExtLamInfo {extLamModule = mname}}-    <- theDef <$> getConstInfo q-  npars <- size <$> lookupSection mname-  let (pars, rest) = splitAt npars es-      cs           = applyE cls pars-  cs <- mapMaybeM (compileClause' (qnameModule q) $ hsName "(lambdaCase)") cs-  case cs of-    -- If there is a single clause and all patterns got erased, we-    -- simply return the body.-    [Hs.Match _ _ [] (Hs.UnGuardedRhs _ rhs) _] -> return rhs-    _ -> do-      lcase <- hsLCase =<< mapM clauseToAlt cs -- Pattern lambdas cannot have where blocks-      eApp lcase <$> compileElims rest+-- * Compilation of constructors +type ConCompileRule = Type -> [Term] -> C (Hs.Exp ())++-- | Custom compilation rules for special constructors.+isSpecialCon :: QName -> Maybe ConCompileRule+isSpecialCon = prettyShow >>> \case+  "Haskell.Prim.Tuple._,_"          -> Just tupleTerm+  "Haskell.Prim.Tuple._×_×_._,_,_"  -> Just tupleTerm+  "Haskell.Prim.Int.Int.int64"      -> Just int64Term+  "Haskell.Extra.Sigma._,_"         -> Just tupleTerm+  "Haskell.Extra.Erase.Erased"      -> Just erasedTerm+  "Haskell.Extra.Delay.Delay.now"   -> Just compileErasedApp+  "Haskell.Extra.Delay.Delay.later" -> Just compileErasedApp+  _                                 -> Nothing++tupleTerm :: ConCompileRule+tupleTerm = compileApp' (Hs.Tuple () Hs.Boxed)++erasedTerm :: ConCompileRule+erasedTerm _ _ = pure (Hs.Tuple () Hs.Boxed [])++int64Term :: ConCompileRule+int64Term ty args = compileArgs ty args >>= \case+  n@Hs.Lit{} : _ -> return n+  _ -> genericError "int64 must be applied to a literal"++-- | @compileErasedApp@ compiles the application of unboxed constructors+-- and transparent functions.+-- Precondition: at most one argument is preserved.+compileErasedApp :: Type -> [Term] -> C (Hs.Exp ())+compileErasedApp ty args = do+  reportSDoc "agda2hs.compile.term" 12 $ text "Compiling application of transparent function or erased unboxed constructor"+  reportSDoc "agda2hs.compile.term" 12 $ text "Args" <+> prettyTCM args+  reportSDoc "agda2hs.compile.term" 12 $ text "Type" <+> prettyTCM ty+  compileArgs ty args >>= \case+    []  -> return $ hsVar "id"+    [v] -> return v+    _   -> __IMPOSSIBLE__+++compileCon :: ConHead -> ConInfo -> Type -> [Term] -> C (Hs.Exp ())+compileCon h i ty args = do+  let c = conName h+  ifJust  (isSpecialCon c)       (\semantics -> semantics ty args) $ do+  ifJustM (isUnboxConstructor c) (\_ -> compileErasedApp ty args)  $ do+  ifJustM (isTupleConstructor c) (\b -> compileTuple ty b args)    $ do+    info <- getConstInfo c+    -- the constructor may be a copy introduced by module application,+    -- therefore we need to find the original constructor+    if defCopy info then+      let Constructor{conSrcCon = ch'} = theDef info in+      compileCon ch' i ty args+    else do+      con <- Hs.Con () <$> compileQName c+      compileApp con ty args++compileTuple :: Type -> Hs.Boxed -> [Term] -> C (Hs.Exp ())+compileTuple ty b args = do+  tellUnboxedTuples b+  (ty', vs) <- compileArgs' ty args+  TelV tel _ <- telView ty'+  missing <- compileTelSize tel+  let given = size vs+  if -- No arguments: return unit constructor () or (# #)+     | given == 0 && missing == 0 -> return $+         Hs.Con () $ Hs.Special () $ case b of+           Hs.Boxed -> Hs.UnitCon ()+           Hs.Unboxed -> Hs.UnboxedSingleCon ()+     -- All arguments missing: return tuple constructor+     -- e.g. (,) or (#,#)+     | given == 0 -> return $+         Hs.Con () $ Hs.Special () $ Hs.TupleCon () b missing+     -- All arguments given: return tuple+     -- e.g. (v1 , v2) or (# v1 , v2 #)+     | missing == 0 -> return $ Hs.Tuple () b vs+     -- Some arguments given, some missing: return tuple section+     -- e.g. (v1 ,) or (# v1, #)+     | otherwise -> do+         tellExtension $ Hs.TupleSections+         return $ Hs.TupleSection () b $+           map Just vs ++ replicate missing Nothing++++-- * Term compilation++compileTerm :: Type -> Term -> C (Hs.Exp ())+compileTerm ty v = do++  reportSDoc "agda2hs.compile.term" 10  $ text "compiling term:" <+> prettyTCM v++  v <- instantiate v++  let bad s t = genericDocError =<< vcat+        [ text "agda2hs: cannot compile" <+> text (s ++ ":")+        , nest 2 $ prettyTCM t+        ]++  reduceProjectionLike v >>= \case++    Def f es -> do+      ty <- defType <$> getConstInfo f+      compileSpined (compileDef f ty) (Def f) ty es++    Con ch ci es -> do+      Just ((_, _, _), ty) <- getConType ch ty+      compileSpined (compileCon ch ci ty) (Con ch ci) ty es++    Var i es     -> do+      ty <- typeOfBV i+      compileSpined (compileVar i ty) (Var i) ty es++    Lit l   -> compileLiteral l++    Lam v b -> compileLam ty v b++    v@Pi{} -> bad "function type" v+    v@Sort{} -> bad "sort type" v+    v@Level{} -> bad "level term" v+    v@MetaV{} -> bad "unsolved metavariable" v+    v@DontCare{} -> bad "irrelevant term" v+    v@Dummy{} -> bad "dummy term" v++-- | Check whether a domain is usable on the Haskell side.+--+-- That is the case if:+-- * it is usable on the Agda side (i.e neither erased nor irrelevant).+-- * is not of sort Prop.+usableDom :: Dom Type -> Bool+usableDom dom | Prop _ <- getSort dom = False+usableDom dom = usableModality dom+++compileLam :: Type -> ArgInfo -> Abs Term -> C (Hs.Exp ())+compileLam ty argi abs = do+  reportSDoc "agda2hs.compile.term" 50 $ text "Reached lambda"+  (dom, cod) <- mustBePi ty++  -- unusable domain, we remove the lambda and compile the body only+  if not (usableDom dom) then+    addContext dom $ compileTerm (absBody cod) (absBody abs)++  -- 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."++    reportSDoc "agda2hs.compile" 17 $ text "compiling regular lambda"++    let varName = absName abs+        ctxElt  = (varName,) <$> dom++    hsLambda varName <$> addContext ctxElt (compileTerm (absBody cod) (absBody abs))++  -- usable domain, generated lambda means we introduce a section+  else do++    let varName = absName abs+        ctxElt  = (varName,) <$> dom++    addContext ctxElt $ do+      x <- compileDBVar 0+      compileTerm (absBody cod) (absBody abs) <&> \case+        Hs.InfixApp () a op b | a == hsVar x ->+          if pp op == "-" then -- Jesper: no right section for minus, as Haskell parses this as negation!+            Hs.LeftSection () b (Hs.QConOp () $ Hs.UnQual () $ hsName "subtract")+          else+            Hs.RightSection () op b -- System-inserted visible lambdas can only come from sections+        body -> hsLambda x body+++-- | Compile the application of a function definition marked as inlinable.+-- The provided arguments will get substituted in the function body, and the missing arguments+-- will get quantified with lambdas.+compileInlineFunctionApp :: QName -> Type -> [Term] -> C (Hs.Exp ())+compileInlineFunctionApp f ty args = do+  reportSDoc "agda2hs.compile.term" 12 $ text "Compiling application of inline function"++  def <- getConstInfo f++  let ty' = defType def+  let Function{funClauses = cs} = theDef def+  let [Clause{namedClausePats = pats}] = filter (isJust . clauseBody) cs++  ty'' <- piApplyM ty args+  -- NOTE(flupe): very flimsy, there has to be a better way+  etaExpand (drop (length args) pats) ty' args >>= compileTerm ty''++  where+    -- inline functions can only have transparent constructor patterns and variable patterns+    extractPatName :: DeBruijnPattern -> ArgName+    extractPatName (VarP _ v) = dbPatVarName v+    extractPatName (ConP _ _ args) =+      let arg = namedThing $ unArg $ maybe __IMPOSSIBLE__ fst $ L.uncons $ filter (usableModality `and2M` visible) args+      in extractPatName arg+    extractPatName _ = __IMPOSSIBLE__++    extractName :: NamedArg DeBruijnPattern -> ArgName+    extractName (unArg -> np)+      | Just n <- nameOf np = rangedThing (woThing n)+      | otherwise = extractPatName (namedThing np)++    etaExpand :: NAPs -> Type -> [Term] -> C Term+    etaExpand [] ty args = do+      r <- liftReduce+            $ locallyReduceDefs (OnlyReduceDefs $ Set.singleton f)+            $ 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++    etaExpand (p:ps) ty args = do+      (dom, cod) <- mustBePi ty+      let ai = domInfo dom+      Lam ai . mkAbs (extractName p) <$> etaExpand ps (absBody cod) (raise 1 args ++ [ var 0 ])+++compileApp :: Hs.Exp () -> Type -> [Term] -> C (Hs.Exp ())+compileApp = compileApp' . eApp++compileApp' :: ([Hs.Exp ()] -> Hs.Exp ()) -> Type -> [Term] -> C (Hs.Exp ())+compileApp' acc ty args = acc <$> compileArgs ty args++-- | Compile a list of arguments applied to a function of the given type.+compileArgs :: Type -> [Term] -> C [Hs.Exp ()]+compileArgs ty args = snd <$> compileArgs' ty args++compileArgs' :: Type -> [Term] -> C (Type, [Hs.Exp ()])+compileArgs' ty [] = pure (ty, [])+compileArgs' ty (x:xs) = do+  (a, b) <- mustBePi ty+  let rest = compileArgs' (absApp b x) xs+  compileDom a >>= \case+    DODropped  -> rest+    DOInstance -> checkInstance x *> rest+    DOType     -> checkValidType x *> rest+    DOTerm     -> second . (:) <$> compileTerm (unDom a) x <*> rest++-- We check that type arguments compile to a valid Haskell type+-- before dropping them, see issue #357.+checkValidType :: Term -> C ()+checkValidType x = noWriteImports (compileType x) *> return ()+ 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 _ _)     = genericError "Pattern matching lambdas must take a single argument" clauseToAlt Hs.InfixMatch{}           = __IMPOSSIBLE__  compileLiteral :: Literal -> C (Hs.Exp ())@@ -200,123 +614,4 @@ 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)---- | Compile a variable. If the check is enabled, ensures the variable is usable and visible.-compileVar :: Nat -> C String-compileVar x = do-  (d, n) <- (fmap snd &&& fst . unDom) <$> lookupBV x-  let cn = prettyShow $ nameConcrete n-  let b | notVisible d   = "hidden"-        | hasQuantity0 d = "erased"-        | otherwise      = ""-  whenM (asks checkVar) $ unless (null b) $ genericDocError =<<-    text ("Cannot use " <> b <> " variable " <> cn)-  return cn--compileTerm :: Term -> C (Hs.Exp ())-compileTerm v = do-  reportSDoc "agda2hs.compile" 7 $ text "compiling term:" <+> prettyTCM v-  reportSDoc "agda2hs.compile" 27 $ text "compiling term:" <+> pure (P.pretty $ unSpine1 v)-  case unSpine1 v of-    Var x es   -> do-      s <- compileVar x-      hsVar s `app` es-    -- v currently we assume all record projections are instance-    -- args that need attention-    Def f es -> maybeUnfoldCopy f es compileTerm $ \f es -> if-      | Just semantics <- isSpecialTerm f -> do-          reportSDoc "agda2hs.compile.term" 12 $ text "Compiling application of special function"-          semantics f es-      | otherwise -> isClassFunction f >>= \case-          True  -> compileClassFunApp f es-          False -> (isJust <$> isUnboxProjection f) `or2M` isTransparentFunction f >>= \case-            True  -> compileErasedApp es-            False -> do-              reportSDoc "agda2hs.compile.term" 12 $ text "Compiling application of regular function"-              -- Drop module parameters of local `where` functions-              moduleArgs <- getDefFreeVars f-              reportSDoc "agda2hs.compile.term" 15 $ text "Module arguments for" <+> (prettyTCM f <> text ":") <+> prettyTCM moduleArgs-              (`app` drop moduleArgs es) . Hs.Var () =<< compileQName f-    Con h i es -> do-      reportSDoc "agda2hs.compile" 8 $ text "reached constructor:" <+> prettyTCM (conName h)-      -- the constructor may be a copy introduced by module application,-      -- therefore we need to find the original constructor-      info <- getConstInfo (conName h)-      if not (defCopy info)-        then compileCon h i es-        else let Constructor{conSrcCon = c} = theDef info in-             compileCon c ConOSystem es-    Lit l -> compileLiteral l-    Lam v b | usableModality v, getOrigin v == UserWritten -> do-      when (patternInTeleName `isPrefixOf` absName b) $ genericDocError =<< do-        text "Record pattern translation not supported. Use a pattern matching lambda instead."-      unless (visible v) $ genericDocError =<< do-        text "Implicit lambda not supported: " <+> prettyTCM (absName b)-      hsLambda (absName b) <$> underAbstr_ b compileTerm-    Lam v b | usableModality v ->-      -- System-inserted lambda, no need to preserve the name.-      underAbstraction_ b $ \ body -> do-        x <- showTCM (Var 0 [])-        let hsx = hsVar x-        body <- compileTerm body-        return $ case body of-          Hs.InfixApp _ a op b-            | a == hsx -> Hs.RightSection () op b -- System-inserted visible lambdas can only come from sections-          _            -> hsLambda x body         -- so we know x is not free in b.-    Lam v b ->-      -- Drop erased lambdas (#65)-      underAbstraction_ b $ \ body -> compileTerm body-    t -> genericDocError =<< text "bad term:" <?> prettyTCM t-  where-    app :: Hs.Exp () -> Elims -> C (Hs.Exp ())-    app hd es = eApp hd <$> compileElims es--    compileCon :: ConHead -> ConInfo -> Elims -> C (Hs.Exp ())-    compileCon h i es-      | Just semantics <- isSpecialCon (conName h)-      = semantics h i es-    compileCon h i es =-      isUnboxConstructor (conName h) >>= \case-        Just _  -> compileErasedApp es-        Nothing -> (`app` es) . Hs.Con () =<< compileQName (conName h)---- `compileErasedApp` compiles an application of an erased constructor--- or projection.-compileErasedApp :: Elims -> C (Hs.Exp ())-compileErasedApp es = do-  reportSDoc "agda2hs.compile.term" 12 $ text "Compiling application of erased function"-  compileElims es >>= \case-    []     -> return $ hsVar "id"-    (v:vs) -> return $ v `eApp` vs---- `compileClassFunApp` is used when we have a record projection and we want to--- drop the first visible arg (the record)-compileClassFunApp :: QName -> Elims -> C (Hs.Exp ())-compileClassFunApp f es = do-  reportSDoc "agda2hs.compile.term" 14 $ text "Compiling application of class function"-  hf <- compileQName f-  case dropWhile notVisible (fromMaybe __IMPOSSIBLE__ $ allApplyElims es) of-    []     -> __IMPOSSIBLE__-    (x:xs) -> do-      curMod <- currentModule-      reportSDoc "agda2hs.compile" 15 $ nest 2 $ vcat-        [ text "symbol module:  " <+> prettyTCM (qnameModule f)-        , text "current module: " <+> prettyTCM curMod-        ]-      unless (curMod `isLeChildModuleOf` qnameModule f) $ checkInstance $ unArg x-      args <- compileArgs xs-      return $ Hs.Var () hf `eApp` args--compileElims :: Elims -> C [Hs.Exp ()]-compileElims es = compileArgs $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es--compileArgs :: Args -> C [Hs.Exp ()]-compileArgs args = mapMaybeM compileArg args--compileArg :: Arg Term -> C (Maybe (Hs.Exp ()))-compileArg x = do-  reportSDoc "agda2hs.compile" 8 $ text "compiling argument" <+> prettyTCM x-  if | keepArg x -> Just <$> compileTerm (unArg x)-     | isInstance x, usableModality x -> Nothing <$ checkInstance (unArg $ x)-     | otherwise -> return Nothing+compileLiteral l             = genericDocError =<< text "bad term:" <?> prettyTCM (Lit l)
src/Agda2Hs/Compile/Type.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE TypeApplications #-} +-- | Compilation to Haskell types. module Agda2Hs.Compile.Type where  import Control.Arrow ( (>>>) )-import Control.Monad ( forM, when )+import Control.Monad ( forM, when, unless ) import Control.Monad.Trans ( lift ) import Control.Monad.Reader ( asks ) import Data.List ( find ) 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@@ -20,204 +22,277 @@ import Agda.Syntax.Common.Pretty ( prettyShow )  import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce ( reduce )+import Agda.TypeChecking.Reduce ( reduce, unfoldDefinitionStep, instantiate ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope  import Agda.Utils.Impossible ( __IMPOSSIBLE__ ) import Agda.Utils.List ( downFrom ) import Agda.Utils.Maybe ( ifJustM, fromMaybe )-import Agda.Utils.Monad ( ifM, unlessM )+import Agda.Utils.Monad ( ifM, whenM, unlessM, and2M, or2M ) import Agda.Utils.Size ( Sized(size) ) import Agda.Utils.Functor ( ($>) )  import Agda2Hs.Compile.Name ( compileQName )-import Agda2Hs.Compile.Term ( compileVar ) import Agda2Hs.Compile.Types import Agda2Hs.Compile.Utils+import Agda2Hs.Compile.Var import Agda2Hs.AgdaUtils import Agda2Hs.HsUtils -isSpecialType :: QName -> Maybe (QName -> Elims -> C (Hs.Type ()))++-- | Type definitions from the prelude that get special translation rules.+isSpecialType :: QName -> Maybe (Elims -> C (Hs.Type ())) isSpecialType = prettyShow >>> \case-  "Haskell.Prim.Tuple._×_"   -> Just tupleType-  "Haskell.Prim.Tuple._×_×_" -> Just tupleType-  _ -> Nothing+  "Haskell.Prim.Tuple._×_"    -> Just tupleType+  "Haskell.Prim.Tuple._×_×_"  -> Just tupleType+  "Haskell.Extra.Sigma.Σ"     -> Just tupleType+  "Haskell.Extra.Erase.Erase" -> Just unitType+  "Haskell.Extra.Delay.Delay" -> Just delayType+  _                           -> Nothing -tupleType :: QName -> Elims -> C (Hs.Type ())-tupleType q es = do++-- | Compile all the elims into a n-uple.+tupleType :: Elims -> C (Hs.Type ())+tupleType es = do   let Just as = allApplyElims es   ts <- mapM (compileType . unArg) as   return $ Hs.TyTuple () Hs.Boxed ts --- | Add a class constraint to a Haskell type.-constrainType-  :: Hs.Asst () -- ^ The class assertion.-  -> Hs.Type () -- ^ The type to constrain.-  -> Hs.Type ()-constrainType c = \case-  Hs.TyForall _ as (Just (Hs.CxTuple _ cs)) t -> Hs.TyForall () as (Just (Hs.CxTuple () (c:cs))) t-  Hs.TyForall _ as (Just (Hs.CxSingle _ c')) t -> Hs.TyForall () as (Just (Hs.CxTuple () [c,c'])) t-  Hs.TyForall _ as _ t -> Hs.TyForall () as (Just (Hs.CxSingle () c)) t-  t -> Hs.TyForall () Nothing (Just (Hs.CxSingle () c)) t --- | Add explicit quantification over a variable to a Haskell type.-qualifyType-  :: String     -- ^ Name of the variable.-  -> Hs.Type () -- ^ Type to quantify.-  -> Hs.Type ()-qualifyType s = \case-    Hs.TyForall _ (Just as) cs t -> Hs.TyForall () (Just (a:as)) cs t-    Hs.TyForall _ Nothing cs t -> Hs.TyForall () (Just [a]) cs t-    t -> Hs.TyForall () (Just [a]) Nothing t-  where-    a = Hs.UnkindedVar () $ Hs.Ident () s+-- | Ignore arguments and return the unit type.+unitType :: Elims -> C (Hs.Type ())+unitType _ = return $ Hs.TyTuple () Hs.Boxed []  --- | Compile a top-level type, such that:------   * erased parameters of the current module are dropped.---   * usable hidden type parameters of the current module are explicitely quantified.---   * usable instance parameters are added as type constraints.---   * usable explicit parameters are forbidden (for now).------   The continuation is called in an extended context with these type---   arguments bound.-compileTopLevelType-    :: Bool-    -- ^ Whether the generated Haskell type will end up in-    --   the final output. If so, this functions asks for-    --   language extension ScopedTypeVariables to be enabled.-    -> Type-    -> (Hs.Type () -> C a) -- ^ Continuation with the compiled type.-    -> C a-compileTopLevelType keepType t cont = do-    reportSDoc "agda2hs.compile.type" 12 $ text "Compiling top-level type" <+> prettyTCM t-    -- NOTE(flupe): even though we only quantify variable for definitions inside anonymous modules,-    --              they will still get quantified over the toplevel module parameters.-    weAreOnTop <- isJust <$> liftTCM  (currentModule >>= isTopLevelModule)-    modTel <- moduleParametersToDrop =<< currentModule-    reportSDoc "agda2hs.compile.type" 19 $ text "Module parameters to process: " <+> prettyTCM modTel-    go weAreOnTop modTel cont-  where-    go :: Bool -> Telescope -> (Hs.Type () -> C a) -> C a-    go _ EmptyTel cont = do-      ctxArgs <- getContextArgs-      ty <- compileType . unEl =<< t `piApplyM` ctxArgs-      cont ty-    go onTop (ExtendTel a atel) cont-      | not (usableModality a) =-          underAbstraction a atel $ \tel -> go onTop tel cont-      | isInstance a = do-          c <- Hs.TypeA () <$> compileType (unEl $ unDom a)-          underAbstraction a atel $ \tel ->-            go onTop tel (cont . constrainType c)-      | otherwise = do-          compileType (unEl $ unDom a)-          when (keepType && not onTop) $ tellExtension Hs.ScopedTypeVariables-          let qualifier = if onTop then id else qualifyType (absName atel)-          underAbstraction a atel $ \tel ->-            go onTop tel (cont . qualifier)+-- | Compile fully applied Delay type as its only type argument.+delayType :: Elims -> C (Hs.Type ())+delayType (Apply a : _) = compileType (unArg a)+delayType (_       : _) = __IMPOSSIBLE__+delayType [] = genericDocError =<< text "Cannot compile unapplied Delay type" -compileType' :: Term -> C (Strictness, Hs.Type ())-compileType' t = do++-- | Compile an Agda term into a Haskell type, along with its strictness.+compileTypeWithStrictness :: Term -> C (Strictness, Hs.Type ())+compileTypeWithStrictness t = do   s <- case t of     Def f es -> fromMaybe Lazy <$> isUnboxRecord f     _        -> return Lazy-  (s,) <$> compileType t+  ty <- compileType t+  pure (s, ty) + -- | Compile an Agda term into a Haskell type. compileType :: Term -> C (Hs.Type ()) compileType t = do+   reportSDoc "agda2hs.compile.type" 12 $ text "Compiling type" <+> prettyTCM t   reportSDoc "agda2hs.compile.type" 22 $ text "Compiling type" <+> pretty t -  case t of-    Pi a b -> compileDom (absName b) a >>= \case-      DomType _ hsA -> do-        hsB <- underAbstraction a b $ compileType . unEl-        return $ Hs.TyFun () hsA hsB-      DomConstraint hsA -> do-        hsB <- underAbstraction a b (compileType . unEl)-        return $ constrainType hsA hsB-      DomDropped -> underAbstr a b (compileType . unEl)+  whenM (isErasedBaseType t) fail++  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)+      let compileB = underAbstraction a b (compileType . unEl)+      compileDomType (absName b) a >>= \case+        DomType _ hsA -> Hs.TyFun () hsA <$> compileB+        DomConstraint hsA -> constrainType hsA <$> compileB+        DomDropped -> compileB+        DomForall hsA -> qualifyType hsA <$> compileB+     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               <+> text "in Haskell type"-         | Just semantics <- isSpecialType f -> setCurrentRange f $ semantics f es+         | Just semantics <- isSpecialType f -> setCurrentRange f $ semantics es          | Just args <- allApplyElims es ->              ifJustM (isUnboxRecord f) (\_ -> compileUnboxType f args) $-             ifM (isTransparentFunction f) (compileTransparentType args) $ do-               vs <- compileTypeArgs args+             ifJustM (isTupleRecord f) (\b -> compileTupleType f b args) $+             ifM (isTransparentFunction f) (compileTransparentType (defType def) args) $+             ifM (isInlinedFunction f) (compileInlineType f es) $ do+               vs <- compileTypeArgs (defType def) args                f <- compileQName f                return $ tApp (Hs.TyCon () f) vs          | otherwise -> fail+     Var x es | Just args <- allApplyElims es -> do-      vs <- compileTypeArgs args-      x  <- hsName <$> compileVar x+      xi <- lookupBV x+      unless (usableModality xi) $ genericDocError+        =<< text "Cannot use erased variable" <+> prettyTCM (var x)+        <+> text "in Haskell type"+      vs <- compileTypeArgs (snd $ unDom xi) args+      x  <- hsName <$> compileDBVar x       return $ tApp (Hs.TyVar () x) vs+     Sort s -> return (Hs.TyStar ())-    Lam argInfo restAbs-      | not (keepArg argInfo) -> underAbstraction_ restAbs compileType++    Lam argInfo restAbs -> do+      (body , x0) <- underAbstraction_ restAbs $ \b ->+        (,) <$> compileType b <*> (hsName <$> compileDBVar 0)++      -- TODO: we should also drop lambdas that can be erased based on their type+      -- (e.g. argument is of type Level/Size or in a Prop) but currently we do+      -- not have access to the type of the lambda here.+      if | hasQuantity0 argInfo -> return body+         -- Rewrite `\x -> (a -> x)` to `(->) a`+         | Hs.TyFun _ a (Hs.TyVar _ y) <- body+         , y == x0 -> return $ Hs.TyApp () (Hs.TyCon () $ Hs.Special () $ Hs.FunCon ()) a+         -- 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+     _ -> fail   where fail = genericDocError =<< text "Bad Haskell type:" <?> prettyTCM t -compileTypeArgs :: Args -> C [Hs.Type ()]-compileTypeArgs args = mapM (compileType . unArg) $ filter keepArg args +compileTypeArgs :: Type -> Args -> C [Hs.Type ()]+compileTypeArgs ty [] = pure []+compileTypeArgs ty (x:xs) = do+  (a, b) <- mustBePi ty+  reportSDoc "agda2hs.compile.type" 16 $ text "compileTypeArgs x =" <+> prettyTCM x+  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))+  compileDom a >>= \case+    DODropped -> rest+    DOInstance -> fail "Type-level instance argument not supported"+    DOType -> do+      (:) <$> compileType (unArg x) <*> rest+    DOTerm -> fail "Type-level term argument not supported"++compileTel :: Telescope -> C [Hs.Type ()]+compileTel EmptyTel = return []+compileTel (ExtendTel a tel) = compileDom a >>= \case+  DODropped  -> underAbstraction a tel compileTel+  DOInstance -> __IMPOSSIBLE__+  DOType     -> __IMPOSSIBLE__+  DOTerm     -> (:) <$> compileType (unEl $ unDom a) <*> underAbstraction a tel compileTel++-- Version of @compileTel@ that just computes the size,+-- and avoids compiling the types themselves.+compileTelSize :: Telescope -> C Int+compileTelSize EmptyTel = return 0+compileTelSize (ExtendTel a tel) = compileDom a >>= \case+  DODropped -> underAbstraction a tel compileTelSize+  DOInstance -> __IMPOSSIBLE__+  DOType -> __IMPOSSIBLE__+  DOTerm -> (1+) <$> underAbstraction a tel compileTelSize+ compileUnboxType :: QName -> Args -> C (Hs.Type ()) compileUnboxType r pars = do-  def <- theDef <$> getConstInfo r-  let tel = telToList $ recTel def `apply` pars-  case find keepArg tel of-    Nothing -> __IMPOSSIBLE__-    Just t -> compileType $ unEl $ snd (unDom t)+  def <- getConstInfo r+  let tel = recTel (theDef def) `apply` pars+  compileTel tel >>= \case+    [t] -> return t+    _   -> __IMPOSSIBLE__ -compileTransparentType :: Args -> C (Hs.Type ())-compileTransparentType args = compileTypeArgs args >>= \case-  []     -> __IMPOSSIBLE__+compileTupleType :: QName -> Hs.Boxed -> Args -> C (Hs.Type ())+compileTupleType r b pars = do+  tellUnboxedTuples b+  def <- getConstInfo r+  let tel = recTel (theDef def) `apply` pars+  ts <- compileTel tel+  return $ Hs.TyTuple () b ts++compileTransparentType :: Type -> Args -> C (Hs.Type ())+compileTransparentType ty args = compileTypeArgs ty args >>= \case   (v:vs) -> return $ v `tApp` vs+  []     -> __IMPOSSIBLE__ -compileDom :: ArgName -> Dom Type -> C CompiledDom-compileDom x a-  | usableModality a = case getHiding a of-      Instance{} -> DomConstraint . Hs.TypeA () <$> compileType (unEl $ unDom a)-      NotHidden  -> uncurry DomType <$> compileType' (unEl $ unDom a)-      Hidden     ->-        ifM (canErase $ unDom a)-            (return DomDropped)-            (genericDocError =<< do text "Implicit type argument not supported: " <+> prettyTCM x)-  | otherwise    = return DomDropped -compileTeleBinds :: Telescope -> C [Hs.TyVarBind ()]-compileTeleBinds tel =-  forM-    (mapMaybe-      (fmap unArgDom . checkArgDom)-      (teleArgNames tel `zip` flattenTel @Type tel))-    (uncurry compileKeptTeleBind)-  where-    checkArgDom (argName, argDom) | keepArg argName = Just (argName, argDom)-    checkArgDom _ | otherwise = Nothing+compileInlineType :: QName -> Elims -> C (Hs.Type ())+compileInlineType f args = do+  Function { funClauses = cs } <- theDef <$> getConstInfo f -    unArgDom (argName, argDom) = (hsName . unArg $ argName, unDom argDom)+  let [ Clause { namedClausePats = pats } ] = filter (isJust . clauseBody) cs +  when (length args < length pats) $ genericDocError =<<+    text "Cannot compile inlinable type alias" <+> prettyTCM f <+> text "as it must be fully applied."++  r <- liftReduce $ locallyReduceDefs (OnlyReduceDefs $ Set.singleton f)+                  $ unfoldDefinitionStep (Def f args) f args++  case r of+    YesReduction _ t -> compileType t+    _                -> genericDocError =<< text "Could not reduce inline type alias " <+> prettyTCM f+++data DomOutput = DOInstance | DODropped | DOType | DOTerm++compileDom :: Dom Type -> C DomOutput+compileDom a = do+  isErasable <- pure (not $ usableModality a) `or2M` canErase (unDom a)+  isClassConstraint <- pure (isInstance a) `and2M` isClassType (unDom a)+  isType <- endsInSort (unDom a)+  return $ if+    | isErasable        -> DODropped+    | isClassConstraint -> DOInstance+    | isType            -> DOType+    | otherwise         -> DOTerm++-- | Compile a function type domain.+-- A domain can either be:+--+-- - dropped if the argument is erased.+-- - added as a class constraint.+-- - added as a type parameter+-- - kept as a regular explicit argument.+compileDomType :: ArgName -> Dom Type -> C CompiledDom+compileDomType x a =+  compileDom a >>= \case+    DODropped  -> pure DomDropped+    DOInstance -> DomConstraint . Hs.TypeA () <$> compileType (unEl $ unDom a)+    DOType     -> do+      -- We compile (non-erased) type parameters to an explicit forall if they+      -- come from a module parameter or if we are in a nested position inside the type.+      reportSDoc "agda2hs.compile.type" 15 $ text "Compiling forall type:" <+> prettyTCM a+      isNested <- asks isNestedInType+      ctx <- getContextSize+      npars <- size <$> (lookupSection =<< currentModule)+      if+        | isNested -> do+          tellExtension Hs.RankNTypes+          -- tellExtension Hs.ExistentialQuantification+          return $ DomForall $ Hs.UnkindedVar () $ Hs.Ident () x+        | ctx < npars -> do+          tellExtension Hs.ScopedTypeVariables+          return $ DomForall $ Hs.UnkindedVar () $ Hs.Ident () x+        | otherwise -> return DomDropped+    DOTerm     -> fmap (uncurry DomType) . withNestedType . compileTypeWithStrictness . unEl $ unDom a++compileTeleBinds :: Telescope -> C [Hs.TyVarBind ()]+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))+  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"+ compileKeptTeleBind :: Hs.Name () -> Type -> C (Hs.TyVarBind ()) compileKeptTeleBind x t = do   checkValidTyVarName x-  case compileKind t of-    Just k              -> pure $ Hs.UnkindedVar () x -- In the future we may want to show kind annotations-    _                   -> genericDocError =<<-      text "Kind of bound argument not supported:"-      <+> parens (text (Hs.prettyPrint x) <> text " : " <> prettyTCM t)+  k <- compileKind t+  pure $ Hs.UnkindedVar () x -- In the future we may want to show kind annotations -compileKind :: Type -> Maybe (Hs.Kind ())+compileKind :: Type -> C (Hs.Kind ()) compileKind t = case unEl t of   Sort (Type _) -> pure (Hs.TyStar ())-  Pi a b-    | keepArg a    -> Hs.TyFun () <$> compileKind (unDom a) <*> compileKind (unAbs b)-    | otherwise    -> compileKind (unAbs b)-  _ -> Nothing     -- ^ if the argument is erased, we only compile the rest+  Pi a b -> compileDom a >>= \case+    DODropped -> underAbstraction a b compileKind+    DOType -> Hs.TyFun () <$> compileKind (unDom a) <*> underAbstraction a b compileKind+    DOTerm -> err+    DOInstance -> err+  _ -> err+  where+    err = genericDocError =<< text "Not a valid Haskell kind: " <+> prettyTCM t
src/Agda2Hs/Compile/TypeDefinition.hs view
@@ -10,22 +10,28 @@  import Agda.Syntax.Common ( namedArg ) import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern +import Agda.TypeChecking.Telescope ( mustBePi )+ import Agda.Utils.Impossible ( __IMPOSSIBLE__ ) import Agda.Utils.Monad -import Agda2Hs.Compile.Term ( compileVar )-import Agda2Hs.Compile.Type ( compileType )+import Agda2Hs.Compile.Type ( compileType, compileDom, DomOutput(..), compileTypeArgs ) 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 + compileTypeDef :: Hs.Name () -> Definition -> C [Hs.Decl ()] compileTypeDef name (Defn {..}) = do   unlessM (isTransparentFunction defName) $ checkValidTypeName name   Clause{..} <- singleClause funClauses   addContext (KeepNames clauseTel) $ do-    as <- compileTypeArgs namedClausePats+    as <- compileTypePatternArgs defType namedClausePats     let hd = foldl (Hs.DHApp ()) (Hs.DHead () name) as     rhs <- compileType $ fromMaybe __IMPOSSIBLE__ clauseBody     return [Hs.TypeDecl () hd rhs]@@ -35,12 +41,19 @@       [cl] -> return cl       _    -> genericError "Not supported: type definition with several clauses" -compileTypeArgs :: NAPs -> C [Hs.TyVarBind ()]-compileTypeArgs ps = mapM (compileTypeArg . namedArg) $ filter keepArg ps+compileTypePatternArgs :: Type -> NAPs -> C [Hs.TyVarBind ()]+compileTypePatternArgs ty naps = do+  aux <- compileTypeArgs ty $ fromMaybe __IMPOSSIBLE__ $ allApplyElims $ patternsToElims naps+  mapM assertIsTyVarBind aux+  where+    assertIsTyVarBind :: Hs.Type () -> C (Hs.TyVarBind ())+    assertIsTyVarBind = \case+      Hs.TyVar _ n -> pure $ Hs.UnkindedVar () n+      _ -> genericError "Not supported: type definition by pattern matching"  compileTypeArg :: DeBruijnPattern -> C (Hs.TyVarBind ()) compileTypeArg p@(VarP o i) = do-  name <- hsName <$> compileVar (dbPatVarIndex i)+  name <- hsName <$> compileDBVar (dbPatVarIndex i)   checkValidTyVarName name   return $ Hs.UnkindedVar () name compileTypeArg _ = genericError "Not supported: type definition by pattern matching"
src/Agda2Hs/Compile/Types.hs view
@@ -1,23 +1,29 @@-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} module Agda2Hs.Compile.Types where -import Control.Monad.Reader ( ReaderT )-import Control.Monad.Writer ( WriterT )-import Control.Monad.State ( StateT )+import Control.Applicative ( liftA2 )+import Control.Monad ( join )+import Control.Monad.Trans ( MonadTrans(lift) )+import Control.Monad.Trans.RWS.CPS (RWST(..), runRWST, rwsT )+import Control.Monad.Trans.Control (MonadTransControl(..))+import Control.Monad.State ( StateT(..) ) import Control.DeepSeq ( NFData(..) ) -import Data.Maybe ( fromMaybe, isJust )+import Data.Maybe ( isJust ) import Data.Set ( Set ) 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 ( Definition, QName, ModuleName, TCM )+import Agda.Compiler.Backend import Agda.Syntax.Position ( Range ) import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName )+import Agda.Utils.Null+import Agda.Utils.Impossible  import Agda2Hs.HsUtils ( Strictness ) @@ -64,31 +70,42 @@ instance NFData Options where   rnf _ = () +-- | Names of local declarations (in @where@ blocks).+type LocalDecls = [QName]+ data CompileEnv = CompileEnv   { currModule :: TopLevelModuleName   -- ^ the current module we are compiling   , minRecordName :: Maybe ModuleName   -- ^ keeps track of the current minimal record we are compiling+  , isNestedInType :: Bool+  -- ^ if we're inside an argument of a type and need an explicit forall   , locals :: LocalDecls   -- ^ keeps track of the current clause's where declarations+  , compilingLocal :: Bool+  -- ^ whether we are currently compiling a where clause or pattern-matching lambda+  , whereModules :: [ModuleName]+  -- ^ the where-blocks currently in scope. Hack until Agda adds where-prominence   , copatternsEnabled :: Bool   -- ^ whether copatterns should be allowed when compiling patterns-  , checkVar :: Bool-  -- ^ whether to ensure compiled variables are usable and visible   , rewrites :: SpecialRules   -- ^ Special compilation rules.+  , writeImports :: Bool+  -- ^ whether we should add imports of compiled names   }  type Qualifier = Maybe (Maybe (Hs.ModuleName ()))+ pattern Unqualified   = Nothing pattern QualifiedAs m = Just m +isQualified :: Qualifier -> Bool isQualified = isJust-qualifiedAs = fromMaybe Nothing -data CompilingCategory = ClassInstance | CaseOf | MonadicBind-  deriving Eq+qualifiedAs :: Qualifier -> Maybe (Hs.ModuleName ())+qualifiedAs = join +-- | Encoding of a Haskell module import statement. data Import = Import   { importModule    :: Hs.ModuleName ()   , importQualified :: Qualifier@@ -99,50 +116,100 @@                     -- 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)   }+ type Imports = [Import] +-- | Output produced during the compilation of a module data CompileOutput = CompileOutput   { imports :: Imports-  -- ^ Information we generate during compilation related to import statements.+  -- ^ Haskell import statements.   , haskellExtensions :: [Hs.KnownExtension]-  -- ^ Necessary language extensions to be automatically inserted.+  -- ^ Required language extensions.   }  instance Semigroup CompileOutput where   CompileOutput imps exts <> CompileOutput imps' exts' =-    CompileOutput (imps ++ imps') (exts ++ exts')+    CompileOutput (imps <> imps') (exts <> exts')  instance Monoid CompileOutput where-  mempty = CompileOutput [] []+  mempty = CompileOutput mempty mempty  -- | State used while compiling a single module.-data CompileState = CompileState+newtype CompileState = CompileState   { lcaseUsed :: Int-  -- ^ Keeps track of how many times we've used an extension.-  -- NB: can be removed by subsequent program transformations, hence the StateT.+    -- ^ How many @\case@ have been generated in the output Haskell code.+    --   Can be removed by subsequent program transformations, hence the StateT.   } -type C = StateT CompileState (ReaderT CompileEnv (WriterT CompileOutput TCM)) --- Currently we can compile an Agda "Dom Type" in three ways:--- - To a type in Haskell (with perhaps a strictness annotation)--- - To a typeclass constraint in Haskell--- - To nothing (e.g. for proofs)+-- NOTE: C should really be a newtype for abstraction's sake+--       but none of the Agda instances are defined for RWST(.CPS)++-- | Compilation monad.+type C = RWST CompileEnv CompileOutput CompileState TCM++-- some missing instances from the Agda side+instance HasFresh i => MonadFresh i C+instance MonadTCState C+instance Monoid w => MonadTransControl (RWST r w s) where+  type StT (RWST r w s) a = (a, s, w)+  liftWith f = rwsT $ \r s -> fmap (, s, mempty) (f $ \t -> runRWST t r s)+  restoreT mSt = rwsT $ \_ _ -> mSt+instance MonadTCEnv C+instance HasOptions C+instance ReadTCState C+instance MonadTCM C+instance MonadTrace C where+  traceClosureCall c f = rwsT $ \ r s -> traceClosureCall c $ runRWST f r s+instance MonadInteractionPoints C where+instance MonadDebug C where+instance HasConstInfo C where+instance MonadReduce C where+instance MonadAddContext C where+instance HasBuiltins C where+instance MonadBlock C where+  catchPatternErr h m = rwsT $ \ r s ->+    let run x = runRWST x r s in catchPatternErr (run . h) (run m)+instance MonadStConcreteNames C where+  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 IsString a => IsString (C a) where fromString = pure . fromString+instance PureTCM C where+instance Null a => Null (C a) where+  empty = lift empty+  null = __IMPOSSIBLE__+instance Semigroup a => Semigroup (C a) where (<>) = liftA2 (<>)++++-- | Agda @Dom Type@ can get compiled in three ways. data CompiledDom   = DomType Strictness (Hs.Type ())+    -- ^ To a Haskell type (with perhaps a strictness annotation)   | DomConstraint (Hs.Asst ())+    -- ^ To a typeclass constraint+  | DomForall (Hs.TyVarBind ())+    -- ^ To an explicit forall   | DomDropped--type LocalDecls = [QName]+    -- ^ To nothing (e.g. erased proofs) -data DataTarget = ToData | ToDataNewType+-- | Whether a datatype/record should be compiled as a @newtype@ haskell definition.+type AsNewType = Bool -data RecordTarget = ToRecord [Hs.Deriving ()] | ToRecordNewType [Hs.Deriving ()] | ToClass [String]+-- | Compilation target for an Agda record definition.+data RecordTarget+  = ToRecord AsNewType [Hs.Deriving ()]+  | ToClass [String] -data InstanceTarget = ToDefinition | ToDerivation (Maybe (Hs.DerivStrategy ()))+-- | Compilation target for an Agda instance declaration.+-- Either to an actual declaration, or a derived instance.+data InstanceTarget+  = ToDefinition+  | ToDerivation (Maybe (Hs.DerivStrategy ()))  -- Used when compiling imports. If there is a type operator, we can append a "type" namespace here.-data NamespacedName = NamespacedName { nnNamespace :: Hs.Namespace (),-                                       nnName      :: Hs.Name ()-                                     }-                      deriving (Eq, Ord)+data NamespacedName = NamespacedName+  { nnNamespace :: Hs.Namespace ()+  , nnName      :: Hs.Name ()+  } deriving (Eq, Ord)
src/Agda2Hs/Compile/Utils.hs view
@@ -1,6 +1,7 @@ module Agda2Hs.Compile.Utils where -import Control.Arrow ( Arrow((***)) )+import Control.Monad ( forM_ )+import Control.Arrow ( Arrow((***)), (&&&) ) import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Writer ( tell )@@ -29,7 +30,7 @@ import Agda.TypeChecking.Level ( isLevelType ) import Agda.TypeChecking.MetaVars ( newInstanceMeta ) import Agda.TypeChecking.Monad.SizedTypes ( isSizeType )-import Agda.TypeChecking.Pretty ( Doc, (<+>), text, PrettyTCM(..) )+import Agda.TypeChecking.Pretty ( Doc, (<+>), text, PrettyTCM(..), pretty ) import Agda.TypeChecking.Records ( isRecordConstructor, getRecordOfField ) import Agda.TypeChecking.Reduce ( instantiate, reduce ) import Agda.TypeChecking.Substitute ( Subst, TelV(TelV), Apply(..) )@@ -45,7 +46,21 @@ import Agda2Hs.Compile.Types import Agda2Hs.HsUtils import Agda2Hs.Pragma+import qualified Data.List as L+import Agda.Utils.Impossible ( __IMPOSSIBLE__ ) ++-- | Primitive modules provided by the agda2hs library.+-- None of those (and none of their children) will get processed.+primModules =+  [ "Agda.Builtin"+  , "Agda.Primitive"+  , "Haskell.Prim"+  , "Haskell.Prelude"+  , "Haskell.Law"+  ]++ concatUnzip :: [([a], [b])] -> ([a], [b]) concatUnzip = (concat *** concat) . unzip @@ -69,12 +84,13 @@ freshString s = liftTCM $ do   scope <- getScope   ctxNames <- map (prettyShow . nameConcrete) <$> getContextNames-  return $ head $ filter (isFresh scope ctxNames) $ s : map (\i -> s ++ show i) [0..]+  let freshName = L.uncons $ filter (isFresh scope ctxNames) $ s : map (\i -> s ++ show i) [0..]+  return (maybe __IMPOSSIBLE__ fst freshName)   where     dummyName s = C.QName $ C.Name noRange C.NotInScope $ singleton $ C.Id s     isFresh scope ctxNames s =       null (scopeLookup (dummyName s) scope :: [AbstractName]) &&-      not (s `elem` ctxNames)+      notElem s ctxNames  makeList :: C Doc -> Term -> C [Term] makeList = makeList' "Agda.Builtin.List.List.[]" "Agda.Builtin.List.List._∷_"@@ -113,24 +129,29 @@ underAbstr_ :: Subst a => Abs a -> (a -> C b) -> C b underAbstr_ = underAbstr __DUMMY_DOM__ --- Determine whether an argument should be kept or dropped.--- We drop all arguments that have quantity 0 (= run-time erased).--- We also drop hidden non-erased arguments (which should all be of--- type Level or Set l).-keepArg :: (LensHiding a, LensModality a) => a -> Bool-keepArg x = usableModality x && visible x+isPropSort :: Sort -> C Bool+isPropSort s = reduce s <&> \case+  Prop _ -> True+  _      -> False + -- Determine whether it is ok to erase arguments of this type, -- even in the absence of an erasure annotation. canErase :: Type -> C Bool canErase a = do   TelV tel b <- telView a   addContext tel $ orM-    [ isLevelType b-    , isJust <$> isSizeType b-    , ((isJust . isSort) <$> reduce (unEl b))+    [ isErasedBaseType (unEl b)+    , isPropSort (getSort b)            -- _ : Prop     ] +isErasedBaseType :: Term -> C Bool+isErasedBaseType x = orM+  [ isLevelType b                       -- Level+  , isJust <$> isSizeType b             -- Size+  ]+  where b = El __DUMMY_SORT__ x+ -- 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@@ -141,35 +162,33 @@   | null $ mnameToList m = return False   | otherwise            = do     minRec <- asks minRecordName-    getConstInfo' (mnameToQName m) >>= \case-      _ | Just m == minRec -> return True-      Right Defn{defName = r, theDef = Record{}} ->-        -- It would be nicer if we remembered this from when we looked at the record the first time.-        processPragma r <&> \case-          ClassPragma _       -> True-          ExistingClassPragma -> True-          _                   -> False-      _                             -> return False+    if Just m == minRec then return True else isClassName (mnameToQName m) +-- | Check if the given name corresponds to a type class in Haskell.+isClassName :: QName -> C Bool+isClassName q = getConstInfo' q >>= \case+  Right Defn{defName = r, theDef = Record{}} ->+    -- It would be nicer if we remembered this from when we looked at the record the first time.+    processPragma r <&> \case+      ClassPragma _       -> True+      ExistingClassPragma -> True+      _                   -> False+  _                       -> return False++-- | Check if the given type corresponds to a class constraint in Haskell.+isClassType :: Type -> C Bool+isClassType a = do+  TelV _ t <- telView a+  case unEl t of+    Def cl _ -> isClassName cl+    _        -> return False+ -- Drops the last (record) module for typeclass methods dropClassModule :: ModuleName -> C ModuleName dropClassModule m@(MName ns) = isClassModule m >>= \case   True  -> dropClassModule $ MName $ init ns   False -> return m -moduleParametersToDrop :: ModuleName -> C Telescope-moduleParametersToDrop mod = do-   reportSDoc "agda2hs.moduleParameters" 25 $ text "Getting telescope for" <+> prettyTCM mod-   isDatatypeModule mod >>= \case-     Just _ -> return EmptyTel-     Nothing -> do-       reportSDoc "agda2hs.moduleParameters" 25 $ text "Current context: " <+> (prettyTCM =<< getContext)-       ctxArgs <- getContextArgs-       reportSDoc "agda2hs.moduleParameters" 25 $ text "Context arguments: " <+> prettyTCM ctxArgs-       sec <- lookupSection mod-       reportSDoc "agda2hs.moduleParameters" 25 $ text "Module section: " <+> prettyTCM sec-       return $ sec `apply` ctxArgs- isUnboxRecord :: QName -> C (Maybe Strictness) isUnboxRecord q = do   getConstInfo q >>= \case@@ -187,42 +206,84 @@ isUnboxProjection q =   caseMaybeM (liftTCM $ getRecordOfField q) (return Nothing) isUnboxRecord +isTupleRecord :: QName -> C (Maybe Hs.Boxed)+isTupleRecord q = do+  getConstInfo q >>= \case+    Defn{defName = r, theDef = Record{}} ->+      processPragma r <&> \case+        TuplePragma b -> Just b+        _             -> Nothing+    _ -> return Nothing++isTupleConstructor :: QName -> C (Maybe Hs.Boxed)+isTupleConstructor q =+  caseMaybeM (isRecordConstructor q) (return Nothing) $ isTupleRecord . fst++isTupleProjection :: QName -> C (Maybe Hs.Boxed)+isTupleProjection q =+  caseMaybeM (liftTCM $ getRecordOfField q) (return Nothing) isTupleRecord+ isTransparentFunction :: QName -> C Bool isTransparentFunction q = do   getConstInfo q >>= \case     Defn{defName = r, theDef = Function{}} ->-      processPragma r <&> \case-        TransparentPragma -> True-        _                 -> False+      (TransparentPragma ==) <$> processPragma r     _ -> return False +isInlinedFunction :: QName -> C Bool+isInlinedFunction q = do+  getConstInfo q >>= \case+    Defn{defName = r, theDef = Function{}} ->+      (InlinePragma ==) <$> processPragma r+    _ -> return False+ checkInstance :: Term -> C ()-checkInstance u | varOrDef u = liftTCM $ noConstraints $ do-  reportSDoc "agda2hs.checkInstance" 5 $ text "checkInstance" <+> prettyTCM u-  t <- infer u-  reportSDoc "agda2hs.checkInstance" 15 $ text "  inferred type:" <+> prettyTCM t-  (m, v) <- newInstanceMeta "" t-  reportSDoc "agda2hs.checkInstance" 15 $ text "  instance meta:" <+> prettyTCM m-  findInstance m Nothing-  reportSDoc "agda2hs.checkInstance" 15 $ text "  inferred instance:" <+> (prettyTCM =<< instantiate v)-  reportSDoc "agda2hs.checkInstance" 65 $ text "  inferred instance:" <+> (pure . P.pretty =<< instantiate v)-  reportSDoc "agda2hs.checkInstance" 65 $ text "  checking instance:" <+> (pure . P.pretty =<< instantiate u)-  equalTerm t u v `catchError` \_ ->-    genericDocError =<< text "illegal instance: " <+> prettyTCM u+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-    varOrDef Var{} = True-    varOrDef Def{} = True-    varOrDef _     = False--- 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.-checkInstance u@(Con c _ _)-  | prettyShow (conName c) == "Agda.Builtin.Unit.tt" ||-    prettyShow (conName c) == "Haskell.Prim.IsTrue.itsTrue" ||-    prettyShow (conName c) == "Haskell.Prim.IsFalse.itsFalse" = return ()-checkInstance u = genericDocError =<< text "illegal instance: " <+> prettyTCM u+    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 }++compileLocal :: C a -> C a+compileLocal = local $ \e -> e { compilingLocal = True }++addWhereModule :: ModuleName  -> C a -> C a+addWhereModule mName = local $ \e -> e { whereModules = mName : whereModules e }+ modifyLCase :: (Int -> Int) -> CompileState -> CompileState modifyLCase f (CompileState {lcaseUsed = n}) = CompileState {lcaseUsed = f n} @@ -266,6 +327,10 @@ tellExtension :: Hs.KnownExtension -> C () tellExtension pr = tell $ CompileOutput [] [pr] +tellUnboxedTuples :: Hs.Boxed -> C ()+tellUnboxedTuples Hs.Boxed = return ()+tellUnboxedTuples Hs.Unboxed = tellExtension $ Hs.UnboxedTuples+ addPatBang :: Strictness -> Hs.Pat () -> C (Hs.Pat ()) addPatBang Strict p = tellExtension Hs.BangPatterns >>   return (Hs.PBangPat () p)@@ -280,5 +345,47 @@ checkSingleElement name fs s = unless (length fs == 1) $ genericDocError =<< do   text (s ++ ":") <+> text (Hs.prettyPrint name) -checkingVars :: C a -> C a-checkingVars = local $ \e -> e { checkVar = True }+checkNewtypeCon :: Hs.Name () -> [b] -> C ()+checkNewtypeCon name tys =+  checkSingleElement name tys "Newtype must have exactly one field in constructor"++checkFixityLevel :: QName -> FixityLevel -> C (Maybe Int)+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+    else pure (Just (round lvl))++maybePrependFixity :: QName -> Fixity -> C [Hs.Decl ()] -> C [Hs.Decl ()]+maybePrependFixity n f comp | f /= noFixity = do+  hsLvl <- checkFixityLevel n (fixityLevel f)+  let x = hsName $ prettyShow $ qnameName n+  let hsAssoc = case fixityAssoc f of+        NonAssoc   -> Hs.AssocNone ()+        LeftAssoc  -> Hs.AssocLeft ()+        RightAssoc -> Hs.AssocRight ()+  (Hs.InfixDecl () hsAssoc hsLvl [Hs.VarOp () x]:) <$> comp+maybePrependFixity n f comp = comp+++checkNoAsPatterns :: DeBruijnPattern -> C ()+checkNoAsPatterns = \case+    VarP i _ -> checkPatternInfo i+    DotP i _ -> checkPatternInfo i+    ConP _ cpi ps -> do+      checkPatternInfo $ conPInfo cpi+      forM_ ps $ checkNoAsPatterns . namedArg+    LitP i _ -> checkPatternInfo i+    ProjP{} -> return ()+    IApplyP i _ _ _ -> checkPatternInfo i+    DefP i _ ps -> do+      checkPatternInfo i+      forM_ ps $ checkNoAsPatterns . namedArg+  where+    checkPatternInfo :: PatternInfo -> C ()+    checkPatternInfo i = unless (null $ patAsNames i) $+      genericDocError =<< text "not supported by agda2hs: as patterns"++noWriteImports :: C a -> C a+noWriteImports = local $ \e -> e { writeImports = False }
+ src/Agda2Hs/Compile/Var.hs view
@@ -0,0 +1,22 @@+module Agda2Hs.Compile.Var where++import Control.Arrow ( (&&&) )+import Control.Monad ( unless )+import Control.Monad.Reader.Class ( asks )++import Agda2Hs.Compile.Types+import Agda.Syntax.Common+import Agda.Syntax.Internal ( unDom )+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.Context ( lookupBV )+import Agda.Utils.Monad ( whenM )+++-- | Compile a variable.+compileDBVar :: Nat -> C String+compileDBVar x = do+  (d, n) <- (fmap snd &&& fst . unDom) <$> lookupBV x+  return $ prettyShow $ nameConcrete n
src/Agda2Hs/HsUtils.hs view
@@ -17,6 +17,8 @@ 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 ------------------------------------------------------------------ @@ -199,7 +201,7 @@  srcSpanToRange :: SrcSpan -> Range srcSpanToRange (SrcSpan file l1 c1 l2 c2) =-  intervalToRange (toStrict $ Just $ mkRangeFile (mkAbsolute file) Nothing) $ Interval (pos l1 c1) (pos 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@@ -219,16 +221,25 @@  -- 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 (InfixApp l e1 op e2) = InfixApp l (parL e1) op (parR e2)+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-    topFix    = getFix op      qopName (QVarOp _ x) = x     qopName (QConOp _ x) = x@@ -241,14 +252,25 @@     needParen _ Nothing _ = True  -- If we don't know, add parens     needParen _ _ Nothing = True -    parL = par $ needParen (AssocLeft () /=)-    parR = par $ needParen (AssocRight () /=)+    needParenExpr (InfixApp _ _ _ e2) = needParenExpr e2+    needParenExpr Lambda{} = True+    needParenExpr _ = False -    par need e@(InfixApp _ _ op _)-      | need topFix (getFix op) = Paren () e-    par _ e = e-insertPars _ e = e+    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@@ -266,5 +288,29 @@   PBangPat _ p        -> patToExp p   _                   -> Nothing + data Strictness = Lazy | Strict-  deriving Show+  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
src/Agda2Hs/Pragma.hs view
@@ -48,14 +48,16 @@  data ParsedPragma   = NoPragma+  | InlinePragma   | DefaultPragma [Hs.Deriving ()]   | ClassPragma [String]   | ExistingClassPragma   | UnboxPragma Strictness   | TransparentPragma   | NewTypePragma [Hs.Deriving ()]+  | TuplePragma Hs.Boxed   | DerivePragma (Maybe (Hs.DerivStrategy ()))-  deriving Show+  deriving (Eq, Show)  derivePragma :: String derivePragma = "derive"@@ -69,13 +71,13 @@ newtypePragma :: String newtypePragma = "newtype" -processDeriving :: String -> ([Hs.Deriving ()] -> ParsedPragma) -> C ParsedPragma-processDeriving d pragma =+processDeriving :: Range -> String -> ([Hs.Deriving ()] -> ParsedPragma) -> C ParsedPragma+processDeriving r d pragma = do   -- parse a deriving clause for a datatype by tacking it onto a   -- dummy datatype and then only keeping the deriving part   case Hs.parseDecl ("data X = X " ++ d) of-    Hs.ParseFailed loc msg ->-      setCurrentRange (srcLocToRange loc) $ genericError msg+    Hs.ParseFailed loc msg -> do+      setCurrentRange r $ genericError msg     Hs.ParseOk (Hs.DataDecl _ _ _ _ _ ds) ->       return $ pragma (map (() <$) ds)     Hs.ParseOk _ -> return $ pragma []@@ -83,15 +85,18 @@ processPragma :: QName -> C ParsedPragma processPragma qn = liftTCM (getUniqueCompilerPragma pragmaName qn) >>= \case   Nothing -> return NoPragma-  Just (CompilerPragma _ s)+  Just (CompilerPragma r s)     | "class" `isPrefixOf` s      -> return $ ClassPragma (words $ drop 5 s)+    | s == "inline"               -> return InlinePragma     | s == "existing-class"       -> return ExistingClassPragma     | s == "unboxed"              -> return $ UnboxPragma Lazy     | s == "unboxed-strict"       -> return $ UnboxPragma Strict     | s == "transparent"          -> return TransparentPragma+    | s == "tuple"                -> return $ TuplePragma Hs.Boxed+    | s == "unboxed-tuple"        -> return $ TuplePragma Hs.Unboxed     | s == newtypePragma          -> return $ NewTypePragma []     | s == derivePragma           -> return $ DerivePragma Nothing     | derivePragma `isPrefixOf` s -> return $ DerivePragma (parseStrategy (drop (length derivePragma + 1) s))-    | "deriving"   `isPrefixOf` s -> processDeriving s DefaultPragma-    | (newtypePragma ++ " deriving") `isPrefixOf` s -> processDeriving (drop (length newtypePragma + 1) s) NewTypePragma+    | "deriving"   `isPrefixOf` s -> processDeriving r s DefaultPragma+    | (newtypePragma ++ " deriving") `isPrefixOf` s -> processDeriving r (drop (length newtypePragma + 1) s) NewTypePragma   _ -> return $ DefaultPragma []
src/Agda2Hs/Render.hs view
@@ -19,7 +19,7 @@ import qualified Language.Haskell.Exts.Extension as Hs  import Agda.Compiler.Backend-import Agda.Compiler.Common ( curIF, compileDir )+import Agda.Compiler.Common ( compileDir )  import Agda.TypeChecking.Pretty import qualified Agda.Syntax.Concrete.Name as C@@ -32,6 +32,7 @@ import Agda2Hs.Compile import Agda2Hs.Compile.Types import Agda2Hs.Compile.Imports+import Agda2Hs.Compile.Utils ( primModules ) import Agda2Hs.HsUtils import Agda2Hs.Pragma ( getForeignPragmas ) @@ -75,11 +76,6 @@   outDir <- compileDir   return $ fromMaybe outDir (optOutDir opts) </> moduleNameToFileName name "hs" -moduleSetup :: Options -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile ModuleEnv ModuleRes)-moduleSetup _ _ m _ = do-  reportSDoc "agda2hs.compile" 3 $ text "Compiling module: " <+> prettyTCM m-  setScope . iInsideScope =<< curIF-  return $ Recompile m  ensureDirectory :: FilePath -> IO () ensureDirectory = createDirectoryIfMissing True . takeDirectory
src/Main.hs view
@@ -21,33 +21,35 @@ import Agda2Hs.Compile.Types import Agda2Hs.Render -import Paths_agda2hs ( version )+import Paths_agda2hs ( version, getDataFileName ) ++-- | Agda2Hs default config defaultOptions :: Options defaultOptions = Options-  { optIsEnabled = True-  , optOutDir = Nothing+  { optIsEnabled  = True+  , optOutDir     = Nothing   , optConfigFile = Nothing   , optExtensions = []-  , optPrelude = PreludeOpts False Nothing []+  , optPrelude    = PreludeOpts False Nothing []     -- by default the Prelude is imported explicitly-  , optRewrites = defaultSpecialRules+  , optRewrites   = defaultSpecialRules   } -disableOpt :: Monad m => Options -> m Options-disableOpt opts = return opts{ optIsEnabled = False } -outdirOpt :: Monad m => FilePath -> Options -> m Options-outdirOpt dir opts = return opts{ optOutDir = Just dir }+disableOpt :: Flag Options+disableOpt opts = return opts { optIsEnabled = False } -configOpt :: Monad m => FilePath -> Options -> m Options-configOpt src opts = return opts{optConfigFile = Just src}+outdirOpt :: FilePath -> Flag Options+outdirOpt dir opts = return opts { optOutDir = Just dir } -extensionOpt :: Monad m => String -> Options -> m Options-extensionOpt ext opts = return opts{ optExtensions = Hs.parseExtension ext : optExtensions opts }+configOpt :: FilePath -> Flag Options+configOpt src opts = return opts { optConfigFile = Just src } --- | Update options by reading the config, if any was specified.+extensionOpt :: String -> Flag Options+extensionOpt ext opts = return opts { optExtensions = Hs.parseExtension ext : optExtensions opts } + backend :: Backend' Options Options ModuleEnv ModuleRes (CompiledDef, CompileOutput) backend = Backend'   { backendName           = "agda2hs"@@ -55,23 +57,27 @@   , options               = defaultOptions   , commandLineFlags      =       [ Option ['d'] ["disable-backend"] (NoArg disableOpt)-        "Disable backend and fall back to vanilla Agda behaviour, without compilation (important for Emacs mode). Implied when run in interactive mode (with --interactive, --interaction or --interaction-json)."+          "Disable backend and fall back to vanilla Agda behaviour, \+          \without compilation (important for Emacs mode). \+          \Implied when run in interactive mode (with --interactive, --interaction or --interaction-json)."       , Option ['o'] ["out-dir"] (ReqArg outdirOpt "DIR")-        "Write Haskell code to DIR. (default: project root)"+          "Write Haskell code to DIR. (default: project root)"       , Option ['X'] [] (ReqArg extensionOpt "EXTENSION")-        "Enable Haskell language EXTENSION. Affects parsing of Haskell code in FOREIGN blocks."+          "Enable Haskell language EXTENSION. Affects parsing of Haskell code in FOREIGN blocks."       , Option [] ["config"] (ReqArg configOpt "FILE")-        "Provide additional configuration to agda2hs with a YAML file."+          "Provide additional configuration to agda2hs with a YAML file."       ]   , isEnabled             = optIsEnabled   , preCompile            = checkConfig   , postCompile           = \ _ _ _ -> return ()   , preModule             = moduleSetup-  , postModule            = writeModule+  , postModule            = verifyAndWriteModule   , compileDef            = compile   , scopeCheckingSuffices = False   , mayEraseType          = \ _ -> return True   }+  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@@ -81,8 +87,15 @@   return $ not $ null i  main = do-  -- Issue #201: disable backend when run in interactive mode-  isInt <- isInteractive-  if isInt-    then runAgda [Backend backend{isEnabled = const False}]-    else runAgda [Backend backend]+  args <- getArgs++  -- Issue #370: `agda2hs locate` will print out the path to the prelude agda-lib file+  if args == ["locate"] then+    putStrLn =<< getDataFileName "agda2hs.agda-lib"+  else do+    -- Issue #201: disable backend when run in interactive mode+    isInt <- isInteractive++    if isInt+      then runAgda [Backend backend{isEnabled = const False}]+      else runAgda [Backend backend]