├── Setup.hs ├── shell.nix ├── src ├── Data │ ├── Functor │ │ ├── Fix.v │ │ ├── Const.v │ │ ├── Kan.v │ │ ├── Identity.v │ │ ├── Contravariant.v │ │ ├── Container.v │ │ └── Yoneda.v │ ├── Ord.v │ ├── Monoid.v │ ├── Eq.v │ ├── Semigroup.v │ ├── Foldable.v │ ├── Traversable.v │ ├── Functor.v │ ├── List │ │ └── Church.v │ ├── IntSet.v │ ├── Either.v │ ├── Tuple.v │ ├── Maybe.v │ ├── IntMap.v │ └── NonEmpty.v ├── Ssr.v ├── Control │ ├── Monad │ │ ├── Base.v │ │ ├── Trans │ │ │ ├── Class.v │ │ │ ├── Reader.v │ │ │ ├── LogicT.v │ │ │ ├── Free.v │ │ │ ├── Control.v │ │ │ ├── State.v │ │ │ ├── Either.v │ │ │ └── FiatState.v │ │ ├── Fix.v │ │ ├── Morph.v │ │ ├── Cont.v │ │ ├── State.v │ │ ├── Eff.v │ │ ├── EffPlain.v │ │ ├── Freer.v │ │ └── Free.v │ ├── Comonad.v │ ├── Impl.v │ ├── Lens.v │ ├── Compose.v │ ├── Applicative.v │ └── Monad.v ├── Extract.v ├── Prelude.v ├── Ltac.v └── Haskell.v ├── check ├── .gitignore ├── .github └── workflows │ └── coq-ci.yml ├── research ├── Basics.v ├── Monad.v ├── Endo.v └── Conduit.v ├── Makefile ├── fixcode.pl ├── README.md ├── coq-haskell.opam ├── _CoqProject ├── default.nix ├── haskell └── Hask │ ├── Coq.hs │ └── Utils.hs ├── coq-haskell.cabal ├── LICENSE ├── test ├── Extracted.hs └── Transfer.hs └── doc └── coq-typeclasses-debugging.txt /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | args@{ version ? "coq-haskell_8_15", pkgs ? null }: 2 | (import ./default.nix args).${version} 3 | -------------------------------------------------------------------------------- /src/Data/Functor/Fix.v: -------------------------------------------------------------------------------- 1 | Generalizable All Variables. 2 | Set Primitive Projections. 3 | Set Universe Polymorphism. 4 | Unset Transparent Obligations. 5 | 6 | Definition Fix (f : Type -> Type) := 7 | forall r, (forall x, (x -> r) -> f x -> r) -> r. 8 | -------------------------------------------------------------------------------- /check: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | docker run -t coqorg/coq:dev bash -c ' 4 | git clone https://github.com/jwiegley/coq-haskell; 5 | cd coq-haskell; 6 | opam update; 7 | opam pin add -n -y -k path coq-haskell .; 8 | opam install -y -v -j 2 coq-haskell --deps-only; 9 | opam install -y -v -j 2 coq-haskell 10 | ' 11 | 12 | wait 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.d 2 | *.glob 3 | *.vio 4 | *.vo 5 | *.vok 6 | *.vos 7 | .*.aux 8 | .coq-native/ 9 | .lia.cache 10 | /Applicative.hs 11 | /Comonad.hs 12 | /Datatypes.hs 13 | /Free.hs 14 | /Functor.hs 15 | /Identity.hs 16 | /Ltac.hs 17 | /Makefile.bak 18 | /Makefile.coq 19 | /Makefile.coq.conf 20 | /Maybe.hs 21 | /Monad.hs 22 | /Monoid.hs 23 | /Prelude0.hs 24 | /Semigroup.hs 25 | /State.hs 26 | /State0.hs 27 | /Tuple.hs 28 | /Yoneda.hs 29 | /extract 30 | -------------------------------------------------------------------------------- /src/Data/Ord.v: -------------------------------------------------------------------------------- 1 | Require Export Hask.Data.Eq. 2 | 3 | Generalizable All Variables. 4 | 5 | Inductive Ordering := LT | EQ | GT. 6 | 7 | Class Ord (A : Type) `{Eq A} := { 8 | compare : A -> A -> Ordering; 9 | ltb : A -> A -> bool; 10 | lteb : A -> A -> bool; 11 | gtb : A -> A -> bool; 12 | gteb : A -> A -> bool; 13 | max : A -> A -> A; 14 | min : A -> A -> A 15 | }. 16 | 17 | Infix "<" := ltb (at level 70). 18 | Infix "<=" := lteb (at level 70). 19 | Infix ">" := gtb (at level 70). 20 | Infix ">=" := gteb (at level 70). 21 | -------------------------------------------------------------------------------- /src/Data/Functor/Const.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Data.Functor. 2 | Require Import Hask.Data.Functor.Contravariant. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | Definition Const (c a : Type) := c. 10 | 11 | #[export] 12 | Program Instance Const_Functor (c : Type) : Functor (Const c) := { 13 | fmap := fun _ _ _ => id 14 | }. 15 | 16 | #[export] 17 | Program Instance Const_Contravariant (c : Type) : Contravariant (Const c) := { 18 | contramap := fun _ _ _ => id 19 | }. 20 | -------------------------------------------------------------------------------- /src/Data/Monoid.v: -------------------------------------------------------------------------------- 1 | Require Export Hask.Data.Semigroup. 2 | Require Import Hask.Prelude. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | Class Monoid (m : Type) := { 10 | is_semigroup :> Semigroup m; 11 | 12 | mempty : m; 13 | 14 | mempty_left : forall a, mappend mempty a = a; 15 | mempty_right : forall a, mappend a mempty = a; 16 | }. 17 | 18 | #[export] 19 | Program Instance Monoid_option `{Monoid a} : Monoid (option a) := { 20 | mempty := None 21 | }. 22 | Next Obligation. destruct a0; reflexivity. Qed. 23 | -------------------------------------------------------------------------------- /src/Data/Eq.v: -------------------------------------------------------------------------------- 1 | Generalizable All Variables. 2 | Set Primitive Projections. 3 | 4 | Class Eq (A : Type) := { 5 | eqb : A -> A -> bool; 6 | neqb : A -> A -> bool; 7 | 8 | eqb_refl x : eqb x x = true; 9 | eqb_sym x y : eqb x y = eqb y x; 10 | eqb_trans {x y z} : eqb x y = true -> eqb y z = true -> eqb x z = true; 11 | 12 | eqb_eq {x y} : eqb x y = true -> x = y; 13 | }. 14 | 15 | Infix "==" := eqb (at level 70). 16 | Infix "/=" := neqb (at level 70). 17 | 18 | Lemma eqb_neq `{Eq A} {x y} : eqb x y = false -> x <> y. 19 | Proof. 20 | repeat intro; subst. 21 | pose proof (eqb_refl y). 22 | rewrite H0 in H1. 23 | inversion H1. 24 | Qed. 25 | -------------------------------------------------------------------------------- /.github/workflows/coq-ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | strategy: 9 | matrix: 10 | image: 11 | - 'coqorg/coq:dev' 12 | - 'coqorg/coq:8.16' 13 | - 'coqorg/coq:8.15' 14 | - 'coqorg/coq:8.14' 15 | fail-fast: false 16 | steps: 17 | - uses: actions/checkout@v2 18 | - uses: coq-community/docker-coq-action@v1 19 | with: 20 | opam_file: 'coq-haskell.opam' 21 | custom_image: ${{ matrix.image }} 22 | 23 | # See also: 24 | # https://github.com/coq-community/docker-coq-action#readme 25 | # https://github.com/erikmd/docker-coq-github-action-demo 26 | -------------------------------------------------------------------------------- /src/Ssr.v: -------------------------------------------------------------------------------- 1 | From Coq Require Export 2 | ssreflect 3 | ssrfun 4 | ssrbool. 5 | 6 | Lemma and_swap : forall x y z, [&& x, y & z] = [&& y, x & z]. 7 | Proof. by case; case; case. Qed. 8 | 9 | Definition decide {T : Type} (H : bool) 10 | (kt : (H = true) -> T) 11 | (kf : (H = false) -> T) : T := 12 | (fun (if_true : (fun b : bool => protect_term (H = b) -> T) true) 13 | (if_false : (fun b : bool => protect_term (H = b) -> T) false) => 14 | if H as b return ((fun b0 : bool => protect_term (H = b0) -> T) b) 15 | then if_true 16 | else if_false) 17 | (fun (E : H = true) => kt E) 18 | (fun (E : H = false) => kf E) 19 | (erefl H). 20 | 21 | Arguments decide {T} H kt kf. 22 | 23 | Definition prop (b : bool) : option (is_true b) := 24 | if b then Some is_true_true else None. 25 | -------------------------------------------------------------------------------- /research/Basics.v: -------------------------------------------------------------------------------- 1 | Require Export FunctionalExtensionality. 2 | 3 | Set Primitive Projection. 4 | 5 | Axiom propositional_extensionality : forall P : Prop, P -> P = True. 6 | Axiom propositional_extensionality_rev : forall P : Prop, P = True -> P. 7 | Axiom proof_irrelevance : forall (P : Prop) (u v : P), u = v. 8 | 9 | (* Commonly occurring patterns that can now be solved with 'auto'. *) 10 | #[export] Hint Extern 4 (?A = ?A) => reflexivity : core. 11 | #[export] Hint Extern 7 (?X = ?Z) => 12 | match goal with 13 | | [H : ?X = ?Y, H' : ?Y = ?Z |- ?X = ?Z] => transitivity Y 14 | end : core. 15 | 16 | Ltac simple_solver := 17 | intros; 18 | try extensionality e; 19 | compute; 20 | repeat ( 21 | match goal with 22 | | [ |- context f [match ?X with _ => _ end] ] => 23 | is_var X; destruct X; auto 24 | end); 25 | auto. 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | MISSING = \ 2 | find . -name '*.v' \ 3 | ! -name Notes.v \ 4 | ! -name Extract.v \ 5 | ! -name CpdtTactics.v \ 6 | ! -name '*2.v' | \ 7 | xargs egrep -i -Hn '(Fail|abort|admit|undefined)' | \ 8 | egrep -v 'Definition undefined' | \ 9 | egrep -v '(old|new|research)/' 10 | 11 | all: Makefile.coq 12 | @+$(MAKE) -f Makefile.coq all 13 | -@$(MISSING) || exit 0 14 | 15 | clean: Makefile.coq 16 | @+$(MAKE) -f Makefile.coq clean 17 | 18 | fullclean: Makefile.coq 19 | @+$(MAKE) -f Makefile.coq cleanall 20 | rm -f Makefile.coq Makefile.coq.conf 21 | 22 | Makefile.coq: _CoqProject 23 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 24 | 25 | force _CoqProject Makefile: ; 26 | 27 | %: Makefile.coq force 28 | @+$(MAKE) -f Makefile.coq $@ 29 | 30 | .PHONY: all clean fullclean force 31 | -------------------------------------------------------------------------------- /src/Data/Semigroup.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Data.Maybe. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | Class Semigroup (m : Type) := { 10 | mappend : m -> m -> m; 11 | 12 | mappend_assoc : forall a b c, mappend a (mappend b c) = mappend (mappend a b) c; 13 | }. 14 | 15 | Arguments mappend {m _} _ _. 16 | 17 | Infix "⨂" := mappend (at level 41, right associativity). 18 | 19 | Definition Maybe_append `{Semigroup a} (x y : Maybe a) : Maybe a := 20 | match x, y with 21 | | Nothing, x => x 22 | | x, Nothing => x 23 | | Just x, Just y => Just (x ⨂ y) 24 | end. 25 | 26 | #[export] 27 | Program Instance Semigroup_Maybe `{Semigroup a} : Semigroup (Maybe a) := { 28 | mappend := Maybe_append 29 | }. 30 | Next Obligation. 31 | destruct a0, b, c; simpl; try reflexivity. 32 | now rewrite mappend_assoc. 33 | Qed. 34 | -------------------------------------------------------------------------------- /fixcode.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | while (<>) { 4 | s/import qualified (.*)/import qualified Hask.\1 as \1/; 5 | s/import qualified Hask\.GHC/import qualified GHC/; 6 | s{import qualified Hask\.Prelude as Prelude}{ 7 | import Debug.Trace (trace, traceShow) 8 | import qualified Data.List 9 | import qualified Prelude 10 | }; 11 | 12 | s/unsafeCoerce :: a -> b/--unsafeCoerce :: a -> b/; 13 | s/module (.+?) where/module Hask.\1 where/; 14 | # s/module Hask..+?.Utils where/module Hask.Utils where/; 15 | 16 | # Sometimes when generating type synonyms, the extraction mechanism will 17 | # inexplicably flip type arguments. We undo these bugs here. 18 | s/o -> Prelude.Either a \(\(,\) errType i\)/i -> Prelude.Either errType ((,) a o)/; 19 | s/a -> \(,\) i o/i -> (,) a o/; 20 | 21 | s/data Coq_simpl_fun/newtype Coq_simpl_fun/; 22 | s/_Hask__//g; s/Hask__//g; 23 | 24 | s/\(,\) \(\(Prelude\.succ\) \(\(Prelude\.succ\) \(unsafeCoerce n\)\)\)/(,) ((Prelude.succ) ((Prelude.succ) (unsafeCoerce n :: Prelude.Int)))/; 25 | 26 | print; 27 | } 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | coq-haskell 2 | =========== 3 | 4 | This library is designed for Haskell users who are either using Coq to build 5 | code intended for extraction to Haskell, or who wish to prototype/prove their 6 | algorithms in Coq. It provides a collection of definitions and notations to 7 | make Gallina more familiar to Haskellers. 8 | 9 | It is based on the ssreflect library, and avoids most uses of the Coq standard 10 | library (except for the `StronglySorted` type). Wherever possible, Haskell 11 | named functions and types are simply aliases for their Coq equivalents, to 12 | facilitate interaction with other Coq users. This means, for example, that one 13 | should use `a + b` with constructors named `inl` and `inr`. 14 | 15 | Thus, the aim is not to make Coq look exactly like Haskell, but only to smooth 16 | the divide. 17 | 18 | This library also allows the use of Haskell Monads within Coq developments, 19 | with one caveat: In order to satisfy the extraction machinery, entry-points on 20 | the Coq side (as well as calls back) must use `Yoneda m a` rather than simply 21 | `m a`, since the latter fully erases the `a` type. 22 | -------------------------------------------------------------------------------- /src/Data/Functor/Kan.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Ltac. 2 | Require Import Hask.Data.Functor. 3 | Require Import Hask.Data.Functor.Contravariant. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | (* Left and Right Kan extensions *) 11 | 12 | Definition Lan (f g : Type -> Type) (a : Type) := 13 | { e : Type & ((f e -> a) * g e)%type }. 14 | 15 | (* As with any data structure, we can provide its final encoding. *) 16 | Definition Lan_final (f g : Type -> Type) (a : Type) := 17 | forall r, (forall x : Type, (f x -> a) -> g x -> r) -> r. 18 | 19 | Axiom Lan_final_parametricity : 20 | forall a b c f g 21 | (k : Lan_final f g a) 22 | (h : forall x : Type, (f x -> a) -> g x -> b) 23 | (x : b -> c), 24 | x (k b h) = k c (fun e n z => x (h e n z)). 25 | 26 | Definition Ran (f g : Type -> Type) (a : Type) := 27 | forall r, (a -> f r) -> g r. 28 | 29 | Axiom Ran_parametricity : 30 | forall a b c `{Functor f} `{Functor g} 31 | (k : Ran f g a) (g : b -> c) (h : a -> f b), 32 | fmap g (k _ h) = k _ (fmap g \o h). 33 | -------------------------------------------------------------------------------- /coq-haskell.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "johnw@newartisans.com" 3 | 4 | homepage: "https://github.com/jwiegley/coq-haskell" 5 | dev-repo: "git+https://github.com/jwiegley/coq-haskell.git" 6 | bug-reports: "https://github.com/jwiegley/coq-haskell/issues" 7 | license: "BSD-3-Clause" 8 | 9 | synopsis: "A library to provide Haskell-familiar constructions in Coq" 10 | description: """ 11 | This library is designed for Haskell users who are either using Coq to build 12 | code intended for extraction to Haskell, or who wish to prototype/prove their 13 | algorithms in Coq. It provides a collection of definitions and notations to 14 | make Gallina more familiar to Haskellers. 15 | """ 16 | 17 | build: [make "-j%{jobs}%"] 18 | install: [make "install"] 19 | depends: [ 20 | "coq" {(>= "8.14" & < "8.17~") | (= "dev")} 21 | ] 22 | 23 | url { 24 | src: "https://github.com/jwiegley/coq-haskell/archive/refs/tags/1.1.tar.gz" 25 | checksum: "sha256=66243d54a6ff551a9ec762d69e5ff6a09869e7d5ce6504fa3a63350efde03720" 26 | } 27 | 28 | authors: [ 29 | "John Wiegley" 30 | ] 31 | 32 | tags: [ 33 | "keyword:haskell" 34 | "category:Miscellaneous/Coq Extensions" 35 | "date:2022-07-22" 36 | "logpath:Hask" 37 | ] 38 | -------------------------------------------------------------------------------- /src/Control/Monad/Base.v: -------------------------------------------------------------------------------- 1 | (* Require Import Data.Functor.Identity. *) 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Control.Monad.Trans.State. 4 | 5 | Generalizable All Variables. 6 | Unset Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | Class FunDep {T : Type} (m1 m2 : T). 11 | 12 | Class MonadBase (b : Type -> Type) `{Monad b} (m : Type -> Type) `{Monad m} 13 | `{FunDep (Type -> Type) m b} := { 14 | liftBase : forall a, b a -> m a 15 | }. 16 | Arguments liftBase {b _ m _ _ _ a} _. 17 | 18 | (* #[export] *) 19 | (* Instance FunDep_Id_Id : FunDep Identity Identity. *) 20 | 21 | (* #[export] *) 22 | (* Instance MonadBase_Id_Id : MonadBase Identity Identity := { *) 23 | (* liftBase := @id *) 24 | (* }. *) 25 | 26 | #[export] 27 | Program Instance StateT_m_b {s : Type} {m b : Type -> Type} 28 | `{FunDep (Type -> Type) m b} : 29 | FunDep (StateT s m) b. 30 | 31 | #[export] 32 | Instance MonadBase_StateT {s : Type} {m b : Type -> Type} 33 | `{B : MonadBase b m} : MonadBase b (StateT s m) := { 34 | liftBase := fun A x st => 35 | res <- liftBase x; 36 | @pure m _ (A * s) (res, st) 37 | }. 38 | -------------------------------------------------------------------------------- /src/Data/Foldable.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Ltac. 2 | Require Import Hask.Data.Functor. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | Class Foldable (t : Type -> Type) := { 10 | foldr : forall a b, (a -> b -> b) -> b -> t a -> b 11 | }. 12 | 13 | Arguments foldr {t _ a b} _ _ _. 14 | 15 | Axiom foldr_parametricity : 16 | forall `{Foldable t} `{Functor t} 17 | A B (f : A -> B -> B) (u : B) 18 | A' B' (g : A' -> B' -> B') (u' : B') 19 | (a : A -> A') (b : B -> B'), 20 | b u = u' 21 | -> (forall x y, b (f x y) = g (a x) (b y)) 22 | -> b \o @foldr t _ A B f u = @foldr t _ A' B' g u' \o fmap a. 23 | 24 | Import FunctorLaws. 25 | 26 | Theorem foldr_fmap_fusion `{Foldable t} `{FunctorLaws t} : 27 | forall A B (f : A -> B -> B) C (g : C -> A) (z : B) (xs : t C), 28 | foldr f z (fmap g xs) = foldr (f \o g) z xs. 29 | Proof. 30 | intros. 31 | pose proof (foldr_parametricity C B (f \o g) z A B f z g id 32 | eq_refl (fun _ _ => eq_refl)). 33 | replace (foldr f z (fmap[ t] g xs)) 34 | with ((foldr f z \o fmap[ t] g) xs) by trivial. 35 | rewrite <- H2. 36 | reflexivity. 37 | Qed. -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R src Hask 2 | src/Control/Applicative.v 3 | src/Control/Category.v 4 | src/Control/Comonad.v 5 | src/Control/Compose.v 6 | src/Control/Impl.v 7 | src/Control/Lens.v 8 | src/Control/Monad.v 9 | src/Control/Monad/Base.v 10 | src/Control/Monad/Cont.v 11 | src/Control/Monad/Fix.v 12 | src/Control/Monad/Free.v 13 | src/Control/Monad/Freer.v 14 | src/Control/Monad/Indexed.v 15 | src/Control/Monad/Morph.v 16 | src/Control/Monad/State.v 17 | src/Control/Monad/Trans/Class.v 18 | src/Control/Monad/Trans/Control.v 19 | src/Control/Monad/Trans/Either.v 20 | src/Control/Monad/Trans/Free.v 21 | src/Control/Monad/Trans/LogicT.v 22 | src/Control/Monad/Trans/State.v 23 | src/Control/Monad/Trans/FiatState.v 24 | src/Control/Monad/Trans/Reader.v 25 | src/Crush.v 26 | src/Data/Either.v 27 | src/Data/Eq.v 28 | src/Data/Ord.v 29 | src/Data/Functor.v 30 | src/Data/Functor/Const.v 31 | src/Data/Functor/Container.v 32 | src/Data/Functor/Contravariant.v 33 | src/Data/Functor/Identity.v 34 | src/Data/Functor/Kan.v 35 | src/Data/Functor/Yoneda.v 36 | src/Data/IntMap.v 37 | src/Data/IntSet.v 38 | src/Data/List.v 39 | src/Data/List/Church.v 40 | src/Data/Maybe.v 41 | src/Data/Monoid.v 42 | src/Data/NonEmpty.v 43 | src/Data/Semigroup.v 44 | src/Data/Tuple.v 45 | src/Data/Vector.v 46 | src/Extract.v 47 | src/Haskell.v 48 | src/Ltac.v 49 | src/Prelude.v 50 | src/Ssr.v 51 | -------------------------------------------------------------------------------- /src/Data/Functor/Identity.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | Set Asymmetric Patterns. 9 | 10 | (* Identity, in two flavors. *) 11 | 12 | Definition Identity (a : Type) := a. 13 | 14 | #[export] 15 | Program Instance Identity_Functor : Functor Identity := { 16 | fmap := fun _ _ => id 17 | }. 18 | 19 | #[export] 20 | Program Instance Identity_Applicative : Applicative Identity := { 21 | pure := fun _ => id; 22 | ap := fun _ _ => id 23 | }. 24 | 25 | #[export] 26 | Program Instance Identity_Monad : Monad Identity := { 27 | join := fun _ => id 28 | }. 29 | 30 | Inductive IdentityF (a : Type) := Id : a -> IdentityF a. 31 | 32 | Definition runIdentityF `(x : IdentityF a) : a := 33 | match x with Id y => y end. 34 | 35 | #[export] 36 | Program Instance IdentityF_Functor : Functor IdentityF := { 37 | fmap := fun _ _ f x => Id _ (f (runIdentityF x)) 38 | }. 39 | 40 | #[export] 41 | Program Instance IdentityF_Applicative : Applicative IdentityF := { 42 | pure := fun _ => Id _; 43 | ap := fun _ _ f x => Id _ (runIdentityF f (runIdentityF x)) 44 | }. 45 | 46 | #[export] 47 | Program Instance IdentityF_Monad : Monad IdentityF := { 48 | join := fun _ => runIdentityF 49 | }. 50 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Class.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | Class MonadTrans (T : (Type -> Type) -> Type -> Type) := 10 | { lift : forall (M : Type -> Type) `{Monad M} `{Monad (T M)} A, M A -> T M A 11 | }. 12 | 13 | Arguments lift {T _ M _ _ A} _. 14 | 15 | Notation "lift[ M ]" := (@lift M _ _ _) (at level 9). 16 | Notation "lift[ M N ]" := (@lift (fun X => M (N X)) _ _ _) (at level 9). 17 | 18 | Module MonadTransLaws. 19 | 20 | Include MonadLaws. 21 | 22 | Class MonadTransLaws `{MonadTrans T} := 23 | { trans_law_1 : 24 | forall (M : Type -> Type) `{MonadLaws M} `{MonadLaws (T M)} A, 25 | lift \o pure[M] = (@pure (T M) _ A); 26 | trans_law_2 : 27 | forall (M : Type -> Type) `{MonadLaws M} `{MonadLaws (T M)} A 28 | (f : A -> M A) (m : M A), 29 | lift (m >>= f) = (@lift _ _ _ _ _ A m) >>= (lift \o f) 30 | }. 31 | 32 | Theorem trans_law_1_x : forall (T : (Type -> Type) -> Type -> Type) 33 | {M : Type -> Type} `{m : MonadLaws M} `{tm : MonadLaws (T M)} 34 | `{MonadTransLaws T} {A : Type} {x : A}, 35 | lift (pure[M] x) = (@pure (T M) _ A) x. 36 | Proof. 37 | intros. 38 | destruct H2. 39 | specialize (trans_law_3 M _). 40 | rewrite <- trans_law_3. 41 | reflexivity. 42 | assumption. 43 | assumption. 44 | Qed. 45 | 46 | End MonadTransLaws. -------------------------------------------------------------------------------- /src/Data/Traversable.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Hask.Control.Monad 3 | Hask.Data.Maybe. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | Class Traversable `{Functor t} := { 11 | sequence : forall `{Applicative f} a, t (f a) -> f (t a) 12 | 13 | (* naturality 14 | t . sequence = sequence . fmap t for every applicative transformation t 15 | identity 16 | sequence . fmap Identity = Identity 17 | composition 18 | sequence . fmap Compose = Compose . fmap sequence . sequence 19 | *) 20 | }. 21 | 22 | Arguments sequence {t H _ f _ a} _. 23 | 24 | Arguments Traversable t [H]. 25 | 26 | (* Tupersable is a specialization of Traversable that applies only to tuples, 27 | and thus does not require that tuples be Applicative. *) 28 | 29 | Class Tupersable {rep} `{Functor t} := { 30 | sequenceT : forall a, rep -> t (rep * a)%type -> rep * t a 31 | }. 32 | 33 | Arguments sequenceT {rep t H _ a} _ _. 34 | 35 | Arguments Tupersable rep t [H]. 36 | 37 | #[export] 38 | Instance Maybe_Traversable : Traversable Maybe := { 39 | sequence := fun _ _ A x => 40 | match x with 41 | | Nothing => pure Nothing 42 | | Just x => fmap Just x 43 | end 44 | }. 45 | 46 | #[export] 47 | Instance Maybe_Tupersable {rep} : Tupersable rep Maybe := { 48 | sequenceT := fun A (s : rep) x => 49 | match x with 50 | | Nothing => (s, Nothing) 51 | | Just (s', x) => (s', Just x) 52 | end 53 | }. 54 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | args@{ 2 | rev ? "8f73de28e63988da02426ebb17209e3ae07f103b" 3 | , sha256 ? "1mvq8wxdns802b1gvjvalbvdsp3xjgm370bimdd93mwpspz0250p" 4 | , pkgs ? import (builtins.fetchTarball { 5 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 6 | inherit sha256; }) { 7 | config.allowUnfree = true; 8 | config.allowBroken = false; 9 | } 10 | }: 11 | 12 | let 13 | 14 | coq-haskell = coqPackages: 15 | with pkgs.${coqPackages}; pkgs.stdenv.mkDerivation rec { 16 | name = "coq${coq.coq-version}-coq-haskell-${version}"; 17 | version = "1.1"; 18 | 19 | src = if pkgs ? coqFilterSource 20 | then pkgs.coqFilterSource [] ./. 21 | else ./.; 22 | 23 | buildInputs = [ 24 | coq coq.ocaml coq.camlp5 coq.findlib pkgs.perl 25 | ]; 26 | enableParallelBuilding = true; 27 | 28 | installFlags = "COQLIB=$(out)/lib/coq/${coq.coq-version}/"; 29 | 30 | env = pkgs.buildEnv { inherit name; paths = buildInputs; }; 31 | passthru = { 32 | compatibleCoqVersions = v: 33 | builtins.elem v [ "8.10" "8.11" "8.12" "8.13" "8.14" "8.15" ]; 34 | }; 35 | }; 36 | 37 | in { 38 | inherit coq-haskell; 39 | coq-haskell_8_10 = coq-haskell "coqPackages_8_10"; 40 | coq-haskell_8_11 = coq-haskell "coqPackages_8_11"; 41 | coq-haskell_8_12 = coq-haskell "coqPackages_8_12"; 42 | coq-haskell_8_13 = coq-haskell "coqPackages_8_13"; 43 | coq-haskell_8_14 = coq-haskell "coqPackages_8_14"; 44 | coq-haskell_8_15 = coq-haskell "coqPackages_8_15"; 45 | } 46 | -------------------------------------------------------------------------------- /haskell/Hask/Coq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hask.Coq where 4 | 5 | import Control.Applicative 6 | import Control.Monad 7 | import Control.Monad.Free 8 | import Data.Monoid hiding (Any) 9 | import qualified Hask.Functor as Coq 10 | import qualified Hask.Functor as Functor 11 | import qualified Hask.Applicative as Coq 12 | import qualified Hask.Monad as Coq 13 | import qualified Hask.Free as Coq 14 | import Unsafe.Coerce 15 | 16 | type Any = Functor.Any 17 | 18 | coqFunctor :: forall f. Functor f => Coq.Functor (f Any) 19 | coqFunctor _ _ g x = 20 | unsafeCoerce (fmap g (unsafeCoerce x :: f Any)) 21 | 22 | coqApplicative :: forall f. Applicative f => Coq.Applicative (f Any) 23 | coqApplicative = Coq.Build_Applicative coqFunctor (\_ -> pure) 24 | (\_ _ g x -> unsafeCoerce (unsafeCoerce g <*> unsafeCoerce x :: f Any)) 25 | 26 | coqMonad :: forall m. (Monad m, Applicative m) => Coq.Monad (m Any) 27 | coqMonad = Coq.Build_Monad coqApplicative 28 | (\_ x -> unsafeCoerce (join (unsafeCoerce x :: m (m Any)) :: m Any)) 29 | 30 | toCoqFree :: Functor f => Free f a -> Coq.Free (f Any) a 31 | toCoqFree (Pure x) = Coq.Pure x 32 | toCoqFree (Free g) = Coq.Join (toCoqFree . unsafeCoerce) 33 | (fmap unsafeCoerce g) 34 | 35 | fromCoqFree :: Functor f 36 | => Coq.Functor (f Any) -> Coq.Free (f Any) a -> Free f a 37 | fromCoqFree _ (Coq.Pure x) = Pure x 38 | fromCoqFree f (Coq.Join g h) = Free (fmap (unsafeCoerce f) g (unsafeCoerce h)) 39 | -------------------------------------------------------------------------------- /coq-haskell.cabal: -------------------------------------------------------------------------------- 1 | -- Initial coq-haskell.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: coq-haskell 5 | version: 0.1.0.0 6 | synopsis: Library for bridging the gap between Haskell and Coq 7 | -- description: 8 | homepage: https://github.com/jwiegley/coq-haskell 9 | license: BSD3 10 | license-file: LICENSE 11 | author: John Wiegley 12 | maintainer: johnw@newartisans.com 13 | -- copyright: 14 | category: Language 15 | build-type: Simple 16 | extra-source-files: README.md 17 | cabal-version: >=1.10 18 | 19 | library 20 | exposed-modules: 21 | Hask.Coq 22 | Hask.Utils 23 | other-modules: 24 | Hask.Applicative 25 | Hask.Church 26 | Hask.Comonad 27 | Hask.Datatypes 28 | Hask.Eqtype 29 | Hask.Fintype 30 | Hask.Free 31 | Hask.Free0 32 | Hask.Functor 33 | Hask.Identity 34 | Hask.IntMap 35 | Hask.IntSet 36 | Hask.List0 37 | Hask.Logic 38 | Hask.Maybe 39 | Hask.Monad 40 | Hask.Prelude0 41 | Hask.Seq 42 | Hask.Specif 43 | Hask.Ssrbool 44 | Hask.Ssrfun 45 | Hask.Ssrnat 46 | Hask.State 47 | Hask.State0 48 | Hask.Tuple 49 | Hask.Vector0 50 | Hask.Yoneda 51 | other-extensions: ScopedTypeVariables 52 | build-depends: base >=4.7 && <5.0 53 | , free >= 4.12 && < 4.13 54 | , containers 55 | , ghc-prim 56 | hs-source-dirs: haskell extract 57 | default-language: Haskell2010 -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, John Wiegley 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of John Wiegley nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /test/Extracted.hs: -------------------------------------------------------------------------------- 1 | module Extracted where 2 | 3 | import qualified Prelude 4 | import Unsafe.Coerce 5 | 6 | type Any = () 7 | 8 | __ :: any 9 | __ = Prelude.error "Logical or arity value used" 10 | 11 | type Functor f = 12 | () -> () -> (Any -> Any) -> f -> f 13 | -- singleton inductive, whose constructor was Build_Functor 14 | 15 | fmap :: (Functor a1) -> (a2 -> a3) -> a1 -> a1 16 | fmap functor x x0 = 17 | unsafeCoerce functor __ __ x x0 18 | 19 | data Applicative f = 20 | Build_Applicative (Functor f) (() -> Any -> f) (() -> () -> f -> f -> f) 21 | 22 | is_functor :: (Applicative a1) -> Functor a1 23 | is_functor applicative = 24 | case applicative of { 25 | Build_Applicative is_functor0 pure0 ap -> is_functor0} 26 | 27 | pure :: (Applicative a1) -> a2 -> a1 28 | pure applicative x = 29 | case applicative of { 30 | Build_Applicative is_functor0 pure0 ap -> unsafeCoerce pure0 __ x} 31 | 32 | data Monad m = 33 | Build_Monad (Applicative m) (() -> m -> m) 34 | 35 | is_applicative :: (Monad a1) -> Applicative a1 36 | is_applicative monad = 37 | case monad of { 38 | Build_Monad is_applicative0 join0 -> is_applicative0} 39 | 40 | join :: (Monad a1) -> a1 -> a1 41 | join monad x = 42 | case monad of { 43 | Build_Monad is_applicative0 join0 -> join0 __ x} 44 | 45 | bind :: (Monad a1) -> (a2 -> a1) -> a1 -> a1 46 | bind h f = 47 | (Prelude..) (join h) (fmap (is_functor (is_applicative h)) f) 48 | 49 | data Free f a = 50 | Pure a 51 | | Join (Any -> Free f a) f 52 | 53 | retract :: (Monad a1) -> (Free a1 a2) -> a1 54 | retract h fr = 55 | case fr of { 56 | Pure x -> pure (is_applicative h) x; 57 | Join g h0 -> bind h ((Prelude..) (retract h) g) h0} 58 | -------------------------------------------------------------------------------- /haskell/Hask/Utils.hs: -------------------------------------------------------------------------------- 1 | module Hask.Utils where 2 | 3 | import Data.Char 4 | import Data.List as L 5 | import Data.IntMap as M 6 | import Debug.Trace 7 | 8 | trace :: [Int] -> a -> a 9 | trace = Debug.Trace.trace . L.map chr 10 | 11 | intMap_mergeWithKey' 12 | :: (Int -> a -> b -> Maybe c) 13 | -> ([(Int, a)] -> [(Int, c)]) 14 | -> ([(Int, b)] -> [(Int, c)]) 15 | -> [(Int, a)] 16 | -> [(Int, b)] 17 | -> [(Int, c)] 18 | intMap_mergeWithKey' combine only1 only2 m1 m2 = 19 | M.toList $ M.mergeWithKey combine 20 | (M.fromList . only1 . M.toList) 21 | (M.fromList . only2 . M.toList) 22 | (M.fromList m1) (M.fromList m2) 23 | 24 | uncons :: [a] -> Maybe (a, [a]) 25 | uncons [] = Nothing 26 | uncons (x:xs) = Just (x, xs) 27 | 28 | -- Used for conversions between vectors and seq, which are the same in Haskell 29 | vec_id :: Int -> a -> a 30 | vec_id _ = id 31 | 32 | vshiftin :: Int -> [a] -> a -> [a] 33 | vshiftin _ xs x = xs ++ [x] 34 | 35 | vreplace :: Int -> [a] -> Int -> a -> [a] 36 | vreplace _ xs n x = take n xs ++ x : drop (n+1) xs 37 | 38 | vmap :: Int -> (a -> b) -> [a] -> [b] 39 | vmap _ = L.map 40 | 41 | vfoldl' :: Int -> (b -> a -> b) -> b -> [a] -> b 42 | vfoldl' _ = L.foldl' 43 | 44 | vfoldl'_with_index :: Int -> (Int -> b -> a -> b) -> b -> [a] -> b 45 | vfoldl'_with_index _ f = go 0 46 | where 47 | go _ z [] = z 48 | go n z (x:xs) = go (n+1) (f n z x) xs 49 | 50 | vmap_with_index :: Int -> (Int -> a -> b) -> [a] -> [b] 51 | vmap_with_index _ f = go 0 52 | where 53 | go _ [] = [] 54 | go n (x:xs) = f n x : go (n+1) xs 55 | 56 | vnth :: Int -> [a] -> Int -> a 57 | vnth _ = (!!) 58 | 59 | vec_rect :: b -> (Int -> a -> [a] -> b -> b) -> Int -> [a] -> b 60 | vec_rect z f _ = go z 61 | where 62 | go z [] = z 63 | go z (x:xs) = go (f err x xs z) xs 64 | 65 | err = error "list_rect: attempt to use size" 66 | -------------------------------------------------------------------------------- /src/Control/Monad/Fix.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | (****************************************************************************** 13 | * The MonadFix class 14 | * 15 | * Note that the type of `mfix` here is quite different from Haskell's 16 | * @(T -> m U) -> m U@, and this is due to the call-by-value nature of Coq. 17 | * For more information on this encoding and what it means, see the article 18 | * "Axioms for Recursion in Call-by-Val": 19 | * 20 | * http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.27.2580&rep=rep1&type=pdf 21 | *) 22 | 23 | Class MonadFix (m : Type -> Type) : Type := { 24 | mfix : forall {T U}, ((T -> m U) -> T -> m U) -> T -> m U 25 | }. 26 | 27 | Module MonadFixLaws. 28 | 29 | Include MonadLaws. 30 | 31 | (** 32 | 33 | The laws of MonadFix and some implications. 34 | 35 | purity: 36 | 37 | mfix (return . h) = return (fix h) 38 | 39 | mfix over pure things is the same as pure recursion. mfix does not add any 40 | monadic action of its own. 41 | 42 | left shrinking: 43 | 44 | mfix (\x -> a >>= \y -> f x y) = a >>= \y -> mfix (\x -> f x y) 45 | 46 | A monadic action on the left (at the beginning) that does not involve 47 | the recursed value (here x) can be factored out of mfix. So mfix does 48 | not change the number of times the action is performed, since putting 49 | it inside or outside makes no difference. 50 | 51 | sliding: if h is strict, 52 | 53 | mfix (liftM h . f) = liftM h (mfix (f . h)) 54 | 55 | nesting: 56 | 57 | mfix (\x -> mfix (\y -> f x y)) = mfix (\x -> f x x) 58 | 59 | these two laws are analogous to those of pure recursion, i.e., laws of 60 | fix. 61 | *) 62 | 63 | End MonadFixLaws. 64 | -------------------------------------------------------------------------------- /test/Transfer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Transfer where 4 | 5 | import Control.Applicative 6 | import Control.Monad 7 | import Control.Monad.Free 8 | import Data.Monoid hiding (Any) 9 | import qualified Extracted as Coq 10 | import Unsafe.Coerce 11 | 12 | type Any = Coq.Any 13 | 14 | coqFunctor :: forall f. Functor f => Coq.Functor (f Any) 15 | coqFunctor (_ :: Any) (_ :: Any) (g :: Any -> Any) x = 16 | unsafeCoerce (fmap g (unsafeCoerce x :: f Any)) 17 | 18 | coqApplicative :: forall f. Applicative f => Coq.Applicative (f Any) 19 | coqApplicative = Coq.Build_Applicative coqFunctor 20 | (\(_ :: Any) -> pure) 21 | (\(_ :: Any) (_ :: Any) g x -> 22 | unsafeCoerce (unsafeCoerce g <*> unsafeCoerce x :: f Any)) 23 | 24 | coqMonad :: forall m. (Monad m, Applicative m) => Coq.Monad (m Any) 25 | coqMonad = Coq.Build_Monad coqApplicative 26 | (\(_ :: Any) x -> 27 | unsafeCoerce (join (unsafeCoerce x :: m (m Any)) :: m Any)) 28 | 29 | toCoqFree :: Functor f => Free f a -> Coq.Free (f Any) a 30 | toCoqFree (Pure x) = Coq.Pure x 31 | toCoqFree (Free g) = Coq.Join (toCoqFree . unsafeCoerce) 32 | (fmap unsafeCoerce g) 33 | 34 | fromCoqFree :: Functor f 35 | => Coq.Functor (f Any) -> Coq.Free (f Any) a -> Free f a 36 | fromCoqFree _ (Coq.Pure x) = Pure x 37 | fromCoqFree f (Coq.Join g h) = Free (fmap (unsafeCoerce f) g (unsafeCoerce h)) 38 | 39 | {------------------------------------------------------------------------} 40 | 41 | instance Monoid w => Monad ((,) w) where 42 | return = pure 43 | (w, x) >>= f = let (w', y) = f x in (w <> w', y) 44 | 45 | main :: IO () 46 | main = do 47 | print $ 48 | (unsafeCoerce :: a -> (Sum Int, Int)) 49 | (Coq.retract coqMonad 50 | (toCoqFree (Free (Sum 100, 51 | Free (Sum 200, Pure 10)) 52 | :: Free ((,) (Sum Int)) Int))) 53 | -------------------------------------------------------------------------------- /src/Control/Comonad.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Data.List. 3 | Require Import Hask.Control.Applicative. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | Class Comonad (w : Type -> Type) := { 11 | is_functor :> Functor w; 12 | 13 | extract : forall {a : Type}, w a -> a; 14 | duplicate : forall {a : Type}, w a -> w (w a) 15 | }. 16 | 17 | Arguments extract {w _ _} _. 18 | Arguments duplicate {w _ _} _. 19 | 20 | Definition extend `{Comonad w} {X Y : Type} (f : (w X -> Y)) : w X -> w Y := 21 | fmap f \o duplicate. 22 | 23 | Notation "m =>> f" := (extend f m) (at level 25, left associativity). 24 | 25 | Module ComonadLaws. 26 | 27 | Include ApplicativeLaws. 28 | 29 | (* Class ComonadLaws (w : Type -> Type) `{Comonad w} := { *) 30 | (* has_applicative_laws :> ApplicativeLaws w; *) 31 | 32 | (* duplicate_fmap_duplicate : forall a : Type, *) 33 | (* duplicate \o fmap (@duplicate w _ a) =1 duplicate \o duplicate; *) 34 | (* duplicate_fmap_extract : forall a : Type, *) 35 | (* duplicate \o fmap (extract (a:=a)) =1 id; *) 36 | (* duplicate_extract : forall a : Type, duplicate \o extract =1 @id (w a); *) 37 | (* duplicate_fmap_fmap : forall (a b : Type) (f : a -> b), *) 38 | (* duplicate \o fmap (fmap f) =1 fmap f \o duplicate *) 39 | (* }. *) 40 | 41 | (* Corollary duplicate_fmap_duplicate_x `{ComonadLaws w} : forall a x, *) 42 | (* duplicate (fmap (duplicate (a:=a)) x) = duplicate (duplicate x). *) 43 | (* Proof. exact: duplicate_fmap_duplicate. Qed. *) 44 | 45 | (* Corollary duplicate_fmap_extract_x `{ComonadLaws w} : forall a x, *) 46 | (* duplicate (fmap (extract (a:=a)) x) = x. *) 47 | (* Proof. exact: duplicate_fmap_extract. Qed. *) 48 | 49 | (* Corollary duplicate_extract_x `{ComonadLaws w} : forall a x, *) 50 | (* duplicate (extract x) = @id (w a) x. *) 51 | (* Proof. exact: duplicate_extract. Qed. *) 52 | 53 | (* Corollary duplicate_fmap_fmap_x `{ComonadLaws w} : *) 54 | (* forall (a b : Type) (f : a -> b) x, *) 55 | (* duplicate (fmap (fmap f) x) = fmap f (duplicate x). *) 56 | (* Proof. exact: duplicate_fmap_fmap. Qed. *) 57 | 58 | End ComonadLaws. 59 | -------------------------------------------------------------------------------- /src/Data/Functor.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Ltac. 2 | 3 | Generalizable All Variables. 4 | Set Primitive Projections. 5 | Set Universe Polymorphism. 6 | Unset Transparent Obligations. 7 | 8 | Class Functor (f : Type -> Type) : Type := { 9 | fmap : forall {a b : Type}, (a -> b) -> f a -> f b 10 | }. 11 | 12 | Arguments fmap {f _ a b} g x. 13 | 14 | Infix "<$>" := fmap (at level 28, left associativity, only parsing). 15 | Infix "<$[ M ]>" := 16 | (@fmap M _ _ _) (at level 28, left associativity, only parsing). 17 | Notation "x <$ m" := 18 | (fmap (const x) m) (at level 28, left associativity, only parsing). 19 | Notation "x <&> f" := 20 | (fmap f x) (at level 28, left associativity, only parsing). 21 | 22 | Notation "fmap[ M ]" := (@fmap M _ _ _) (at level 9). 23 | Notation "fmap[ M N ]" := (@fmap (fun X => M (N X)) _ _ _) (at level 9). 24 | Notation "fmap[ M N O ]" := 25 | (@fmap (fun X => M (N (O X))) _ _ _) (at level 9). 26 | 27 | Require Import FunctionalExtensionality. 28 | Require Import Coq.Classes.Morphisms. 29 | Require Import Coq.Setoids.Setoid. 30 | 31 | Module FunctorLaws. 32 | 33 | (* Functors preserve extensional equality for the applied function. 34 | This is needed to perform setoid rewriting within the function 35 | passed to a functor. *) 36 | Add Parametric Morphism {A B} `{Functor F} : (@fmap F _ A B) 37 | with signature (pointwise_relation _ eq ==> eq ==> eq) 38 | as mul_isomorphism. 39 | Proof. 40 | intros. 41 | f_equal. 42 | extensionality e. 43 | apply H0. 44 | Qed. 45 | 46 | Class FunctorLaws (f : Type -> Type) `{Functor f} := { 47 | fmap_id : forall a : Type, fmap (@id a) = id; 48 | fmap_comp : forall (a b c : Type) (f : b -> c) (g : a -> b), 49 | fmap f \o fmap g = fmap (f \o g) 50 | }. 51 | 52 | Corollary fmap_id_x `{FunctorLaws f} : forall (a : Type) x, fmap (@id a) x = x. 53 | Proof. 54 | intros. 55 | rewrite fmap_id. 56 | reflexivity. 57 | Qed. 58 | 59 | Corollary fmap_comp_x `{FunctorLaws F} : 60 | forall (a b c : Type) (f : b -> c) (g : a -> b) x, 61 | fmap f (fmap g x) = fmap (fun y => f (g y)) x. 62 | Proof. 63 | intros. 64 | replace (fun y : a => f (g y)) with (f \o g). 65 | rewrite <- fmap_comp. 66 | reflexivity. 67 | reflexivity. 68 | Qed. 69 | 70 | End FunctorLaws. 71 | -------------------------------------------------------------------------------- /src/Data/List/Church.v: -------------------------------------------------------------------------------- 1 | (* Church-encoded lists. *) 2 | 3 | Require Import Hask.Prelude. 4 | Require Import FunctionalExtensionality. 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | 11 | Definition Church (a : Type) := forall r, (a -> r -> r) -> r -> r. 12 | 13 | (* 14 | Definition toChurch {a} : list a -> Church a := 15 | fun xs _ c n => foldr c n xs. 16 | 17 | Definition fromChurch `(xs : Church a) : list a := xs _ cons nil. 18 | 19 | Axiom Church_parametricity : forall (a : Type) 20 | (l : forall r : Type, (a -> r -> r) -> r -> r) 21 | (r : Type) (c : a -> r -> r) (n : r), 22 | foldr c n (l (list a) cons [::]) = l r c n. 23 | 24 | Definition to_from_Church : forall a (l : Church a), 25 | toChurch (fromChurch l) = l. 26 | Proof. 27 | rewrite /Church /toChurch /fromChurch. 28 | move=> a l. 29 | extensionality r. 30 | extensionality c. 31 | extensionality n. 32 | exact: Church_parametricity. 33 | Qed. 34 | 35 | Definition from_to_Church : forall a (l : list a), 36 | fromChurch (toChurch l) = l. 37 | Proof. 38 | rewrite /Church /toChurch /fromChurch. 39 | move=> a. 40 | elim=> //= [x xs IHxs]. 41 | by rewrite IHxs. 42 | Qed. 43 | 44 | Definition Church_ind : forall (A : Type) (P : Church A -> Prop), 45 | P (fun _ c n => n) -> 46 | (forall (h : A) (t : Church A), P t -> P (fun _ c n => c h (t _ c n))) -> 47 | forall l : Church A, P l. 48 | Proof. 49 | rewrite /Church. 50 | move=> A P Hnil Hcons l. 51 | rewrite -[l]to_from_Church. 52 | induction (fromChurch l) as [|x xs IHxs]. 53 | exact: Hnil. 54 | exact/Hcons/IHxs. 55 | Defined. 56 | 57 | Definition Church_length `(xs : Church a) : nat := xs nat (fun _ => plus 1) 0. 58 | Definition Church_append {a} (xs ys : Church a) : Church a := 59 | fun _ c n => xs _ c (ys _ c n). 60 | 61 | Example Church_append_works : 62 | fromChurch (Church_append (toChurch [:: 1; 2; 3]) (toChurch [:: 4; 5; 6])) 63 | = [:: 1; 2; 3; 4; 5; 6]. 64 | Proof. reflexivity. Qed. 65 | 66 | Theorem Church_length_append : forall a (xs ys : Church a), 67 | Church_length (Church_append xs ys) = Church_length xs + Church_length ys. 68 | Proof. 69 | move=> a xs. 70 | rewrite /Church_length /Church_append. simpl. 71 | elim/Church_ind: xs => //= [x xs IHxs] ys. 72 | by rewrite IHxs. 73 | Qed. 74 | *) -------------------------------------------------------------------------------- /src/Control/Monad/Morph.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Control.Monad.Trans.Class. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | (* These classes are laws are documented by Gabriel Gonzalez at: 11 | 12 | http://hackage.haskell.org/package/mmorph-1.0.3/docs/src/Control-Monad-Morph.html 13 | *) 14 | Class MFunctor (T : (Type -> Type) -> Type -> Type) := 15 | { hoist : forall {M N : Type -> Type} `{Monad M} `{Monad (T M)} {A}, 16 | (forall {X}, M X -> N X) -> T M A -> T N A 17 | }. 18 | 19 | Notation "hoist/ M N" := (@hoist M N _ _ _) (at level 28). 20 | 21 | (* 22 | Set Printing All. 23 | Class MMonad (T : (Type -> Type) -> Type -> Type) 24 | `{MFunctor T} `{td : MonadTrans T} := 25 | { embed : forall {M N : Type -> Type} `{Monad N} `{Monad (T N)} {A}, 26 | (forall {X}, M X -> T N X) -> T M A -> T N A 27 | 28 | ; embed_law_1 : forall {N : Type -> Type} 29 | `{n : Monad N} `{tn : Monad (T N)} {A : Type}, 30 | @embed N N _ _ A (@lift T _ n tn td) = id 31 | 32 | ; embed_law_2 : forall {M N : Type -> Type} 33 | `{Monad M} `{Monad (T M)} `{Monad N} `{Monad (T N)} {A : Type} 34 | (m : M A) (f : forall X, M X -> T N X), 35 | (@embed M N _ _ A f (@lift T _ _ _ _ A m)) = f A m 36 | 37 | ; embed_law_3 : forall {M N O : Type -> Type} 38 | `{Monad M} `{Monad (T M)} 39 | `{Monad N} `{Monad (T N)} 40 | `{Monad O} `{Monad (T O)} {A : Type} 41 | (f : forall X, N X -> T O X) (g : forall X, M X -> T N X) (t : T M A), 42 | (@embed N O _ _ A f) \o (@embed M N _ _ A g) = 43 | (@embed M O _ _ A (fun B => (@embed N O _ _ B f) \o g B)) 44 | }. 45 | 46 | Notation "embed/ M N" := (@embed M N _ _ _) (at level 28). 47 | *) 48 | 49 | Module MorphLaws. 50 | 51 | Include MonadLaws. 52 | 53 | Class MFunctorLaws (T : (Type -> Type) -> Type -> Type) `{MFunctor T} := 54 | { hoist_law_1 : forall {M : Type -> Type} 55 | `{MonadLaws M} `{MonadLaws (T M)} {A}, 56 | (@hoist T _ M M _ _ A (fun X => id)) = id 57 | 58 | ; hoist_law_2 : forall {M N O : Type -> Type} 59 | `{MonadLaws M} `{MonadLaws (T M)} 60 | `{MonadLaws N} `{MonadLaws (T N)} {A : Type} 61 | (f : forall X, N X -> O X) (g : forall X, M X -> N X), 62 | hoist (fun X => f X \o g X) = hoist f \o (@hoist T _ M N _ _ A g) 63 | }. 64 | 65 | End MorphLaws. 66 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Reader.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Control.Monad.Trans.Class. 4 | Require Import Hask.Control.Monad.Morph. 5 | Require Import Hask.Control.Impl. 6 | Require Import Hask.Control.Compose. 7 | 8 | Generalizable All Variables. 9 | Set Primitive Projections. 10 | Set Universe Polymorphism. 11 | Unset Transparent Obligations. 12 | 13 | Definition ReaderT (X : Type) (M : Type -> Type) (Y : Type) : Type := 14 | X -> M Y. 15 | 16 | Definition runReaderT {E M A} (r : ReaderT E M A) := r. 17 | 18 | #[export] 19 | Program Instance ReaderT_Functor `{Functor m} {E} : Functor (ReaderT E m) := 20 | @Compose_Functor _ Impl_Functor m _. 21 | 22 | #[export] 23 | Program Instance ReaderT_Applicative `{Applicative m} {E} : 24 | Applicative (ReaderT E m) := 25 | @Compose_Applicative _ m Impl_Applicative _. 26 | 27 | #[export] 28 | Program Instance ReaderT_Monad `{Monad m} {E} : Monad (ReaderT E m) := 29 | @Compose_Monad _ Impl_Monad m _ Impl_Monad_Distributes. 30 | 31 | #[export] 32 | Instance ReaderT_MonadTrans {E} : MonadTrans (ReaderT E) := 33 | { lift := fun _ _ _ _ => fun v _ => v 34 | }. 35 | 36 | #[export] 37 | Program Instance ReaderT_MFunctor {E} : MFunctor (ReaderT E) := 38 | { hoist := fun _ _ _ _ _ nat => fun v1 v2 => nat _ (v1 v2) 39 | }. 40 | 41 | Module ReaderTLaws. 42 | 43 | Import MonadLaws. 44 | Import ComposeMonadLaws. 45 | Import ImplMonadLaws. 46 | 47 | #[export] 48 | Program Instance ReaderT_FunctorLaws `{FunctorLaws m} {E} : 49 | FunctorLaws (ReaderT E m) := 50 | @Compose_FunctorLaws _ Impl_Functor Impl_FunctorLaws m _ _. 51 | 52 | #[export] 53 | Program Instance ReaderT_ApplicativeLaws `{ApplicativeLaws m} {E} : 54 | ApplicativeLaws (ReaderT E m) := 55 | @Compose_ApplicativeLaws _ _ Impl_ApplicativeLaws m _ _. 56 | 57 | #[export] 58 | Program Instance ReaderT_MonadLaws `{MonadLaws m} {E} : 59 | MonadLaws (ReaderT E m) := 60 | @Compose_MonadLaws _ m Impl_Monad _ _ Impl_Monad_DistributesLaws. 61 | 62 | End ReaderTLaws. 63 | 64 | Class MonadReader (r : Type) (m : Type -> Type) `{Monad m} := { 65 | ask : m r; 66 | local : forall a, (r -> r) -> m a -> m a; 67 | reader : forall a, (r -> a) -> m a 68 | }. 69 | 70 | #[export] 71 | Program Instance ReaderT_MonadReader {E} `{Monad m} : 72 | MonadReader E (ReaderT E m) := { 73 | ask := pure; 74 | local := fun _ f m => fun v => m (f v); 75 | reader := fun _ f => fun v => pure (f v) 76 | }. 77 | -------------------------------------------------------------------------------- /src/Data/IntSet.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Data.List. 3 | Require Import Hask.Data.NonEmpty. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | Generalizable All Variables. 9 | Set Primitive Projections. 10 | Set Universe Polymorphism. 11 | Unset Transparent Obligations. 12 | 13 | (* 14 | Inductive IntSet := getIntSet of seq nat. 15 | 16 | Arguments getIntSet _. 17 | 18 | Definition emptyIntSet := getIntSet [::]. 19 | 20 | Definition IntSet_singleton (x : nat) := getIntSet [:: x]. 21 | 22 | (* We needn't bother defining these in Coq, since they only matter to the 23 | extracted Haskell code, and there we use the definitions from 24 | [Data.IntMap]. *) 25 | Definition IntSet_member : nat -> IntSet -> bool := 26 | fun k m => let: getIntSet xs := m in k \in xs. 27 | 28 | Definition IntSet_size : IntSet -> nat := 29 | fun m => let: getIntSet xs := m in size xs. 30 | 31 | Definition IntSet_insert : nat -> IntSet -> IntSet := fun k m => 32 | let: getIntSet xs := m in 33 | if k \in xs then m else getIntSet (k :: xs). 34 | 35 | Definition IntSet_delete : nat -> IntSet -> IntSet := fun k m => 36 | let: getIntSet xs := m in getIntSet (rem k xs). 37 | 38 | Definition IntSet_union : IntSet -> IntSet -> IntSet := fun m1 m2 => 39 | let: getIntSet xs1 := m1 in 40 | let: getIntSet xs2 := m2 in 41 | getIntSet (undup (xs1 ++ xs2)). 42 | 43 | Definition IntSet_difference : IntSet -> IntSet -> IntSet := fun m1 m2 => 44 | let: getIntSet xs1 := m1 in 45 | let: getIntSet xs2 := m2 in 46 | getIntSet (filter (fun k => k \notin xs2) xs1). 47 | 48 | Definition IntSet_foldl : forall a, (a -> nat -> a) -> a -> IntSet -> a := 49 | fun _ f z m => let: getIntSet xs := m in foldl f z xs. 50 | 51 | Definition IntSet_forFold {a} (z : a) (m : IntSet) (f: a -> nat -> a) : a := 52 | IntSet_foldl f z m. 53 | 54 | Definition IntSet_toList (m : IntSet) : seq nat := 55 | let: getIntSet xs := m in xs. 56 | 57 | Section EqIntSet. 58 | 59 | Variable a : eqType. 60 | 61 | Definition eqIntSet (s1 s2 : IntSet) := 62 | match s1, s2 with 63 | | getIntSet xs, getIntSet ys => xs == ys 64 | end. 65 | 66 | Lemma eqIntSetP : Equality.axiom eqIntSet. 67 | Proof. 68 | move. 69 | case=> [s1]. 70 | case=> [s2] /=. 71 | case: (s1 =P s2) => [<-|neqx]; last by right; case. 72 | by constructor. 73 | Qed. 74 | 75 | Canonical IntSet_eqMixin := EqMixin eqIntSetP. 76 | Canonical IntSet_eqType := Eval hnf in EqType IntSet IntSet_eqMixin. 77 | 78 | End EqIntSet. 79 | *) -------------------------------------------------------------------------------- /src/Control/Impl.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Data.Functor. 2 | Require Import Hask.Control.Applicative. 3 | Require Import Hask.Control.Monad. 4 | Require Import Hask.Control.Compose. 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | 11 | #[export] 12 | Instance Impl_Functor {A} : Functor (fun B => A -> B) := { 13 | fmap := fun A B f run => fun xs => f (run xs) 14 | }. 15 | 16 | #[export] 17 | Instance Impl_Applicative {A} : Applicative (fun B => A -> B) := { 18 | pure := fun _ x => fun _ => x; 19 | ap := fun _ _ runf runx => fun xs => runf xs (runx xs) 20 | }. 21 | 22 | #[export] 23 | Instance Impl_Monad {A} : Monad (fun B => A -> B) := { 24 | join := fun A run => fun xs => run xs xs 25 | }. 26 | 27 | #[export] 28 | Program Instance Impl_Monad_Distributes {A} `{Monad N} : 29 | @Monad_Distributes (fun B => A -> B) Impl_Monad N is_applicative. 30 | Obligation 1. 31 | exact (X >>= fun f => f X0). 32 | Defined. 33 | 34 | Require Import FunctionalExtensionality. 35 | 36 | Module ImplMonadLaws. 37 | 38 | Import MonadLaws. 39 | 40 | #[export] 41 | Program Instance Impl_FunctorLaws {A} : FunctorLaws (fun B => A -> B). 42 | #[export] 43 | Program Instance Impl_ApplicativeLaws {A} : ApplicativeLaws (fun B => A -> B). 44 | #[export] 45 | Program Instance Impl_MonadLaws {A} : MonadLaws (fun B => A -> B). 46 | 47 | #[export] 48 | Program Instance Impl_Monad_DistributesLaws {A} `{MonadLaws N} : 49 | @Monad_DistributesLaws (fun B => A -> B) N _ Impl_Monad is_applicative 50 | Impl_Monad_Distributes. 51 | Obligation 1. 52 | unfold Impl_Monad_Distributes_obligation_1, comp, bind, id. 53 | extensionality x. 54 | extensionality x0. 55 | simpl. 56 | rewrite <- join_fmap_fmap_x, !fmap_comp_x. 57 | reflexivity. 58 | Qed. 59 | Obligation 2. 60 | unfold Impl_Monad_Distributes_obligation_1, comp, bind, id. 61 | extensionality x. 62 | extensionality x0. 63 | simpl. 64 | rewrite fmap_pure_x, join_pure_x. 65 | reflexivity. 66 | Qed. 67 | Obligation 3. 68 | unfold Impl_Monad_Distributes_obligation_1, comp, bind, id. 69 | extensionality x. 70 | extensionality x0. 71 | simpl. 72 | rewrite fmap_comp_x, join_fmap_pure_x. 73 | reflexivity. 74 | Qed. 75 | Obligation 4. 76 | unfold Impl_Monad_Distributes_obligation_1, comp, bind, id. 77 | extensionality x. 78 | extensionality x0. 79 | simpl. 80 | rewrite <- join_fmap_fmap_x, <- join_fmap_join_x, !fmap_comp_x. 81 | reflexivity. 82 | Qed. 83 | 84 | End ImplMonadLaws. 85 | -------------------------------------------------------------------------------- /doc/coq-typeclasses-debugging.txt: -------------------------------------------------------------------------------- 1 | 16:15 johnw: It's approximately [eauto with typeclass_instances]. There are a 2 | few subtle differences (backtracking across evar instantiations across 3 | multiple goals is handled slightly differently) and a few very, very, very 4 | subtle differences (I think the algorithm it uses to look things up and what 5 | it unfolds are slightly different in a way that I've seen show up in 6 | performance bugs and nothing else). But, in general, just look at [Print 7 | HintDb 8 | 16:15 typeclass_instances] and [Set Typeclasses := debug.] (I think that's the 9 | right invocation?). 10 | 18:25 johnw: [unfold trans_sym_co_inv_impl_morphism]? 11 | 18:25 johnw: Is there a way to use "Check" within a definition? <- use [$(idtac 12 | defn; admit)$]. You'll need to get enough of your definition type-checking 13 | that admitting the broken piece is enough to get it to go through, but that 14 | should show you the thing you want to see. Or [$(let T := type of defn in 15 | idtac T; admit)$]. Or you might need [$(let term := constr:(defn) in let T := 16 | type of term in idtac T; admit)$]. 17 | 18:30 johnw: how do I ask Coq to always prefer ∘ from Sets <- make [Sets] have 18 | prioity 0 ([Instance Sets : Category | 0 := ...]), and give all other 19 | instances prioity 1 or higher (default is the number of typeclass arguments 20 | the instance has) 21 | 18:37 johnw: Rather than using setoids, you should develop the theory of higher 22 | coinductive types, or a sane equality for coinductives. :-P (Is axiomatizing 23 | HStream_eq -> eq really that terrible? You should be able to convince 24 | yourself in the metatheory that any function out of HStream will respect 25 | HStream_eq (because, for cofixpoint functions, you can induct on your proof of 26 | HStream_eq, and for non-cofix functions, you can destruct the proof 27 | 18:37 whatever finite number of times the non-cofix function does. And then 28 | you do magic univalence-like things to get it to work with crazy dependent 29 | type families like [eq].) And that's basically the definition of [eq]. 30 | Furthermore, if you make your axiom that the function [eq -> HStream_eq] is an 31 | equivalence, then you can make your axiom disappear whenever you transport 32 | across it, in much the same way that we currently make univalence disappear 33 | 18:37 in HoTT/HoTT. 34 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Ltac. 2 | Require Import Hask.Data.Functor. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | Class Contravariant (f : Type -> Type) := { 10 | contramap : forall {a b : Type}, (a -> b) -> f b -> f a 11 | }. 12 | 13 | Arguments contramap {f _ a b} _ x. 14 | 15 | Infix ">$<" := contramap (at level 28, left associativity, only parsing). 16 | Notation "x >&< f" := 17 | (contramap f x) (at level 28, left associativity, only parsing). 18 | 19 | Notation "contramap[ M ] f" := (@contramap M _ _ _ f) (at level 9). 20 | Notation "contramap[ M N ] f" := 21 | (@contramap (fun X => M (N X)) _ _ _ f) (at level 9). 22 | Notation "contramap[ M N O ] f" := 23 | (@contramap (fun X => M (N (O X))) _ _ _ f) (at level 9). 24 | 25 | Definition coerce `{Functor f} `{Contravariant f} {a b} : f a -> f b := 26 | fmap (False_rect _) \o contramap (False_rect _). 27 | 28 | #[export] 29 | Instance Contravariant_Compose `{Functor F} `{Contravariant G} : 30 | Contravariant (F \o G) := 31 | { contramap := fun A B => @fmap F _ (G B) (G A) \o @contramap G _ A B 32 | }. 33 | 34 | Require Import FunctionalExtensionality. 35 | 36 | Module ContravariantLaws. 37 | 38 | Include FunctorLaws. 39 | 40 | Class ContravariantLaws (f : Type -> Type) `{Contravariant f} := { 41 | contramap_id : forall a : Type, contramap (@id a) = id; 42 | contramap_comp : forall (a b c : Type) (f : b -> c) (g : a -> b), 43 | contramap g \o contramap f = contramap (f \o g) 44 | }. 45 | 46 | Corollary contramap_id_x `{ContravariantLaws f} : 47 | forall (a : Type) x, contramap (@id a) x = x. 48 | Proof. intros; rewrite contramap_id. auto. Qed. 49 | 50 | Corollary contramap_comp_x `{ContravariantLaws F} : 51 | forall (a b c : Type) (f : b -> c) (g : a -> b) x, 52 | contramap g (contramap f x) = contramap (fun y => f (g y)) x. 53 | Proof. 54 | intros. 55 | replace (fun y : a => f (g y)) with (f \o g). 56 | rewrite <- contramap_comp. 57 | reflexivity. 58 | reflexivity. 59 | Qed. 60 | 61 | Corollary contramap_compose `{Functor F} `{Contravariant G} : 62 | forall {X Y} (f : X -> Y), 63 | @fmap F _ (G Y) (G X) (@contramap G _ X Y f) = 64 | @contramap (F \o G) _ X Y f. 65 | Proof. reflexivity. Qed. 66 | 67 | #[export] 68 | Program Instance ContravariantLaws_Compose 69 | `{FunctorLaws F} `{ContravariantLaws G} : ContravariantLaws (F \o G). 70 | Obligation 1. (* contramap_id *) 71 | extensionality x. 72 | rewrite contramap_id, fmap_id. 73 | reflexivity. 74 | Qed. 75 | Obligation 2. (* contramap_comp *) 76 | extensionality x. 77 | rewrite fmap_comp, contramap_comp. 78 | reflexivity. 79 | Qed. 80 | 81 | End ContravariantLaws. 82 | -------------------------------------------------------------------------------- /src/Extract.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Data.Functor. 3 | Require Import Hask.Data.Functor.Container. 4 | Require Import Hask.Data.Functor.Contravariant. 5 | Require Import Hask.Data.Functor.Identity. 6 | Require Import Hask.Data.Functor.Yoneda. 7 | Require Import Hask.Control.Monad. 8 | Require Import Hask.Control.Applicative. 9 | Require Import Hask.Control.Comonad. 10 | Require Import Hask.Control.Monad.Free. 11 | Require Import Hask.Control.Monad.State. 12 | Require Import Hask.Control.Monad.Trans.Free. 13 | Require Import Hask.Control.Monad.Trans.State. 14 | Require Import Hask.Data.IntMap. 15 | Require Import Hask.Data.IntSet. 16 | Require Import Hask.Data.List.Church. 17 | Require Import Hask.Data.List. 18 | Require Import Hask.Data.Monoid. 19 | Require Import Hask.Data.NonEmpty. 20 | Require Import Hask.Data.Vector. 21 | Require Import Hask.Haskell. 22 | 23 | Separate Extraction 24 | Hask.Control.Applicative.Applicative 25 | Hask.Control.Monad.Trans.Free.Free 26 | FreeT 27 | Hask.Data.Functor.Functor 28 | Hask.Control.Monad.Monad 29 | apply 30 | bind 31 | (* catMaybes *) 32 | compose 33 | concatMapM 34 | const 35 | curry 36 | (* distance *) 37 | (* emptyIntMap *) 38 | (* emptyIntSet *) 39 | (* eqIntMap *) 40 | (* eqIntSet *) 41 | (* eq_op *) 42 | (* exist_in_cons *) 43 | extend 44 | (* fin_contra *) 45 | (* fin_ind *) 46 | (* fin_rect *) 47 | first 48 | flip 49 | foldM 50 | (* foldl_with_index *) 51 | foldrM 52 | (* foldr_with_index *) 53 | (* forFold *) 54 | forFoldM 55 | (* forFoldr *) 56 | forFoldrM 57 | forM 58 | forM_ 59 | (* fromChurch *) 60 | get 61 | (* getBy *) 62 | getT 63 | gets 64 | getsT 65 | isJust 66 | iterT 67 | kleisli_compose 68 | lebf 69 | (* lift *) 70 | liftA2 71 | liftCoyoneda 72 | liftF 73 | liftStateT 74 | (* list_membership *) 75 | lowerCoyoneda 76 | (* map_fst_filter_snd *) 77 | modify 78 | modifyT 79 | (* oddnum *) 80 | (* oends *) 81 | (* olast *) 82 | Maybe_choose 83 | Maybe_map 84 | Monoid.Monoid 85 | mempty 86 | mappend 87 | (* partition *) 88 | put 89 | putT 90 | runIdentityF 91 | (* safe_hd *) 92 | (* safe_last *) 93 | second 94 | (* sumlist *) 95 | (* toChurch *) 96 | (* to_from_Church *) 97 | undefined 98 | (* vapp *) 99 | (* vcons *) 100 | (* vconst *) 101 | (* vec_ind *) 102 | (* vec_rect *) 103 | (* vecn_ind *) 104 | (* vecn_rect *) 105 | (* vfoldl *) 106 | (* vfoldl_with_index *) 107 | (* vfoldr_with_index *) 108 | (* vmap *) 109 | (* vnil *) 110 | (* vnth *) 111 | (* vnth_vshiftin *) 112 | (* vreplace *) 113 | (* vshiftin *) 114 | (* vsing *) 115 | (* vec_to_seq *) 116 | (* seq_to_vec *). 117 | -------------------------------------------------------------------------------- /src/Control/Monad/Cont.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Data.Functor.Identity. 4 | Require Import Hask.Data.Functor.Yoneda. 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | 11 | Definition Cont (R A : Type) : Type := (A -> R) -> R. 12 | 13 | Definition Cont_map {R X Y} (f : X -> Y) (k : Cont R X) : Cont R Y := 14 | k \o (flip compose f). 15 | 16 | #[export] 17 | Instance Cont_Functor {R} : Functor (Cont R) := 18 | { fmap := @Cont_map R 19 | }. 20 | (* jww (2015-06-17): NYI 21 | Proof. 22 | - (* fun_identity *) 23 | intros. extensionality x. compute. destruct x; reflexivity. 24 | - (* fun_composition *) 25 | intros. extensionality x. compute. destruct x; reflexivity. 26 | Defined. 27 | *) 28 | 29 | Definition Cont_apply {R X Y} (kf : Cont R (X -> Y)) (kx : Cont R X) 30 | : Cont R Y := 31 | fun h => kf (fun f' => 32 | kx (fun x' => h (f' x'))). 33 | 34 | #[export] 35 | Instance Cont_Applicative {R} : Applicative (Cont R) := 36 | { is_functor := Cont_Functor 37 | ; pure := fun A x => fun k => k x 38 | ; ap := @Cont_apply R 39 | }. 40 | (* jww (2015-06-17): NYI 41 | Proof. 42 | - (* app_identity *) 43 | intros. extensionality x. compute. destruct x; reflexivity. 44 | - (* app_composition *) 45 | intros. compute. 46 | destruct u. 47 | destruct v; reflexivity. 48 | - (* app_homomorphism *) 49 | intros. compute. reflexivity. 50 | - (* app_interchange *) 51 | intros. compute. destruct u; reflexivity. 52 | - (* app_fmap_unit *) 53 | intros. extensionality x. compute. destruct x; reflexivity. 54 | Defined. 55 | *) 56 | 57 | Definition Cont_join {R X} (k : Cont R (Cont R X)) : Cont R X := 58 | fun h => k (fun km => km (fun x' => h x')). 59 | 60 | #[export] 61 | Instance Cont_Monad {R} : Monad (Cont R) := 62 | { is_applicative := Cont_Applicative 63 | ; join := @Cont_join R 64 | }. 65 | (* jww (2015-06-17): NYI 66 | Proof. 67 | - (* monad_law_1 *) 68 | intros. extensionality x. compute. 69 | destruct x. 70 | f_equal. extensionality p. 71 | f_equal. extensionality q. 72 | destruct q. 73 | f_equal. 74 | - (* monad_law_2 *) 75 | intros. extensionality x. compute. 76 | destruct x; reflexivity. 77 | - (* monad_law_3 *) 78 | intros. extensionality x. compute. 79 | destruct x; reflexivity. 80 | - (* monad_law_4 *) 81 | intros. extensionality x. compute. 82 | destruct x. 83 | f_equal. extensionality p. 84 | f_equal. extensionality q. 85 | destruct q. 86 | f_equal. 87 | Defined. 88 | *) 89 | 90 | Lemma Cont_parametricity : 91 | forall A B C (f : B -> C) (g : A -> B) (k : forall r, Cont r A), 92 | f (k B g) = k C (f \o g). 93 | Proof. 94 | intros. 95 | Import YonedaLaws. 96 | pose proof (@Yoneda_parametricity Identity _ _ _ _ k f). 97 | apply H. 98 | Qed. 99 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/LogicT.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | (* Require Import Hask.Control.Iso. *) 3 | Require Import Hask.Control.Monad. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | Set Asymmetric Patterns. 10 | 11 | Inductive LogicT (M : Type -> Type) `{Monad M} (A : Type) := 12 | LogicT_ : forall {R : Type}, ((A -> M R -> M R) -> M R -> M R) -> LogicT M A. 13 | 14 | Inductive LogicT' (M : Type -> Type) `{Monad M} (A : Type) := 15 | LogicT_' : forall {R : Type}, ((A -> R -> M R) -> R -> M R) -> LogicT' M A. 16 | 17 | Definition fromLogicT (M : Type -> Type) `{Monad M} (A : Type) 18 | (l : LogicT M A) : LogicT' M A := 19 | match l with 20 | LogicT_ _ await => 21 | LogicT_' M A (fun yield => 22 | await (compose (join[M]) \o (@fmap M _ _ _) \o yield) \o pure) 23 | end. 24 | 25 | Definition toLogicT (M : Type -> Type) `{Monad M} (A : Type) 26 | (l : LogicT' M A) : LogicT M A := 27 | match l with 28 | LogicT_' _ await => 29 | LogicT_ M A (fun yield => join \o fmap (await (fun x => yield x \o pure))) 30 | end. 31 | 32 | (* The condition J2 was given by Jones and Duponcheel as a condition in their 33 | treatment of "compatible" monads. I'm not yet certain what part it plays 34 | here. 35 | *) 36 | (* #[export] *) 37 | (* Instance LogicT_Restricted_Isomorphism (M : Type -> Type) `{Monad M} (A : Type) *) 38 | (* (J2 : forall A B (f : M A -> M B), join \o fmap f = f \o join) *) 39 | (* : LogicT' M A ≅ LogicT M A := *) 40 | (* { iso_to := toLogicT M A *) 41 | (* ; iso_from := fromLogicT M A *) 42 | (* }. *) 43 | (* jww (2015-06-17): NYI 44 | Proof. 45 | intros. 46 | - extensionality x. 47 | unfold id. 48 | destruct x. 49 | unfold compose. 50 | simpl. f_equal. 51 | unfold flip, bind. 52 | extensionality p. extensionality q. 53 | unfold compose. 54 | rewrite <- app_fmap_compose_x. 55 | rewrite monad_law_3_x. 56 | f_equal. 57 | extensionality p0. extensionality q0. 58 | unfold compose. 59 | rewrite <- app_fmap_compose_x. 60 | rewrite monad_law_3_x. 61 | reflexivity. 62 | - extensionality x. 63 | unfold id. destruct x. 64 | unfold compose. simpl. 65 | unfold compose at 5. 66 | f_equal. extensionality x. 67 | rewrite <- fun_composition. 68 | rewrite comp_assoc. 69 | rewrite J2. 70 | rewrite <- comp_assoc. 71 | rewrite monad_law_2. 72 | rewrite comp_id_right. 73 | f_equal. extensionality y. 74 | unfold compose at 2. 75 | unfold compose at 1. 76 | extensionality x0. 77 | assert ((join[M]) ((fmap[M] (x y \o pure[M])) x0) = 78 | (join[M] \o fmap[M] (x y \o pure[M])) x0). 79 | auto. rewrite H0. clear H0. 80 | rewrite <- fun_composition. 81 | rewrite comp_assoc. 82 | rewrite J2. 83 | rewrite <- comp_assoc. 84 | rewrite monad_law_2. 85 | reflexivity. 86 | Defined. 87 | *) 88 | -------------------------------------------------------------------------------- /src/Control/Monad/State.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | (****************************************************************************** 13 | * The State Monad 14 | *) 15 | 16 | Definition State (s a : Type) := s -> (a * s). 17 | 18 | Definition get {s : Type} : State s s := fun i => (i, i). 19 | Definition gets {s a : Type} f : State s a := fun s => (f s, s). 20 | Definition put {s : Type} x : State s unit := fun _ => (tt, x). 21 | 22 | Definition modify {s : Type} (f : s -> s) : State s unit := fun i => (tt, f i). 23 | 24 | #[export] 25 | Program Instance State_Functor {s : Type} : Functor (State s) := { 26 | fmap := fun A B f (x : State s A) => fun st => match x st with 27 | | (a,st') => (f a, st') 28 | end 29 | }. 30 | 31 | #[export] 32 | Program Instance State_Applicative {s : Type} : Applicative (State s) := { 33 | pure := fun _ x => fun st => (x, st); 34 | 35 | ap := fun _ _ f x => fun st => match f st with 36 | | (f', st') => 37 | match x st' with 38 | | (x', st'') => (f' x', st'') 39 | end 40 | end 41 | }. 42 | 43 | #[export] 44 | Program Instance State_Monad {s : Type} : Monad (State s) := { 45 | join := fun _ x => fun st => match x st with 46 | | (y, st') => match y st' with 47 | | (a, st'') => (a, st'') 48 | end 49 | end 50 | }. 51 | 52 | Require Import FunctionalExtensionality. 53 | 54 | Module StateLaws. 55 | 56 | Include MonadLaws. 57 | 58 | #[export] 59 | Program Instance State_FunctorLaws {s : Type} : FunctorLaws (State s). 60 | Obligation 1. 61 | extensionality x. 62 | extensionality st. 63 | unfold id. 64 | destruct (x st); auto. 65 | Qed. 66 | Obligation 2. 67 | extensionality x. 68 | extensionality st. 69 | unfold comp. 70 | destruct (x st); auto. 71 | Qed. 72 | 73 | #[export] 74 | Program Instance State_Applicative {s : Type} : ApplicativeLaws (State s). 75 | Obligation 1. 76 | extensionality x. 77 | extensionality st. 78 | unfold id. 79 | destruct (x st); auto. 80 | Qed. 81 | Obligation 2. 82 | extensionality st. 83 | destruct (u st) as [f' st']. 84 | destruct (v st') as [f'' st'']. 85 | destruct (w st''); auto. 86 | Qed. 87 | 88 | #[export] 89 | Program Instance State_Monad {s : Type} : MonadLaws (State s). 90 | Obligation 1. 91 | extensionality f. 92 | extensionality st. 93 | unfold comp; simpl. 94 | destruct (f st) as [f' st']. 95 | destruct (f' st') as [f'' st'']. 96 | destruct (f'' st'') as [f''' st''']; auto. 97 | Qed. 98 | Obligation 2. 99 | extensionality f. 100 | extensionality st. 101 | unfold comp, id; simpl. 102 | destruct (f st) as [f' st']; auto. 103 | Qed. 104 | Obligation 3. 105 | extensionality f. 106 | extensionality st. 107 | unfold comp, id; simpl. 108 | destruct (f st) as [f' st']; auto. 109 | Qed. 110 | Obligation 4. 111 | extensionality x. 112 | extensionality st. 113 | unfold comp; simpl. 114 | destruct (x st) as [f' st']. 115 | destruct (f' st') as [f'' st'']; auto. 116 | Qed. 117 | 118 | End StateLaws. 119 | -------------------------------------------------------------------------------- /src/Data/Either.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Control.Monad. 2 | 3 | Generalizable All Variables. 4 | Set Primitive Projections. 5 | Set Universe Polymorphism. 6 | Unset Transparent Obligations. 7 | 8 | Notation Either := sum (only parsing). 9 | Notation Left := inl (only parsing). 10 | Notation Right := inr (only parsing). 11 | 12 | Definition isLeft `(x : a + b) : bool := if x then true else false. 13 | Definition isRight `(x : a + b) : bool := if x then false else true. 14 | 15 | Definition either `(f : a -> c) `(g : b -> c) (x : a + b) : c := 16 | match x with 17 | | inl a => f a 18 | | inr b => g b 19 | end. 20 | 21 | Definition mapLeft `(f : a -> c) `(x : a + b) : c + b := 22 | match x with 23 | | inl l => inl (f l) 24 | | inr r => inr r 25 | end. 26 | 27 | Definition Either_map {E X Y} (f : X -> Y) (x : Either E X) : Either E Y := 28 | match x with 29 | | Left e => Left e 30 | | Right x' => Right (f x') 31 | end. 32 | 33 | Definition Either_apply {E X Y} (f : Either E (X -> Y)) (x : Either E X) 34 | : Either E Y := 35 | match f with 36 | | Left e => Left e 37 | | Right f' => match x with 38 | | Left e => Left e 39 | | Right x' => Right (f' x') 40 | end 41 | end. 42 | 43 | Definition Either_join {E X} (x : Either E (Either E X)) : Either E X := 44 | match x with 45 | | Left e => Left e 46 | | Right (Left e) => Left e 47 | | Right (Right x') => Right x' 48 | end. 49 | 50 | #[export] 51 | Instance Either_Functor {E} : Functor (Either E) := 52 | { fmap := @Either_map E 53 | }. 54 | (* jww (2015-06-17): NYI 55 | Proof. 56 | - (* fun_identity *) 57 | intros. extensionality x. compute. destruct x; reflexivity. 58 | - (* fun_composition *) 59 | intros. extensionality x. compute. destruct x; reflexivity. 60 | Defined. 61 | *) 62 | 63 | #[export] 64 | Instance Either_Applicative {E} : Applicative (Either E) := 65 | { is_functor := Either_Functor 66 | ; pure := @Right E 67 | ; ap := @Either_apply E 68 | }. 69 | (* jww (2015-06-17): NYI 70 | Proof. 71 | - (* app_identity *) 72 | intros. extensionality x. compute. destruct x; reflexivity. 73 | - (* app_composition *) 74 | intros. compute. 75 | destruct u. 76 | destruct v; reflexivity. 77 | destruct v. reflexivity. destruct w; reflexivity. 78 | - (* app_homomorphism *) 79 | intros. compute. reflexivity. 80 | - (* app_interchange *) 81 | intros. compute. destruct u; reflexivity. 82 | - (* app_fmap_unit *) 83 | intros. extensionality x. compute. destruct x; reflexivity. 84 | Defined. 85 | *) 86 | 87 | #[export] 88 | Instance Either_Monad {E} : Monad (Either E) := 89 | { is_applicative := Either_Applicative 90 | ; join := @Either_join E 91 | }. 92 | (* jww (2015-06-17): NYI 93 | Proof. 94 | - (* monad_law_1 *) 95 | intros. extensionality x. compute. 96 | destruct x. 97 | reflexivity. 98 | destruct e. 99 | reflexivity. 100 | destruct e; reflexivity. 101 | - (* monad_law_2 *) 102 | intros. extensionality x. compute. 103 | destruct x; reflexivity. 104 | - (* monad_law_3 *) 105 | intros. extensionality x. compute. 106 | destruct x; reflexivity. 107 | - (* monad_law_4 *) 108 | intros. extensionality x. compute. 109 | destruct x. 110 | reflexivity. 111 | destruct e; reflexivity. 112 | Defined. 113 | *) 114 | -------------------------------------------------------------------------------- /src/Control/Lens.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Data.Functor.Contravariant. 4 | Require Import Hask.Data.Functor.Identity. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | Generalizable All Variables. 10 | Set Primitive Projections. 11 | Unset Transparent Obligations. 12 | 13 | Definition Lens s t a b := forall f, Functor f -> (a -> f b) -> s -> f t. 14 | Definition Lens' s a := Lens s s a a. 15 | 16 | Definition Getter s a := 17 | forall f, Functor f -> Contravariant f -> (a -> f a) -> s -> f s. 18 | 19 | Definition Getting r s a := (a -> Const r a) -> s -> Const r s. 20 | 21 | Notation "x &+ f" := (f x) (at level 41, only parsing). 22 | 23 | Definition set `(l : Lens s t a b) (x : b) : s -> t := 24 | runIdentityF \o l _ _ (fun _ => Id _ x). 25 | Notation "l .~ x" := (set l x) (at level 40). 26 | 27 | Definition over `(l : Lens s t a b) (f : a -> b) : s -> t := 28 | runIdentityF \o l _ _ (fun x => Id _ (f x)). 29 | Notation "l %~ f" := (over l f) (at level 40). 30 | 31 | Definition view `(f : Getting a s a) : s -> a := f id. 32 | Notation "x ^_ l" := (view l x) (at level 40). 33 | 34 | Definition stepdownl' `(l : Lens' s a) : Getting a s a := l _ _. 35 | Coercion stepdownl' : Lens' >-> Getting. 36 | 37 | Definition stepdowng `(l : Getter s a) : Getting a s a := l _ _ _. 38 | Coercion stepdowng : Getter >-> Getting. 39 | 40 | Notation "f \o+ g" := (fun x y => f x y \o g x y) (at level 41, only parsing). 41 | 42 | Definition _1 {a b : Type} : Lens' (a * b) a := 43 | fun _ _ f s => match s with (x, y) => fmap (fun z => (z, y)) (f x) end. 44 | Definition _2 {a b : Type} : Lens' (a * b) b := 45 | fun _ _ f s => match s with (x, y) => fmap (fun z => (x, z)) (f y) end. 46 | 47 | Definition _ex1 {a : Type} {P : a -> Prop} : Getter { x : a | P x } a := 48 | fun _ _ _ f s => fmap (const s) (f (proj1_sig s)). 49 | 50 | Require Import Hask.Control.Monad.Trans.State. 51 | 52 | Definition use `(l : Getting a s a) `{Monad m} : StateT s m a := 53 | view l <$> getT. 54 | 55 | Definition plusStateT `(l : Lens' s nat) (n : nat) `{Monad m} : 56 | StateT s m unit := modifyT (l %~ plus n). 57 | 58 | Notation "l += n" := (plusStateT l n) (at level 41). 59 | 60 | Definition modifyStateT `(l : Lens' s a) (x : a) `{Monad m} : 61 | StateT s m unit := modifyT (l .~ x). 62 | 63 | Notation "l .= x" := (modifyStateT l x) (at level 41). 64 | 65 | Definition applyStateT `(l : Lens' s a) (f : a -> a) `{Monad m} : 66 | StateT s m unit := modifyT (l %~ f). 67 | 68 | Notation "l %= f" := (applyStateT l f) (at level 41). 69 | 70 | Module LensLaws. 71 | 72 | Class LensLaws `(l : Lens' s a) := { 73 | lens_view_set : forall (x : s) (y : a), view l (set l y x) = y; 74 | lens_set_view : forall (x : s), set l (view l x) x = x; 75 | lens_set_set : forall (x : s) (y z : a), set l z (set l y x) = set l z x 76 | }. 77 | 78 | #[export] 79 | Program Instance Lens__1 {a b} : LensLaws (s:=a * b) _1. 80 | #[export] 81 | Program Instance Lens__2 {a b} : LensLaws (s:=a * b) _2. 82 | 83 | Example lens_ex1 : view _1 (10, 20) = 10. 84 | Proof. reflexivity. Qed. 85 | 86 | Example lens_ex2 : view _2 (10, 20) = 20. 87 | Proof. reflexivity. Qed. 88 | 89 | Example lens_ex3 : (10, 20) ^_ _2 = 20. 90 | Proof. reflexivity. Qed. 91 | 92 | Example lens_ex4 : (1, (2, (3, 4))) ^_ stepdownl' (_2 \o+ _2 \o+ _2) = 4. 93 | Proof. reflexivity. Qed. 94 | 95 | Example lens_ex5 : ((10, 20) &+ _1 .~ 500) = (500, 20). 96 | Proof. reflexivity. Qed. 97 | 98 | Example lens_ex6 : ((10, 20) &+ _1 %~ plus 1) = (11, 20). 99 | Proof. reflexivity. Qed. 100 | 101 | End LensLaws. 102 | -------------------------------------------------------------------------------- /src/Control/Monad/Eff.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Hask.Control.Monad 3 | Hask.Data.Maybe 4 | Coq.Lists.List. 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | 11 | Import ListNotations. 12 | 13 | Definition Effect := (Type -> Type) -> Type. 14 | 15 | Inductive Effects (m : Type -> Type) : list Effect -> Type := 16 | | NilE : Effects m [] 17 | | ConsE effects : forall effect : Effect, 18 | effect m -> Effects m effects -> Effects m (effect :: effects). 19 | 20 | Arguments ConsE : default implicits. 21 | 22 | Definition combine `(e : effect m) `(xs : Effects m effects) : 23 | Effects m (effect :: effects) := ConsE _ e xs. 24 | 25 | Infix ".:" := combine (at level 48, right associativity). 26 | 27 | Class Handles (fs : list Effect) (effect : Effect) := { 28 | getEffect : forall m, Effects m fs -> effect m 29 | }. 30 | 31 | #[export] 32 | Instance Handles_hd {fs : list Effect} {f : Effect} : 33 | Handles (f :: fs) f. 34 | Proof. 35 | constructor; intros. 36 | inversion X. 37 | exact X0. 38 | Defined. 39 | 40 | #[export] 41 | Instance Handles_tl `{_ : Handles fs f} : Handles (x :: fs) f. 42 | Proof. 43 | constructor; intros. 44 | inversion H. 45 | apply getEffect0. 46 | inversion X. 47 | exact X1. 48 | Defined. 49 | 50 | Definition TFree `(xs : list Effect) m a := 51 | Effects m xs -> m a. 52 | 53 | Definition Eff := TFree. 54 | 55 | Definition liftF `{Handles effects effect} `{Monad m} 56 | `(getOp : effect m -> m a) : Eff effects m a := 57 | fun effects => getOp (getEffect m effects). 58 | 59 | Definition interpret `{H : Monad m} `(interpreter : Effects m effects) 60 | `(program : Eff effects m a) : m a := program interpreter. 61 | 62 | #[export] 63 | Instance TFree_Functor `(xs : list Effect) `{Monad m} : Functor (TFree xs m) := { 64 | fmap := fun A B f run => fun xs => fmap f (run xs) 65 | }. 66 | 67 | #[export] 68 | Instance TFree_Applicative `(xs : list Effect) `{Monad m} : Applicative (TFree xs m) := { 69 | pure := fun _ x => fun xs => pure x; 70 | ap := fun A B runf runx => fun xs => runf xs <*> runx xs 71 | }. 72 | 73 | #[export] 74 | Instance TFree_Monad `(xs : list Effect) `{Monad m} : Monad (TFree xs m) := { 75 | join := fun A run => fun xs => run xs >>= fun f => f xs 76 | }. 77 | 78 | Record Abortive (m : Type -> Type) := { 79 | abortE : m unit 80 | }. 81 | 82 | Definition abort `{Handles r Abortive} : Eff r unit := 83 | liftF abortE. 84 | 85 | Record Reader (e : Type) (m : Type -> Type) := { 86 | askE : m e 87 | }. 88 | 89 | Definition ask `{Handles r (Reader e)} : Eff r e := 90 | liftF (askE e). 91 | 92 | Require Import Arith. 93 | 94 | Set Printing Universes. 95 | 96 | Definition example1 `{Handles r (Reader nat)} `{Handles r Abortive} : 97 | Eff r nat := 98 | (fun x y => y + 15) <$> abort <*> ask. 99 | 100 | Definition maybeInterpreter : Effects Maybe [Reader nat; Abortive] := 101 | combine {| askE := Just 10 |} (combine {| abortE := Nothing |} (NilE _)). 102 | 103 | Definition run {a} : Eff [Reader nat; Abortive] a -> Maybe a := 104 | interpret maybeInterpreter. 105 | 106 | Example run_example1 : run example1 = Nothing. 107 | Proof. reflexivity. Qed. 108 | 109 | Definition example2 `{Handles r (Reader nat)} : Eff r nat := 110 | fmap (plus 15) ask. 111 | 112 | Example run_example2 : run example2 = Just 25. 113 | Proof. reflexivity. Qed. 114 | 115 | (* 116 | Definition example3 `{Handles r (Reader nat)} `{Handles r Abortive} : 117 | Eff r nat := 118 | v <- ask; 119 | if leb v 15 120 | then abort ;; pure 0 121 | else pure (v+1). 122 | 123 | Example run_example3 : run example3 = None. 124 | Proof. reflexivity. Qed. 125 | *) 126 | -------------------------------------------------------------------------------- /src/Data/Tuple.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Ltac. 2 | (* Require Import Hask.Control.Iso. *) 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | (* 10 | #[export] 11 | Instance LTuple_Isomorphism {A} : (unit * A) ≅ A := 12 | { iso_to := @snd unit A 13 | ; iso_from := pair tt 14 | }. 15 | (* jww (2015-06-17): NYI 16 | Obligation 1. (* iso_to *) 17 | intros. extensionality x. destruct x. compute. destruct u. reflexivity. 18 | Defined. 19 | *) 20 | 21 | #[export] 22 | Instance RTuple_Isomorphism {A} : (A * unit) ≅ A := 23 | { iso_to := @fst A unit 24 | ; iso_from := fun x => (x, tt) 25 | }. 26 | (* jww (2015-06-17): NYI 27 | Obligation 1. (* iso_to *) 28 | intros. extensionality x. destruct x. compute. destruct u. reflexivity. 29 | Defined. 30 | *) 31 | *) 32 | 33 | Definition tuple_swap_a_bc_to_ab_c {A B C} (x : A * (B * C)) : A * B * C := 34 | match x with (a, (b, c)) => ((a, b), c) end. 35 | 36 | Definition tuple_swap_ab_c_to_a_bc {A B C} (x : A * B * C) : A * (B * C) := 37 | match x with ((a, b), c) => (a, (b, c)) end. 38 | 39 | Definition left_triple {A B C} (x : A) (y : B) (z : C) : A * B * C := 40 | ((x, y), z). 41 | 42 | Definition right_triple {A B C} (x : A) (y : B) (z : C) : A * (B * C) := 43 | (x, (y, z)). 44 | 45 | (* 46 | #[export] 47 | Instance Tuple_Assoc {A B C} : (A * B * C) ≅ (A * (B * C)) := 48 | { iso_to := tuple_swap_ab_c_to_a_bc 49 | ; iso_from := tuple_swap_a_bc_to_ab_c 50 | }. 51 | (* jww (2015-06-17): NYI 52 | Obligation 1. (* iso_to *) 53 | intros. 54 | extensionality x. 55 | unfold compose. 56 | destruct x. 57 | destruct p. 58 | unfold id. 59 | unfold tuple_swap_a_bc_to_ab_c, tuple_swap_ab_c_to_a_bc. 60 | reflexivity. 61 | Defined. 62 | Obligation 2. (* iso_from *) 63 | intros. 64 | extensionality x. 65 | unfold compose. 66 | destruct x. 67 | destruct p. 68 | unfold id. 69 | unfold tuple_swap_a_bc_to_ab_c, tuple_swap_ab_c_to_a_bc. 70 | reflexivity. 71 | Defined. 72 | *) 73 | *) 74 | 75 | Definition first `(f : a -> b) `(x : a * z) : b * z := 76 | match x with (a, z) => (f a, z) end. 77 | 78 | Definition second `(f : a -> b) `(x : z * a) : z * b := 79 | match x with (z, b) => (z, f b) end. 80 | 81 | Definition curry `(f : a -> b -> c) (x : (a * b)) : c := 82 | match x with (a, b) => f a b end. 83 | 84 | Definition uncurry {X Y Z} (f : X -> Y -> Z) (xy : X * Y) : Z := 85 | match xy with (x, y) => f x y end. 86 | 87 | Theorem uncurry_works : forall {X Y Z} (x : X) (y : Y) (f : X -> Y -> Z), 88 | uncurry f (x, y) = f x y. 89 | Proof. reflexivity. Qed. 90 | 91 | Lemma fst_snd : forall a b (z : a * b), 92 | (let '(x, y) := z in (x, y)) = (fst z, snd z). 93 | Proof. intros ? ? [?]; auto. Qed. 94 | 95 | Require Import Coq.Lists.List. 96 | 97 | Lemma unsplit : forall a b (xs : list (a * b)), 98 | map (fun x => (fst x, snd x)) xs = xs. 99 | Proof. 100 | intros. 101 | induction xs as [|x xs IHxs]; auto; simpl. 102 | rewrite IHxs. 103 | destruct x; auto. 104 | Qed. 105 | 106 | Definition prod_map {A B C : Type} (f : A -> B) (x : C * A) : C * B := 107 | match x with (a, b) => (a, f b) end. 108 | 109 | Require Import FunctionalExtensionality. 110 | 111 | Module TupleLaws. 112 | 113 | Theorem prod_map_id {E A} : @prod_map A A E id = id. 114 | Proof. 115 | extensionality x. 116 | destruct x; auto. 117 | Qed. 118 | 119 | Theorem prod_map_comp {E A B C} (f : B -> C) (g : A -> B) : 120 | @prod_map B C E f \o @prod_map A B E g = @prod_map A C E (f \o g). 121 | Proof. 122 | extensionality x. 123 | destruct x; auto. 124 | Qed. 125 | 126 | Corollary prod_map_comp_x {E A B C} (f : B -> C) (g : A -> B) (x : E * A) : 127 | prod_map f (prod_map g x) = prod_map (fun x => f (g x)) x. 128 | Proof. destruct x; auto. Qed. 129 | 130 | End TupleLaws. 131 | -------------------------------------------------------------------------------- /src/Prelude.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Ltac. 2 | Require Export Hask.Data.Either. 3 | Require Export Hask.Data.Maybe. 4 | Require Export Hask.Data.Tuple. 5 | Require Export Hask.Data.Functor. 6 | Require Export Coq.micromega.Lia. 7 | 8 | Generalizable All Variables. 9 | Set Primitive Projections. 10 | Set Universe Polymorphism. 11 | Unset Transparent Obligations. 12 | Set Implicit Arguments. 13 | Unset Strict Implicit. 14 | Unset Printing Implicit Defensive. 15 | 16 | Definition undefined {a : Type} : a. Admitted. 17 | 18 | Notation "f $ x" := (f x) (at level 60, right associativity, only parsing). 19 | 20 | Definition flip `(f : a -> b -> c) : b -> a -> c := fun y x => f x y. 21 | 22 | Definition const {A B : Type} (x : B) : A -> B := fun _ => x. 23 | 24 | Definition apply `(f : a -> b) (x : a) : b := f x. 25 | 26 | Definition compose {a b c : Type} (f : b -> c) (g : a -> b) : a -> c := f \o g. 27 | 28 | Lemma compA {a b c d : Type} (h : a -> b) (g : b -> c) (f : c -> d) : 29 | (f \o g) \o h = f \o (g \o h). 30 | Proof. reflexivity. Qed. 31 | 32 | Notation "f .: g" := (fun x y => f (g x y)) (at level 100). 33 | 34 | (* 35 | Lemma sym_neg : forall a (R : rel a), symmetric R -> symmetric (negb .: R). 36 | Proof. 37 | move=> a R H x y. 38 | by rewrite H. 39 | Qed. 40 | *) 41 | 42 | Definition lebf {a : Type} (f : a -> nat) (n m : a) := f n <= f m. 43 | 44 | (* 45 | Definition oddnum := { n : nat | odd n }. 46 | 47 | Program Definition odd1 := exist odd 1 _. 48 | 49 | Lemma odd_gt1 : forall n, odd n -> n >= 1. 50 | Proof. by elim. Qed. 51 | 52 | Lemma odds1 : forall n, odd n -> ~~ odd (n.-1). 53 | Proof. by elim. Qed. 54 | 55 | Lemma odd_double_plus (n : nat) : odd n.*2.+1. 56 | Proof. 57 | elim: n => [|n IHn] //=. 58 | apply/negPn. 59 | by rewrite odd_double. 60 | Qed. 61 | 62 | Lemma isP : forall x : bool, x = true -> x. 63 | Proof. by []. Qed. 64 | 65 | Lemma has_over_false A (f : A -> bool) (xs : seq A) : 66 | has (fun x => f x || false) xs = has f xs. 67 | Proof. 68 | elim: xs => //= [x xs IHxs]. 69 | by rewrite !Bool.orb_false_r IHxs. 70 | Qed. 71 | 72 | Lemma has_flip A (R : rel A) (_ : symmetric R) (xs ys : seq A) : 73 | has (fun x => has (fun y => R x y) ys) xs 74 | = has (fun y => has (fun x => R y x) xs) ys. 75 | Proof. 76 | elim: xs => /= [|x xs IHxs]. 77 | by elim: ys. 78 | rewrite has_predU {}IHxs. 79 | f_equal. 80 | elim: ys => //= [y ys IHys]. 81 | by rewrite IHys H. 82 | Qed. 83 | 84 | Lemma ltn_odd n m : odd n && odd m -> n < m -> n.+1 < m. 85 | Proof. 86 | move/andP=> [nodd modd] Hlt. 87 | rewrite -subn_gt0 odd_gt0 // odd_sub // modd /=. 88 | exact/negPn. 89 | Qed. 90 | 91 | Lemma odd_minn : forall x y, odd x -> odd y -> odd (minn x y). 92 | Proof. 93 | move=> x y Hx Hy. 94 | rewrite /minn. 95 | by case: (x < y). 96 | Qed. 97 | 98 | Definition distance (n m : nat) : nat := if n < m then m - n else n - m. 99 | *) 100 | 101 | Lemma ltn_plus : forall m n, 0 < n -> m < m + n. 102 | Proof. intros; lia. Qed. 103 | 104 | Lemma leq_plus : forall m n, m <= m + n. 105 | Proof. intros; lia. Qed. 106 | 107 | Lemma leq_add2r : forall p m n : nat, m <= n -> m + p <= n + p. 108 | Proof. intros; lia. Qed. 109 | 110 | Lemma leq_add2l : forall p m n : nat, m <= n -> p + m <= p + n. 111 | Proof. intros; lia. Qed. 112 | 113 | (* 114 | Lemma leq_eqF : forall n m, (n == m) = false -> n <= m -> n < m. 115 | Proof. 116 | move=> n m. 117 | move/eqP=> H1 H2. 118 | by ordered. 119 | Qed. 120 | 121 | Lemma leq_double_r : forall n m, n <= m -> n <= m.*2. 122 | Proof. 123 | move=> n m H. 124 | rewrite -muln2. 125 | have ->: n = n * 1 by ordered. 126 | exact: leq_mul. 127 | Qed. 128 | *) 129 | 130 | Lemma ltn0ltn : forall n m, n < m -> 0 < m. 131 | Proof. intros; lia. Qed. 132 | 133 | Lemma ltn_subn : forall n m, n < m -> m > 0 -> n <= m - 1. 134 | Proof. intros; lia. Qed. 135 | -------------------------------------------------------------------------------- /src/Control/Compose.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Data.Functor. 2 | Require Import Hask.Control.Applicative. 3 | Require Import Hask.Control.Monad. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | #[export] 11 | Instance Compose_Functor `{Functor F} `{Functor G} : Functor (F \o G) := 12 | { fmap := fun A B => @fmap F _ (G A) (G B) \o @fmap G _ A B 13 | }. 14 | 15 | #[export] 16 | Instance Compose_Applicative (F : Type -> Type) (G : Type -> Type) 17 | `{Applicative F} `{Applicative G} : Applicative (F \o G) := 18 | { is_functor := Compose_Functor (F:=F) (G:=G) 19 | ; pure := fun A => @pure F _ (G A) \o @pure G _ A 20 | ; ap := fun A B => ap \o fmap (@ap G _ A B) 21 | }. 22 | 23 | #[export] 24 | Instance Compose_Alternative 25 | `{Alternative F} `{Alternative G} : Alternative (F \o G) := 26 | { empty := fun A => @empty F _ (G A) 27 | ; choose := fun A => @choose F _ (G A) (* jww (2016-01-28): correct? *) 28 | }. 29 | 30 | #[export] 31 | Instance Compose_Monad `{Monad_Distributes M N} 32 | : Monad (M \o N) := 33 | { is_applicative := Compose_Applicative M N 34 | ; join := fun A => join[M] \o fmap[M] (prod M N A) 35 | }. 36 | 37 | Require Import FunctionalExtensionality. 38 | 39 | Module ComposeMonadLaws. 40 | 41 | Import MonadLaws. 42 | 43 | Corollary fmap_compose `{Functor F} `{Functor G} : forall {X Y} (f : X -> Y), 44 | @fmap F _ (G X) (G Y) (@fmap G _ X Y f) = @fmap (F \o G) _ X Y f. 45 | Proof. reflexivity. Qed. 46 | 47 | #[export] 48 | Program Instance Compose_FunctorLaws `{FunctorLaws F} `{FunctorLaws G} : 49 | FunctorLaws (F \o G). 50 | Obligation 1. (* fmap_id *) 51 | extensionality x. 52 | do 2 rewrite fmap_id. 53 | reflexivity. 54 | Qed. 55 | Obligation 2. (* fmap_comp *) 56 | extensionality x. 57 | do 2 rewrite fmap_comp. 58 | reflexivity. 59 | Qed. 60 | 61 | Local Obligation Tactic := intros; simpl; apply_applicative_laws. 62 | 63 | #[export] 64 | Program Instance Compose_ApplicativeLaws 65 | `{ApplicativeLaws F} `{ApplicativeLaws G} : ApplicativeLaws (F \o G). 66 | Obligation 2. (* ap_composition *) 67 | (* Discharge w *) 68 | rewrite <- ap_comp; f_equal. 69 | (* Discharge v *) 70 | rewrite <- !ap_fmap, <- ap_comp. 71 | symmetry. 72 | rewrite <- ap_comp; f_equal. 73 | (* Discharge u *) 74 | apply_applicative_laws. 75 | f_equal. 76 | extensionality y. 77 | extensionality x. 78 | extensionality x0. 79 | rewrite <- ap_comp, ap_fmap. 80 | reflexivity. 81 | Qed. 82 | 83 | #[export] 84 | Program Instance Compose_MonadLaws 85 | `{Monad_DistributesLaws M N (H:=Compose_Applicative M N)} : 86 | MonadLaws (M \o N). 87 | Obligation 1. (* monad_law_1 *) 88 | intros. 89 | rewrite <- comp_assoc with (f := join[M]). 90 | rewrite <- comp_assoc with (f := join[M]). 91 | rewrite comp_assoc with (f := fmap[M] (prod M N a)). 92 | rewrite <- join_fmap_fmap. 93 | rewrite <- comp_assoc. 94 | rewrite comp_assoc with (f := join[M]). 95 | rewrite comp_assoc with (f := join[M]). 96 | rewrite <- join_fmap_join. 97 | repeat (rewrite <- comp_assoc). 98 | repeat (rewrite fmap_comp). 99 | repeat (rewrite comp_assoc). 100 | rewrite <- prod_fmap_join_fmap_prod. 101 | reflexivity. 102 | Qed. 103 | Obligation 2. (* monad_law_2 *) 104 | intros. 105 | rewrite <- join_fmap_pure. 106 | repeat (rewrite <- comp_assoc). 107 | repeat (rewrite fmap_comp). 108 | repeat f_equal. 109 | pose proof (@prod_fmap_pure M N _ _ _ _ _ a). 110 | simpl in H3. 111 | rewrite H3. 112 | reflexivity. 113 | Qed. 114 | Obligation 3. (* monad_law_3 *) 115 | intros. 116 | rewrite <- prod_pure. 117 | rewrite <- comp_id_left. 118 | rewrite <- (@join_pure M _ _ (N a)). 119 | rewrite <- comp_assoc. 120 | rewrite <- comp_assoc. 121 | f_equal. 122 | rewrite comp_assoc. 123 | rewrite comp_assoc. 124 | f_equal. 125 | rewrite <- fmap_pure. 126 | reflexivity. 127 | Qed. 128 | Obligation 4. (* monad_law_4 *) 129 | intros. 130 | unfold comp at 2. 131 | rewrite comp_assoc. 132 | rewrite <- join_fmap_fmap. 133 | rewrite <- comp_assoc. 134 | rewrite fmap_comp. 135 | pose proof (@prod_fmap_fmap M N _ _ _ _ _ a). 136 | simpl in H3. 137 | rewrite <- H3. 138 | rewrite <- fmap_comp. 139 | reflexivity. 140 | Qed. 141 | 142 | End ComposeMonadLaws. 143 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Free.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Control.Monad. 2 | 3 | Generalizable All Variables. 4 | Set Primitive Projections. 5 | Set Universe Polymorphism. 6 | Unset Transparent Obligations. 7 | Set Asymmetric Patterns. 8 | 9 | Definition FreeT (f m : Type -> Type) (a : Type) := 10 | forall r, (a -> m r) -> (forall x, (x -> m r) -> f x -> m r) -> m r. 11 | 12 | Definition iterT `{Functor f} `{Monad m} 13 | `(phi : f (m a) -> m a) (ft : FreeT f m a) : m a := 14 | ft _ pure (fun _ h x => phi (fmap h x)). 15 | 16 | (* iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) 17 | => (f (t m a) -> t m a) -> FreeT f m a -> t m a *) 18 | 19 | (* Tear down a free monad transformer using iteration over a transformer. *) 20 | 21 | (* hoistFreeT :: (Monad m, Functor f) 22 | => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b *) 23 | 24 | (* Lift a monad homomorphism from m to n into a monad homomorphism from FreeT 25 | f m to FreeT f n *) 26 | 27 | (* hoistFreeT :: (Monad m, Functor f) => (m ~> n) -> FreeT f m ~> FreeT f n *) 28 | 29 | (* transFreeT :: (Monad m, Functor g) 30 | => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b *) 31 | 32 | (* Lift a natural transformation from f to g into a monad homomorphism from 33 | FreeT f m to FreeT g m *) 34 | 35 | (* joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a) *) 36 | 37 | Inductive FreeF (f : Type -> Type) (a b : Type) := 38 | | Pure : a -> FreeF f a b 39 | | Free : f b -> FreeF f a b. 40 | 41 | Arguments Pure {f a b} _. 42 | Arguments Free {f a b} _. 43 | 44 | Inductive FreeTi (f m : Type -> Type) (a : Type) := 45 | | FT : forall x, (x -> FreeTi f m a) -> m (FreeF f a x) -> FreeTi f m a. 46 | 47 | Arguments FT {f m a x} _ _. 48 | 49 | Definition liftF {f : Type -> Type} `{Monad m} {a : Type} (x : f a) : 50 | FreeT f m a := fun _ k h => h a k x. 51 | 52 | Definition liftFM `{Monad m} {f} `(x : m a) : FreeT f m a := 53 | fun _ k _ => x >>= k. 54 | 55 | Fixpoint iterTi `{Functor f} `{Monad m} 56 | `(phi : f (m a) -> m a) (ft : FreeTi f m a) : m a := 57 | match ft with FT s k z => 58 | y <- z ; 59 | match y with 60 | | Pure x => @pure m _ a x 61 | | Free x => phi (fmap (iterTi phi \o k) x) 62 | end 63 | end. 64 | 65 | (* Definition retractT (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a *) 66 | 67 | (* Definition wrap `{Functor f} `{Monad m} {a} : *) 68 | (* f (FreeTi f m a) -> FreeTi f m a := FT id \o pure \o Free. *) 69 | 70 | (* Definition fromFreeT `{Functor f} `{Monad m} `(z : FreeT f m a) : *) 71 | (* FreeTi f m a := *) 72 | (* join $ z _ (pure \o Pure) $ fun _ h x => *) 73 | (* tt. *) 74 | 75 | Fixpoint toFreeT `{Functor f} `{Monad m} `(ft : FreeTi f m a) : FreeT f m a := 76 | fun s k h => 77 | match ft with FT _ g z => 78 | y <- z ; 79 | match y with 80 | | Pure x => k x 81 | | Free fb => h _ (fun x => toFreeT (g x) _ k h) fb 82 | end 83 | end. 84 | 85 | #[export] 86 | Program Instance FreeT_Functor {f m} : Functor (FreeT f m) := { 87 | fmap := fun _ _ f k => fun _ a fr => k _ (a \o f) fr 88 | }. 89 | 90 | #[export] 91 | Program Instance FreeT_Applicative {f m} : Applicative (FreeT f m) := { 92 | pure := fun _ a => fun _ k _ => k a; 93 | ap := fun _ _ fk ak => fun _ b fr => 94 | fk _ (fun e => ak _ (fun d => b (e d)) fr) fr 95 | }. 96 | 97 | (* jww (2017-04-24): Universe inconsistency in Coq 8.6 *) 98 | (* 99 | #[export] 100 | Program Instance FreeT_Monad {f m} : Monad (FreeT f m) := { 101 | join := fun _ x => fun _ k h => x _ (fun y => y _ k h) h 102 | }. 103 | *) 104 | 105 | Module FreeTLaws. 106 | 107 | Include MonadLaws. 108 | 109 | (* It's not always this easy. *) 110 | #[export] 111 | Program Instance FreeT_FunctorLaws {f m} : FunctorLaws (FreeT f m). 112 | #[export] 113 | Program Instance FreeT_ApplicativeLaws {f m} : ApplicativeLaws (FreeT f m). 114 | (* #[export] *) 115 | (* Program Instance FreeT_MonadLaws : MonadLaws (FreeT f m). *) 116 | 117 | End FreeTLaws. 118 | 119 | Section FreeT. 120 | 121 | Context `{Functor f}. 122 | Context `{Monad m}. 123 | 124 | Axiom ft_ind : forall (a : Type) (P : FreeT f id a -> Prop), 125 | (forall (h : a), P (fun _ p _ => p h)) -> 126 | (forall x (h : forall r, x -> r) (b : f x) (t : FreeT f id a), 127 | P t -> P (fun s _ k => k x (h s) b)) -> 128 | forall t : FreeT f id a, P t. 129 | 130 | End FreeT. 131 | -------------------------------------------------------------------------------- /src/Data/Maybe.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Control.Monad. 2 | 3 | Generalizable All Variables. 4 | Set Primitive Projections. 5 | Set Universe Polymorphism. 6 | Unset Transparent Obligations. 7 | 8 | Notation Maybe := option. 9 | Notation Nothing := None. 10 | Notation Just := Some. 11 | 12 | Definition fromMaybe `(x : a) (my : Maybe a) : a := 13 | match my with 14 | | Just z => z 15 | | Nothing => x 16 | end. 17 | 18 | Definition maybe `(x : b) `(f : a -> b) (my : Maybe a) : b := 19 | match my with 20 | | Just z => f z 21 | | Nothing => x 22 | end. 23 | 24 | Definition Maybe_map `(f : X -> Y) (x : Maybe X) : Maybe Y := 25 | match x with 26 | | Nothing => Nothing 27 | | Just x' => Just (f x') 28 | end. 29 | 30 | #[export] 31 | Instance Maybe_Functor : Functor Maybe := { 32 | fmap := @Maybe_map 33 | }. 34 | 35 | Definition Maybe_apply {X Y} (f : Maybe (X -> Y)) (x : Maybe X) : Maybe Y := 36 | match f with 37 | | Nothing => Nothing 38 | | Just f' => match x with 39 | | Nothing => Nothing 40 | | Just x' => Just (f' x') 41 | end 42 | end. 43 | 44 | #[export] 45 | Instance Maybe_Applicative : Applicative Maybe := { 46 | is_functor := Maybe_Functor; 47 | 48 | pure := @Just; 49 | ap := @Maybe_apply 50 | }. 51 | 52 | Definition Maybe_join {X} (x : Maybe (Maybe X)) : Maybe X := 53 | match x with 54 | | Nothing => Nothing 55 | | Just Nothing => Nothing 56 | | Just (Just x') => Just x' 57 | end. 58 | 59 | #[export] 60 | Instance Maybe_Monad : Monad Maybe := { 61 | is_applicative := Maybe_Applicative; 62 | join := @Maybe_join 63 | }. 64 | 65 | Definition isJust {a} (x : Maybe a) := if x then true else false. 66 | 67 | Definition Maybe_choose {a} (x y : Maybe a) : Maybe a := 68 | match x with 69 | | Nothing => y 70 | | Just _ => x 71 | end. 72 | 73 | #[export] 74 | Instance Maybe_Alternative : Alternative Maybe := { 75 | empty := @Nothing; 76 | choose := @Maybe_choose 77 | }. 78 | 79 | Lemma Maybe_choose_spec : forall a (x y : Maybe a), 80 | isJust (x <|> y) = (isJust x || isJust y)%bool. 81 | Proof. 82 | intros a x y. 83 | destruct x; auto. 84 | Qed. 85 | 86 | Lemma fmap_endo_just {c} (f : c -> c) (m : Maybe c) (x : c) : 87 | f <$> m = Just x <-> exists y, x = f y /\ m = Just y. 88 | Proof. 89 | induction m; simpl; split; intros. 90 | - inversion_clear H. 91 | eexists; eauto. 92 | - destruct H, H; subst. 93 | now inversion_clear H0. 94 | - discriminate. 95 | - destruct H, H; discriminate. 96 | Qed. 97 | 98 | Lemma fmap_endo_nothing {c} (f : c -> c) (m : Maybe c) : 99 | f <$> m = Nothing <-> m = Nothing. 100 | Proof. induction m; simpl; intuition auto; discriminate. Qed. 101 | 102 | Lemma ap_endo_just {c} (f : c -> c -> c) (m n : Maybe c) (x : c) : 103 | f <$> m <*> n = Just x 104 | <-> exists y z, x = f y z /\ m = Just y /\ n = Just z. 105 | Proof. 106 | induction m, n; simpl; split; intros. 107 | - inversion_clear H. 108 | eexists; eauto. 109 | - destruct H, H, H, H0; subst. 110 | inversion_clear H0. 111 | now inversion_clear H1. 112 | - discriminate. 113 | - destruct H, H, H, H0; discriminate. 114 | - discriminate. 115 | - destruct H, H, H, H0; discriminate. 116 | - discriminate. 117 | - destruct H, H, H, H0; discriminate. 118 | Qed. 119 | 120 | Lemma ap_endo_nothing {c} (f : c -> c -> c) (m n : Maybe c) : 121 | f <$> m <*> n = Nothing <-> m = Nothing \/ n = Nothing. 122 | Proof. induction m, n; simpl; intuition auto; discriminate. Qed. 123 | 124 | Lemma bind_endo_just {c} (f : c -> Maybe c) (m : Maybe c) (x : c) : 125 | m >>= f = Just x <-> exists y, f y = Just x /\ m = Just y. 126 | Proof. 127 | induction m; simpl; split; intros. 128 | - destruct (f a) eqn:?. 129 | inversion H; subst. 130 | now eexists; eauto. 131 | discriminate. 132 | - destruct H, H. 133 | inversion H0; subst. 134 | now rewrite H. 135 | - discriminate. 136 | - destruct H, H. 137 | discriminate. 138 | Qed. 139 | 140 | Lemma bind_endo_nothing {c} (f : c -> Maybe c) (m : Maybe c) : 141 | m >>= f = Nothing <-> m = Nothing \/ exists y, f y = Nothing /\ m = Just y. 142 | Proof. 143 | induction m; simpl; split; intros. 144 | - destruct (f a) eqn:?. 145 | now inversion H; subst. 146 | right. 147 | now eexists; eauto. 148 | - destruct H. 149 | discriminate. 150 | firstorder eauto. 151 | inversion_clear H0. 152 | now rewrite H. 153 | - now left. 154 | - reflexivity. 155 | Qed. 156 | 157 | Lemma alt_endo_just {c} (m n : Maybe c) (x : c) : 158 | m <|> n = Just x <-> m = Just x \/ (m = Nothing /\ n = Just x). 159 | Proof. induction m; simpl; intuition auto; discriminate. Qed. 160 | 161 | Lemma alt_endo_nothing {c} (m n : Maybe c) : 162 | m <|> n = Nothing <-> m = Nothing /\ n = Nothing. 163 | Proof. induction m, n; simpl; intuition auto; discriminate. Qed. 164 | -------------------------------------------------------------------------------- /research/Monad.v: -------------------------------------------------------------------------------- 1 | Require Export Applicative. 2 | Require Import Coq.Lists.List. 3 | 4 | Class Monad (M : Type -> Type) := 5 | { is_applicative :> Applicative M 6 | 7 | ; join : forall {X}, M (M X) -> M X 8 | 9 | ; monad_law_1 : forall {X}, join ∘ fmap join = (@join X) ∘ join 10 | ; monad_law_2 : forall {X}, join ∘ fmap (@pure M is_applicative X) = id 11 | ; monad_law_3 : forall {X}, (@join X) ∘ pure = id 12 | ; monad_law_4 : forall {X Y} (f : X -> Y), join ∘ fmap (fmap f) = fmap f ∘ join 13 | }. 14 | 15 | Declare Scope Monad_scope. 16 | 17 | Notation "join/ M" := (@join M _ _) (at level 28). 18 | Notation "join/ M N" := (@join (fun X => M (N X)) _ _) (at level 26). 19 | 20 | Definition bind {M} `{Monad M} {X Y} 21 | (f : (X -> M Y)) (x : M X) : M Y := join (fmap f x). 22 | 23 | Notation "m >>= f" := (bind f m) (at level 25, left associativity). 24 | 25 | (* Notation "x <- c1 ;; c2" := (@bind _ _ _ _ _ c1 (fun x => c2)) *) 26 | (* (at level 100, c1 at next level, right associativity). *) 27 | 28 | Notation "X <- A ; B" := (A >>= (fun X => B)) 29 | (right associativity, at level 84). 30 | 31 | (* Notation "x : a <== c1 ;; c2" := (@bind _ _ _ _ _ c1 (fun x : a => c2)) *) 32 | (* (at level 100, c1 at next level, right associativity). *) 33 | 34 | Notation "A ;; B" := (_ <- A ; B) 35 | (right associativity, at level 84). 36 | 37 | Theorem monad_law_1_x 38 | : forall (M : Type -> Type) (m_dict : Monad M) A (x : M (M (M A))), 39 | join (fmap join x) = (@join M m_dict A) (join x). 40 | Proof. 41 | intros. 42 | assert (join (fmap join x) = (join ∘ fmap join) x). 43 | unfold compose. reflexivity. 44 | assert (join (join x) = (join ∘ join) x). 45 | unfold compose. reflexivity. 46 | rewrite H. rewrite H0. 47 | rewrite monad_law_1. 48 | reflexivity. 49 | Qed. 50 | 51 | Theorem monad_law_2_x 52 | : forall (M : Type -> Type) (m_dict : Monad M) A (x : M A), 53 | join (fmap (@pure M _ A) x) = x. 54 | Proof. 55 | intros. 56 | assert (join (fmap pure x) = (join ∘ fmap pure) x). 57 | unfold compose. reflexivity. 58 | rewrite H. 59 | rewrite monad_law_2. 60 | reflexivity. 61 | Qed. 62 | 63 | Theorem monad_law_3_x 64 | : forall (M : Type -> Type) (m_dict : Monad M) A (x : M A), 65 | (@join M m_dict A) (pure x) = x. 66 | Proof. 67 | intros. 68 | assert (join (pure x) = (join ∘ pure) x). 69 | unfold compose. reflexivity. 70 | rewrite H. 71 | rewrite monad_law_3. 72 | reflexivity. 73 | Qed. 74 | 75 | Theorem monad_law_4_x 76 | : forall (M : Type -> Type) (m_dict : Monad M) 77 | A B (f : A -> B) (x : M (M A)), 78 | join (fmap (fmap f) x) = fmap f (join x). 79 | Proof. 80 | intros. 81 | assert (join (fmap (fmap f) x) = (join ∘ fmap (fmap f)) x). 82 | unfold compose. reflexivity. 83 | assert (fmap f (join x) = (fmap f ∘ join) x). 84 | unfold compose. reflexivity. 85 | rewrite H. rewrite H0. 86 | rewrite monad_law_4. 87 | reflexivity. 88 | Qed. 89 | 90 | Theorem monad_assoc : forall `{M : Type -> Type} `{Monad M} 91 | {A B C} (m : M A) (f : A -> M B) (g : B -> M C), 92 | m >>= f >>= g = m >>= (fun x => f x >>= g). 93 | Proof. 94 | intros. 95 | unfold bind. 96 | rewrite <- monad_law_4_x. 97 | rewrite fun_composition_x. 98 | rewrite <- monad_law_1_x. 99 | rewrite fun_composition_x. 100 | f_equal. 101 | Qed. 102 | 103 | #[export] 104 | Program Instance option_Monad : Monad option := { 105 | join := fun _ x => match x with 106 | | None => None 107 | | Some None => None 108 | | Some (Some x) => Some x 109 | end 110 | }. 111 | Obligation 1. 112 | extensionality x. 113 | destruct x; auto; 114 | destruct o; auto; 115 | destruct o; auto. 116 | Qed. 117 | Obligation 2. 118 | extensionality x. 119 | destruct x; auto; 120 | destruct o; auto; 121 | destruct o; auto. 122 | Qed. 123 | Obligation 3. 124 | extensionality x. 125 | destruct x; auto; 126 | destruct o; auto; 127 | destruct o; auto. 128 | Qed. 129 | Obligation 4. 130 | extensionality x. 131 | destruct x; auto; 132 | destruct o; auto; 133 | destruct o; auto. 134 | Qed. 135 | 136 | Module Import LN := ListNotations. 137 | 138 | #[export] 139 | Program Instance list_Monad : Monad list := { 140 | join := @concat 141 | }. 142 | Obligation 1. 143 | extensionality l. 144 | induction l. crush. 145 | unfold compose in *. simpl. 146 | rewrite IHl. 147 | Admitted. 148 | Obligation 2. 149 | extensionality l. 150 | induction l. crush. 151 | unfold compose in *. simpl. 152 | rewrite IHl. 153 | unfold id. reflexivity. 154 | Qed. 155 | Obligation 3. 156 | extensionality l. 157 | induction l. crush. 158 | unfold compose, id in *. 159 | simpl. rewrite app_nil_r. 160 | reflexivity. 161 | Qed. 162 | Obligation 4. 163 | extensionality l. 164 | induction l. crush. 165 | unfold compose, id in *. 166 | simpl. rewrite IHl. 167 | Admitted. 168 | -------------------------------------------------------------------------------- /src/Control/Monad/EffPlain.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Hask.Control.Monad 3 | Hask.Data.Maybe 4 | Coq.Lists.List. 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | 11 | Import ListNotations. 12 | 13 | Definition Effect := (Type -> Type) -> Type. 14 | 15 | Inductive Effects (m : Type -> Type) : list Effect -> Type := 16 | | NilE : Effects m [] 17 | | ConsE effects : forall effect : Effect, 18 | effect m -> Effects m effects -> Effects m (effect :: effects). 19 | 20 | Arguments ConsE : default implicits. 21 | 22 | Definition combine `(e : effect m) `(xs : Effects m effects) : 23 | Effects m (effect :: effects) := ConsE _ e xs. 24 | 25 | Infix ".:" := combine (at level 48, right associativity). 26 | 27 | Class Handles (fs : list Effect) (effect : Effect) := { 28 | getEffect : forall m, Effects m fs -> effect m 29 | }. 30 | 31 | #[export] 32 | Instance Handles_hd {fs : list Effect} {f : Effect} : 33 | Handles (f :: fs) f. 34 | Proof. 35 | constructor; intros. 36 | inversion X. 37 | exact X0. 38 | Defined. 39 | 40 | #[export] 41 | Instance Handles_tl `{_ : Handles fs f} : Handles (x :: fs) f. 42 | Proof. 43 | constructor; intros. 44 | inversion H. 45 | apply getEffect0. 46 | inversion X. 47 | exact X1. 48 | Defined. 49 | 50 | Axiom IO : Type -> Type. 51 | Axiom IO_Functor : Functor IO. 52 | Axiom IO_Applicative : Applicative IO. 53 | Axiom IO_Monad : Monad IO. 54 | 55 | Definition Kleisli m (A B : Type) := A -> m B. 56 | 57 | Arguments Kleisli m A B. 58 | 59 | Definition TFree `(xs : list Effect) a := 60 | Kleisli IO (Effects IO xs) a. 61 | 62 | Definition Eff := TFree. 63 | 64 | Arguments Eff xs a. 65 | 66 | Definition liftF `{Handles effects effect} 67 | `(getOp : effect IO -> IO a) : Eff effects a := 68 | fun effects => getOp (getEffect IO effects). 69 | 70 | Definition interpret `(interpreter : Effects IO effects) 71 | `(program : Eff effects a) : IO a := program interpreter. 72 | 73 | #[export] 74 | Instance Impl_Functor {A} : Functor (fun B => A -> B) := { 75 | fmap := fun A B f run => fun xs => f (run xs) 76 | }. 77 | 78 | #[export] 79 | Instance Impl_Applicative {A} : Applicative (fun B => A -> B) := { 80 | pure := fun _ x => fun xs => x; 81 | ap := fun A B runf runx => fun xs => runf xs (runx xs) 82 | }. 83 | 84 | #[export] 85 | Instance Impl_Monad {A} : Monad (fun B => A -> B) := { 86 | join := fun A run => fun xs => run xs xs 87 | }. 88 | 89 | #[export] 90 | Instance Kleisli_Functor `{Monad m} {A} : Functor (Kleisli m A) := 91 | Compose_Functor. 92 | 93 | #[export] 94 | Instance Kleisli_Applicative `{Applicative m} : Applicative (Kleisli m A) := 95 | fun _ => @Compose_Applicative _ _ Impl_Applicative _. 96 | 97 | #[export] 98 | Program Instance Kleisli_Monad_Distributes `{Monad m} {A} : 99 | @Monad_Distributes _ (@Impl_Monad A) m _ := { 100 | prod := _ 101 | }. 102 | Obligation 1. 103 | exact (join (fmap (fun k => k X0) X)). 104 | Defined. 105 | 106 | (* Instance Kleisli_Monad `{Monad m} {A} : Monad (Kleisli m A) := Compose_Monad. *) 107 | 108 | #[export] 109 | Instance TFree_Functor `(xs : list Effect) : Functor (TFree xs) := { 110 | fmap := fun A B f run => fun xs => fmap f (run xs) 111 | }. 112 | 113 | #[export] 114 | Instance TFree_Applicative `(xs : list Effect) : Applicative (TFree xs) := { 115 | pure := fun _ x => fun xs => pure x; 116 | ap := fun A B runf runx => fun xs => runf xs <*> runx xs 117 | }. 118 | 119 | #[export] 120 | Instance TFree_Monad `(xs : list Effect) : Monad (TFree xs) := { 121 | join := fun A run => fun xs => run xs >>= fun f => f xs 122 | }. 123 | 124 | Record Abortive (m : Type -> Type) := { 125 | abortE : m unit 126 | }. 127 | 128 | Definition abort `{Handles r Abortive} : Eff r unit := 129 | liftF abortE. 130 | 131 | Record Reader (e : Type) (m : Type -> Type) := { 132 | askE : m e 133 | }. 134 | 135 | Definition ask `{Handles r (Reader e)} : Eff r e := 136 | liftF (askE e). 137 | 138 | Require Import Arith. 139 | 140 | Set Printing Universes. 141 | 142 | Definition example1 `{Handles r (Reader nat)} `{Handles r Abortive} : 143 | Eff r nat := 144 | (fun x y => y + 15) <$> abort <*> ask. 145 | 146 | Definition maybeInterpreter : Effects Maybe [Reader nat; Abortive] := 147 | combine {| askE := Just 10 |} (combine {| abortE := Nothing |} (NilE _)). 148 | 149 | Definition run {a} : Eff [Reader nat; Abortive] a -> Maybe a := 150 | interpret maybeInterpreter. 151 | 152 | Example run_example1 : run example1 = Nothing. 153 | Proof. reflexivity. Qed. 154 | 155 | Definition example2 `{Handles r (Reader nat)} : Eff r nat := 156 | fmap (plus 15) ask. 157 | 158 | Example run_example2 : run example2 = Just 25. 159 | Proof. reflexivity. Qed. 160 | 161 | (* 162 | Definition example3 `{Handles r (Reader nat)} `{Handles r Abortive} : 163 | Eff r nat := 164 | v <- ask; 165 | if leb v 15 166 | then abort ;; pure 0 167 | else pure (v+1). 168 | 169 | Example run_example3 : run example3 = None. 170 | Proof. reflexivity. Qed. 171 | *) 172 | -------------------------------------------------------------------------------- /src/Control/Applicative.v: -------------------------------------------------------------------------------- 1 | Require Export Hask.Ltac. 2 | Require Export Hask.Data.Functor. 3 | Require Export Hask.Data.Functor.Const. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | Reserved Notation "f <*> g" (at level 28, left associativity). 11 | 12 | Class Applicative (f : Type -> Type) := { 13 | is_functor :> Functor f; 14 | 15 | pure : forall a : Type, a -> f a; 16 | ap : forall a b : Type, f (a -> b) -> f a -> f b 17 | where "f <*> g" := (ap f g) 18 | }. 19 | 20 | Arguments pure {f _ _} _. 21 | Arguments ap {f _ _ _} _ x. 22 | 23 | Notation "pure[ M ]" := (@pure M _ _) (at level 19, M at next level). 24 | Notation "pure[ M N ]" := (@pure (fun X => M (N X)) _ _) (at level 9). 25 | 26 | Notation "ap[ M ]" := (@ap M _ _ _) (at level 9). 27 | Notation "ap[ M N ]" := (@ap (fun X => M (N X)) _ _ _) (at level 9). 28 | Notation "ap[ M N O ]" := (@ap (fun X => M (N (O X))) _ _ _) (at level 9). 29 | 30 | Infix "<*>" := ap (at level 28, left associativity). 31 | Notation "x <**> f" := (ap f x) (at level 28, left associativity). 32 | Notation "x <**[ M ]> f" := (@ap M _ _ _ f x) (at level 28, left associativity). 33 | Infix "<*[ M ]>" := 34 | (@ap M _ _ _) (at level 28, left associativity, only parsing). 35 | 36 | (* Notation "[| f x y .. z |]" := (.. (f <$> x <*> y) .. <*> z) *) 37 | (* (at level 9, left associativity, f at level 9, *) 38 | (* x at level 9, y at level 9, z at level 9). *) 39 | 40 | Definition liftA2 `{Applicative m} {A B C : Type} 41 | (f : A -> B -> C) (x : m A) (y : m B) : m C := ap (fmap f x) y. 42 | 43 | Infix "*>" := (liftA2 (const id)) (at level 28, left associativity). 44 | Infix "<*" := (liftA2 const) (at level 28, left associativity). 45 | 46 | Require Import FunctionalExtensionality. 47 | 48 | Module ApplicativeLaws. 49 | 50 | Include FunctorLaws. 51 | 52 | Class ApplicativeLaws (f : Type -> Type) `{Applicative f} := { 53 | has_functor_laws :> FunctorLaws f; 54 | 55 | ap_id : forall a : Type, ap (pure (@id a)) = id; 56 | ap_comp : forall (a b c : Type) (v : f (a -> b)) (u : f (b -> c)) (w : f a), 57 | pure (fun f g x => f (g x)) <*> u <*> v <*> w = u <*> (v <*> w); 58 | ap_homo : forall (a b : Type) (x : a) (f : a -> b), 59 | pure f <*> pure x = pure (f x); 60 | ap_interchange : forall (a b : Type) (y : a) (u : f (a -> b)), 61 | u <*> pure y = pure (fun f => f y) <*> u; 62 | 63 | ap_fmap : forall (a b : Type) (f : a -> b), 64 | ap (pure f) = @fmap _ is_functor _ _ f 65 | }. 66 | 67 | Corollary fmap_pure `{ApplicativeLaws m} : forall (a b : Type) (f : a -> b), 68 | fmap[m] f \o pure = pure \o f. 69 | Proof. 70 | intros a b f. 71 | extensionality x. 72 | unfold Basics.compose. 73 | rewrite <- ap_fmap. 74 | apply ap_homo. 75 | Qed. 76 | 77 | Corollary fmap_pure_x `{ApplicativeLaws m} : forall (a b : Type) (f : a -> b) x, 78 | fmap[m] f (pure x) = pure (f x). 79 | Proof. 80 | intros. 81 | replace (pure[m] (f x)) with ((pure[m] \o f) x). 82 | rewrite <- fmap_pure. 83 | reflexivity. 84 | reflexivity. 85 | Qed. 86 | 87 | Ltac apply_applicative_laws := 88 | repeat 89 | match goal with 90 | | [ |- context[fmap[?F] id] ] => 91 | rewrite fmap_id 92 | | [ |- context[fmap[?F] _ (fmap[?F] _ _)] ] => 93 | rewrite fmap_comp_x 94 | 95 | | [ |- context[fmap[?F] _ (pure[?F] _)] ] => 96 | rewrite fmap_pure_x 97 | | [ |- context[ap[?F] (pure[?F] id) _] ] => 98 | rewrite ap_id 99 | | [ |- context[ap[?F] (pure[?F] _) _] ] => 100 | rewrite ap_fmap 101 | | [ |- context[ap[?F] (pure[?F] _)] ] => 102 | rewrite ap_fmap 103 | | [ |- context[ap[?F] (pure[?F] _) (pure[?F] _)] ] => 104 | rewrite ap_homo 105 | | [ |- context[_ <*> pure[?F] _] ] => 106 | rewrite ap_interchange 107 | 108 | | [ |- context[fmap[?F] id] ] => 109 | setoid_rewrite fmap_id 110 | | [ |- context[fmap[?F] _ (fmap[?F] _ _)] ] => 111 | setoid_rewrite fmap_comp_x 112 | 113 | | [ |- context[fmap[?F] _ (pure[?F] _)] ] => 114 | setoid_rewrite fmap_pure_x 115 | | [ |- context[ap[?F] (pure[?F] id) _] ] => 116 | setoid_rewrite ap_id 117 | | [ |- context[ap[?F] (pure[?F] _) _] ] => 118 | setoid_rewrite ap_fmap 119 | | [ |- context[ap[?F] (pure[?F] _)] ] => 120 | setoid_rewrite ap_fmap 121 | | [ |- context[ap[?F] (pure[?F] _) (pure[?F] _)] ] => 122 | setoid_rewrite ap_homo 123 | | [ |- context[_ <*> pure[?F] _] ] => 124 | setoid_rewrite ap_interchange 125 | end; auto. 126 | 127 | End ApplicativeLaws. 128 | 129 | Reserved Notation "f <|> g" (at level 29, left associativity). 130 | 131 | Class Alternative (F : Type -> Type) := 132 | { alt_is_applicative :> Applicative F 133 | 134 | ; empty : forall {X}, F X 135 | ; choose : forall {X}, F X -> F X -> F X 136 | where "f <|> g" := (choose f g) 137 | (* ; some : forall {X}, F X -> list (F X) *) 138 | (* ; many : forall {X}, F X -> list (F X) *) 139 | }. 140 | 141 | Notation "f <|> g" := (choose f g) (at level 29, left associativity). 142 | 143 | (* Module Import LN := ListNotations. *) 144 | 145 | (* #[export] *) 146 | (* Program Instance list_Alternative : Alternative list := { *) 147 | (* empty := fun _ => []; *) 148 | (* choose := app *) 149 | (* }. *) 150 | -------------------------------------------------------------------------------- /research/Endo.v: -------------------------------------------------------------------------------- 1 | Require Export Basics. 2 | 3 | Generalizable All Variables. 4 | 5 | (* Even though we have the Category class in Category.v, the Functors 6 | and Monads I'm interested in reasoning about are all endofunctors on 7 | Coq, so there is no reason to carry around that extra machinery. *) 8 | 9 | Class Functor (F : Type -> Type) := 10 | { fobj := F 11 | ; fmap : forall {X Y}, (X -> Y) -> F X -> F Y 12 | 13 | ; fun_identity : forall {X}, fmap (@id X) = id 14 | ; fun_composition : forall {X Y Z} (f : Y -> Z) (g : X -> Y), 15 | fmap f ∘ fmap g = fmap (f ∘ g) 16 | }. 17 | 18 | Arguments fmap [F] [Functor] [X] [Y] f g. 19 | Arguments fun_identity [F] [Functor] [X]. 20 | Arguments fun_composition [F] [Functor] [X] [Y] [Z] f g. 21 | 22 | Notation "f <$> g" := (fmap f g) (at level 28, left associativity). 23 | 24 | Notation "fmap[ M ] f" := (@fmap M _ _ _ f) (at level 28). 25 | Notation "fmap[ M N ] f" := (@fmap (fun X => M (N X)) _ _ _ f) (at level 26). 26 | Notation "fmap[ M N O ] f" := (@fmap (fun X => M (N (O X))) _ _ _ f) (at level 24). 27 | 28 | Coercion fobj : Functor >-> Funclass. 29 | 30 | Lemma fun_irrelevance `(F : Functor) 31 | : ∀ (f g : ∀ {X Y}, (X -> Y) → (F X -> F Y)) 32 | i i' c c', 33 | @f = @g → 34 | {| fmap := @f 35 | ; fun_identity := i 36 | ; fun_composition := c |} = 37 | {| fmap := @g 38 | ; fun_identity := i' 39 | ; fun_composition := c' |}. 40 | Proof. 41 | intros. subst. f_equal. 42 | apply proof_irrelevance. 43 | apply proof_irrelevance. 44 | Qed. 45 | 46 | Section Functors. 47 | 48 | Variable F : Type -> Type. 49 | Context `{Functor F}. 50 | 51 | Theorem fun_identity_x : forall {X} (x : F X), fmap id x = id x. 52 | Proof. 53 | intros. 54 | rewrite fun_identity. 55 | reflexivity. 56 | Qed. 57 | 58 | Theorem fun_composition_x 59 | : forall {X Y Z} (f : Y -> Z) (g : X -> Y) (x : F X), 60 | f <$> (g <$> x) = (f ∘ g) <$> x. 61 | Proof. 62 | intros. 63 | rewrite <- fun_composition. 64 | reflexivity. 65 | Qed. 66 | 67 | End Functors. 68 | 69 | (* Functions are trivial functors. *) 70 | 71 | (* 72 | #[export] 73 | Program Instance Hom_Functor {A} : Functor (fun X => A -> X) := 74 | { fmap := fun X Y f g => f ∘ g 75 | }. 76 | *) 77 | 78 | Class Natural `(Functor F) `(Functor G) := { 79 | transport : ∀ {X}, F X -> G X; 80 | naturality : ∀ {X Y} (f : X -> Y), 81 | fmap f ∘ transport = transport ∘ fmap f 82 | }. 83 | 84 | Notation "transport/ N" := (@transport _ _ _ _ N _) (at level 24). 85 | Notation "F ⟾ G" := (Natural F G) (at level 90, right associativity). 86 | 87 | Lemma nat_irrelevance `(F : Functor) `(G : Functor) 88 | : ∀ (f g : ∀ {X}, F X -> G X) n n', 89 | @f = @g -> 90 | {| transport := @f; naturality := n |} = 91 | {| transport := @g; naturality := n' |}. 92 | Proof. 93 | intros. subst. f_equal. 94 | apply proof_irrelevance. 95 | Qed. 96 | 97 | Class Full `(F : Functor) := { 98 | full_prop : ∀ {X Y} (g : F X -> F Y) (f : X -> Y), g = fmap f 99 | }. 100 | 101 | Class Faithful `(F : Functor) := { 102 | faithful_prop : ∀ {X Y} (f1 f2 : X -> Y), fmap f1 = fmap f2 -> f1 = f2 103 | }. 104 | 105 | Class FullyFaithful `(F : Functor) := { 106 | is_full :> Full F; 107 | is_faithful :> Faithful F; 108 | 109 | unfmap : ∀ {X Y}, (F X -> F Y) -> (X -> Y) 110 | }. 111 | 112 | #[export] 113 | Program Instance Hom (A : Type) : Functor (fun X => A -> X) := { 114 | fmap := @compose _ 115 | }. 116 | 117 | Definition hom_irrelevance : forall {A X}, (A -> X) -> Hom A X. 118 | Proof. auto. Defined. 119 | 120 | Definition hom_irrelevance_r : forall {A} X, Hom A X -> (A -> X). 121 | Proof. auto. Defined. 122 | 123 | (* Open Scope nat_scope. *) 124 | 125 | (* Theorem distributive : forall n m o : nat, *) 126 | (* (n + m) * (n + o) = n * n + m * n + m * o + n * o. *) 127 | (* Proof. *) 128 | (* intros. induction n; simpl. *) 129 | (* omega. *) 130 | (* rewrite Mult.mult_succ_r. *) 131 | (* rewrite IHn. *) 132 | (* repeat rewrite <- Plus.plus_assoc. *) 133 | (* rewrite (Plus.plus_comm o). *) 134 | (* rewrite (Plus.plus_comm o). *) 135 | (* rewrite Mult.mult_succ_r. *) 136 | (* rewrite Mult.mult_succ_r. *) 137 | (* omega. *) 138 | (* Qed. *) 139 | 140 | #[export] 141 | Program Instance Hom_Full (A : Type) : Full (Hom A). 142 | Obligation 1. 143 | Admitted. 144 | 145 | #[export] 146 | Program Instance Hom_Faithful (A : Type) : Faithful (Hom A). 147 | Obligation 1. 148 | Admitted. 149 | 150 | #[export] 151 | Program Instance Hom_FullyFaithful (A : Type) : FullyFaithful (Hom A). 152 | Obligation 1. 153 | pose (@full_prop _ (Hom A) _ X Y X0). 154 | pose (@faithful_prop _ (Hom A) _ X Y). 155 | apply (X0 (const X1)). 156 | Admitted. 157 | 158 | #[export] 159 | Program Instance option_Functor : Functor option := { 160 | fmap := fun _ _ f x => match x with 161 | | None => None 162 | | Some x => Some (f x) 163 | end 164 | }. 165 | Obligation 1. extensionality x. destruct x; auto. Qed. 166 | Obligation 2. extensionality x. destruct x; auto. Qed. 167 | 168 | #[export] 169 | Program Instance list_Functor : Functor list := { 170 | fmap := List.map 171 | }. 172 | Obligation 1. 173 | extensionality l. 174 | induction l; auto. 175 | simpl. rewrite IHl. 176 | reflexivity. 177 | Qed. 178 | Obligation 2. 179 | extensionality l. 180 | induction l; auto. 181 | simpl. rewrite <- IHl. 182 | reflexivity. 183 | Qed. 184 | -------------------------------------------------------------------------------- /src/Data/Functor/Container.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Control.Monad. 3 | Require Import Control.Comonad. 4 | 5 | Generalizable All Variables. 6 | Set Primitive Projections. 7 | Set Universe Polymorphism. 8 | Unset Transparent Obligations. 9 | 10 | (* A container takes a set of shapes {S] and a family of types {P] indexed by 11 | {S]. Using these two, we may construct a box for one such shape {x : S] 12 | along with a function (unnamed, but let's call it {f]) that, given some 13 | "index" {i : P x], yields the contained element corresponding to {i], of 14 | type {a]. 15 | 16 | For example, the shape of a list of type {list a] may be described by its 17 | length {n : nat], along with an accessor of type {Fin n -> a]. Thus: 18 | 19 | S = nat 20 | P = forall n : S, Fin n 21 | x : S 22 | f : P x -> a := fun (i : P x) => nth i 23 | 24 | The accessor in this case need not be a closure over {Vector x a], but is 25 | always isomorphic to it. 26 | 27 | The benefit of this abstraction is that any type representable as a 28 | container must be strictly positive, since its elements are demonstrably 29 | finite (its use is contingent on the inhabitants of {S] and {P x]). *) 30 | 31 | Record Container `(Position : Shape -> Type) (a : Type) := { 32 | shape : Shape; 33 | getter : Position shape -> a 34 | }. 35 | 36 | Arguments shape {Shape Position a} _. 37 | Arguments getter {Shape Position a} _ _. 38 | 39 | #[export] 40 | Program Instance Container_Functor {S : Type} (P : S -> Type) : 41 | Functor (Container P) := { 42 | fmap := fun X Y f x => 43 | {| shape := shape x 44 | ; getter := fun i => f (getter x i) 45 | |} 46 | }. 47 | 48 | (* Record FocusedContainer `(Position : Shape -> Type) (a : Type) := { *) 49 | (* is_container :> Container Position a; *) 50 | 51 | (* refocus : Position (shape is_container) -> FocusedContainer Shape Position a; *) 52 | (* focus : Position (shape is_container) *) 53 | (* }. *) 54 | 55 | (* Arguments focus {Shape Position a} _. *) 56 | 57 | (* #[export] *) 58 | (* Program Instance Container_Comonad {S : Type} (P : S -> Type) : *) 59 | (* Comonad (FocusedContainer P) := { *) 60 | (* extract := fun _ x => getter x (focus x); *) 61 | (* duplicate := fun _ x => *) 62 | (* {| is_container := *) 63 | (* {| shape := shape x *) 64 | (* ; getter := *) 65 | (* ; positions := *) 66 | (* ; focus := *) 67 | (* |} *) 68 | (* }. *) 69 | 70 | Definition IdentityContainer `(x : a) : Container (const unit) a := 71 | {| shape := tt 72 | ; getter := const x 73 | |}. 74 | 75 | #[export] 76 | Program Instance IdentityContainer_Applicative : 77 | Applicative (Container (const unit)) := { 78 | pure := fun _ => IdentityContainer; 79 | ap := fun _ _ f x => IdentityContainer (getter f tt (getter x tt)) 80 | }. 81 | 82 | #[export] 83 | Program Instance IdentityContainer_Monad : 84 | Monad (Container (const unit)) := { 85 | join := fun _ x => getter x tt 86 | }. 87 | 88 | Inductive CFree {S : Type} (P : S -> Type) (a : Type) : Type := 89 | | CPure : a -> CFree P a 90 | | CJoin : forall s : S, (P s -> CFree P a) -> CFree P a. 91 | 92 | Arguments CPure {S P a} _. 93 | Arguments CJoin {S P a} _ _. 94 | 95 | Definition CFree_bind {S : Type} {P : S -> Type} `(k : a -> CFree P b) : 96 | CFree P a -> CFree P b := 97 | fun x0 => let fix go x := match x with 98 | | CPure a => k a 99 | | CJoin s g => CJoin s (go \o g) 100 | end in 101 | go x0. 102 | 103 | #[export] 104 | Program Instance CFree_Functor {S : Type} (P : S -> Type) : 105 | Functor (CFree P) := { 106 | fmap := fun _ _ k => CFree_bind (CPure \o k) 107 | }. 108 | 109 | #[export] 110 | Program Instance CFree_Applicative {S : Type} (P : S -> Type) : 111 | Applicative (CFree P) := { 112 | pure := fun _ => CPure; 113 | ap := fun _ _ mf mx => CFree_bind (flip fmap mx) mf 114 | }. 115 | 116 | #[export] 117 | Program Instance CFree_Monad {S : Type} (P : S -> Type) : Monad (CFree P) := { 118 | join := fun _ => CFree_bind id 119 | }. 120 | 121 | Fixpoint fold `(r : x -> y) {S : Type} `(c : forall s : S, (P s -> y) -> y) 122 | (fr : CFree P x) : y := 123 | match fr with 124 | | CPure x => r x 125 | | CJoin s k => c s $ fun t => fold r c (k t) 126 | end. 127 | 128 | Fixpoint retract {S : Type} `(fr : CFree P a) : 129 | (forall s : S, (P s -> a) -> a) -> a := 130 | fun c => match fr with 131 | | CPure x => x 132 | | CJoin s k => c s $ fun t => retract (k t) c 133 | end. 134 | 135 | Require Import FunctionalExtensionality. 136 | 137 | Module ContainerLaws. 138 | 139 | Include MonadLaws. 140 | 141 | Section ContainerLaws. 142 | 143 | Variable S : Type. 144 | Variable P : S -> Type. 145 | 146 | #[export] 147 | Program Instance Container_FunctorLaws : FunctorLaws (Container P). 148 | 149 | (* 150 | Ltac reduce_cfree H := 151 | try elim=> //= [? ? H]; 152 | congr (CJoin _ _); 153 | extensionality YY; 154 | exact: H. 155 | 156 | #[export] 157 | Program Instance CFree_FunctorLaws : FunctorLaws (CFree P). 158 | Obligation 1. by reduce_cfree IHx. Qed. 159 | Obligation 2. by reduce_cfree IHx. Qed. 160 | 161 | #[export] 162 | Program Instance CFree_ApplicativeLaws : ApplicativeLaws (CFree P). 163 | Obligation 1. by reduce_cfree IHx. Qed. 164 | Obligation 2. 165 | elim: u => /= [?|? ? IHu]. 166 | elim: v => /= [?|? ? IHv]. 167 | move: w. 168 | by reduce_cfree IHw. 169 | by reduce_cfree IHv. 170 | by reduce_cfree IHu. 171 | Qed. 172 | 173 | #[export] 174 | Program Instance CFree_MonadLaws : MonadLaws (CFree P). 175 | Obligation 1. by reduce_cfree IHx. Qed. 176 | Obligation 2. by reduce_cfree IHx. Qed. 177 | Obligation 4. by reduce_cfree IHx. Qed. 178 | *) 179 | 180 | End ContainerLaws. 181 | 182 | End ContainerLaws. 183 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Control.v: -------------------------------------------------------------------------------- 1 | (* Require Import Hask.Data.Functor.Identity. *) 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Control.Monad.Base. 4 | Require Import Hask.Control.Monad.Trans.State. 5 | (* Require Import Hask.Control.Monad.Trans.Free. *) 6 | 7 | Generalizable All Variables. 8 | Set Primitive Projections. 9 | Set Universe Polymorphism. 10 | Unset Transparent Obligations. 11 | 12 | Class StMC (m : Type -> Type) : Type := { 13 | StM : Type -> Type 14 | }. 15 | Arguments StM m {_} a. 16 | 17 | Definition RunInBase m `{StMC m} b := forall a, m a -> b (StM m a). 18 | 19 | Class MonadBaseControl b m `{MonadBase b m} `{StMC m} := { 20 | liftBaseWith : forall a, (RunInBase m b -> b a) -> m a; 21 | restoreM : forall a, StM m a -> m a 22 | }. 23 | Arguments liftBaseWith {b m _ _ _ _ _ _ a} _. 24 | Arguments restoreM {b m _ _ _ _ _ _ a} _. 25 | 26 | Class MonadBaseControlLaws b m `{MonadBaseControl b m} := { 27 | mbc_law_1 : forall a, liftBaseWith \o const \o pure[b] = @pure m _ a; 28 | mbc_law_2 : forall a (x : b a) r (f : a -> b r), 29 | liftBaseWith (const (x >>= f)) 30 | = liftBaseWith (const x) >>= (liftBaseWith \o const \o f); 31 | mbc_law_3 : forall a (x : m a), 32 | liftBaseWith (fun runInBase => runInBase _ x) >>= restoreM = x 33 | }. 34 | 35 | Corollary mbc_law_1_x : forall b m `{MonadBaseControlLaws b m} a x, 36 | liftBaseWith (const (pure[b] x)) = @pure m _ a x. 37 | Proof. 38 | intros. 39 | rewrite <- (@mbc_law_1 b m _ _ _ _ _ _ _). 40 | reflexivity. 41 | Qed. 42 | 43 | (* #[export] *) 44 | (* Instance StMC_Identity : StMC Identity := { *) 45 | (* StM := id *) 46 | (* }. *) 47 | 48 | (* #[export] *) 49 | (* Instance MonadBaseControl_Id_Id : *) 50 | (* MonadBaseControl Identity Identity := { *) 51 | (* liftBaseWith := fun _ runInBase => liftBase (runInBase (fun _ => pure)); *) 52 | (* restoreM := fun A => @id A *) 53 | (* }. *) 54 | 55 | (* #[export] *) 56 | (* Program Instance MonadBaseControlLaws_Id_Id : *) 57 | (* MonadBaseControlLaws Identity Identity. *) 58 | 59 | #[export] 60 | Instance StMC_StateT s m `{StMC m} : StMC (StateT s m) := { 61 | StM := fun A => StM m (A * s)%type 62 | }. 63 | 64 | #[export] 65 | Program Instance MonadBaseControl_StateT s `{MonadBaseControl b m} : 66 | MonadBaseControl b (StateT s m) := { 67 | liftBaseWith := fun _ f => fun st => 68 | res <- liftBaseWith (fun runInBase : RunInBase m b => 69 | f (fun A k => runInBase _ (k st))); 70 | pure (res, st); 71 | restoreM := fun _ => const \o restoreM 72 | }. 73 | 74 | (* 75 | #[export] 76 | Instance FreeT_m_b {f : Type -> Type} {m b : Type -> Type} 77 | `{FunDep (Type -> Type) m b} : 78 | FunDep (FreeT f m) b. 79 | 80 | #[export] 81 | Instance MonadBase_FreeT `{Functor f} {m b : Type -> Type} 82 | `{B : MonadBase b m} : MonadBase b (FreeT f m) := { 83 | liftBase := fun _ x => fun _ p _ => liftBase x >>= p 84 | }. 85 | 86 | #[export] 87 | Instance StMC_FreeT f m `{StMC m} : StMC (FreeT f m) := { 88 | StM := fun A => FreeF f A (FreeT f m (StM m A)) 89 | }. 90 | 91 | Definition embedF `{Monad m} `{Functor f} {t} 92 | (k : m (FreeF f t (FreeT f m t))) : FreeT f m t := 93 | fun r p j => 94 | res <- k; 95 | match res : FreeF f t (FreeT f m t) with 96 | | Pure x => p x 97 | | Free x => j (m r) id (fmap (fun k => k r p j) x) 98 | end. 99 | 100 | #[export] 101 | Program Instance MonadBaseControl_FreeT `{Functor f} `{MonadBaseControl b m} : 102 | MonadBaseControl b (FreeT f m) := { 103 | 104 | liftBaseWith := fun a g => 105 | fun r p j => 106 | liftBaseWith 107 | (fun runInBase : RunInBase m b => 108 | g (fun t k => 109 | runInBase _ (k _ (fun x : t => pure (Pure x)) 110 | (fun u h (x : f u) => 111 | pure (Free (fmap (embedF \o h) x)))))) 112 | >>= p; 113 | 114 | restoreM := fun a (x : StM (FreeT f m) a) => embedF (restoreM x) 115 | }. 116 | *) 117 | 118 | Require Import FunctionalExtensionality. 119 | 120 | Module MonadBaseControlLaws. 121 | 122 | Import MonadLaws. 123 | 124 | #[export] 125 | Program Instance MonadBaseControlLaws_StateT 126 | s `{MonadBaseControlLaws b m} `{@MonadLaws b H} `{@MonadLaws m H0} : 127 | MonadBaseControlLaws b (StateT s m). 128 | Obligation 1. 129 | extensionality x. 130 | extensionality st. 131 | pose proof (@mbc_law_1_x b m _ _ _ _ _ _ _ a) as H9. 132 | unfold bind, comp, const in *. 133 | rewrite H9, fmap_pure_x, join_pure_x. 134 | reflexivity. 135 | Qed. 136 | Obligation 2. 137 | extensionality st. 138 | pose proof (@mbc_law_2 b m _ _ _ _ _ _ _) as H10. 139 | unfold StateT_join, bind, comp, Tuple.curry, Tuple.first, 140 | Prelude.apply, const in *. 141 | rewrite !H10, !fmap_comp_x, <- !join_fmap_fmap_x, !fmap_comp_x, 142 | <- !join_fmap_join_x, !fmap_comp_x. 143 | f_equal; f_equal. 144 | extensionality y. 145 | rewrite fmap_pure_x, join_pure_x. 146 | reflexivity. 147 | Qed. 148 | Obligation 3. 149 | pose proof (@mbc_law_3 b m _ _ _ _ _ _ _) as H10. 150 | unfold StateT_join, bind, comp, Tuple.curry, Tuple.first, 151 | Prelude.apply, const in *. 152 | extensionality st. 153 | rewrite fmap_comp_x, <- join_fmap_fmap_x, <- join_fmap_join_x, !fmap_comp_x. 154 | setoid_rewrite fmap_pure_x. 155 | setoid_rewrite join_pure_x. 156 | rewrite H10. 157 | reflexivity. 158 | Qed. 159 | 160 | (* 161 | #[export] 162 | Program Instance MonadBaseControlLaws_FreeT 163 | `{Functor f} `{MonadBaseControlLaws b m} 164 | `{@MonadLaws b H0} `{@MonadLaws m H1} : 165 | MonadBaseControlLaws b (FreeT f m). 166 | Obligation 1. 167 | extensionality x. 168 | extensionality r. 169 | extensionality p. 170 | extensionality j. 171 | pose proof (@mbc_law_1_x b m _ _ _ _ _ _ _ a) as H9. 172 | unfold bind, comp, const in *. 173 | rewrite H9, fmap_pure_x, join_pure_x. 174 | reflexivity. 175 | Qed. 176 | Obligation 2. 177 | extensionality r'. 178 | extensionality p. 179 | extensionality j. 180 | pose proof (@mbc_law_2 b m _ _ _ _ _ _ _) as H10. 181 | unfold StateT_join, bind, comp, Tuple.curry, Tuple.first, 182 | Prelude.apply, const in *. 183 | rewrite H10, <- !join_fmap_fmap_x, !fmap_comp_x, 184 | <- !join_fmap_join_x, !fmap_comp_x. 185 | f_equal; f_equal. 186 | Qed. 187 | Obligation 3. 188 | pose proof (@mbc_law_3 b m _ _ _ _ _ _ _) as H10. 189 | unfold StateT_join, bind, comp, Tuple.curry, Tuple.first, 190 | Prelude.apply, const in *. 191 | extensionality r. 192 | extensionality p. 193 | extensionality j. 194 | rewrite <- join_fmap_fmap_x, <- join_fmap_join_x, !fmap_comp_x. 195 | setoid_rewrite fmap_pure_x. 196 | setoid_rewrite join_pure_x. 197 | rewrite H10. 198 | reflexivity. 199 | Qed. 200 | *) 201 | 202 | End MonadBaseControlLaws. 203 | -------------------------------------------------------------------------------- /src/Data/IntMap.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Ltac. 3 | Require Import Hask.Data.List. 4 | Require Import Hask.Data.NonEmpty. 5 | Require Import Hask.Data.Tuple. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | Generalizable All Variables. 11 | Set Primitive Projections. 12 | Set Universe Polymorphism. 13 | Unset Transparent Obligations. 14 | 15 | (* 16 | Inductive IntMap (a : Type) := getIntMap of seq (nat * a). 17 | 18 | Arguments getIntMap {a} _. 19 | 20 | Definition emptyIntMap {a} := @getIntMap a [::]. 21 | 22 | Definition IntMap_fromList {a} := @getIntMap a. 23 | 24 | Definition IntMap_size : forall a, IntMap a -> nat := 25 | fun _ m => let: getIntMap x := m in size x. 26 | 27 | (* We needn't bother defining these in Coq, since they only matter to the 28 | extracted Haskell code, and there we use the definitions from 29 | [Data.IntMap]. *) 30 | Definition IntMap_lookup : forall a, nat -> IntMap a -> option a := 31 | fun _ k m => let: getIntMap x := m in maybeLookup x k. 32 | 33 | Definition IntMap_member : forall a, nat -> IntMap a -> bool := 34 | fun _ k m => if IntMap_lookup k m is Some _ then true else false. 35 | 36 | Definition IntMap_alter : forall a, 37 | (option a -> option a) -> nat -> IntMap a -> IntMap a := 38 | fun _ f k m => 39 | let: getIntMap xs := m in @getIntMap _ $ 40 | if IntMap_lookup k m is Some x 41 | then 42 | foldr (fun z acc => 43 | let: (a, b) := z in 44 | if a == k 45 | then if f (Some x) is Some x' 46 | then rcons acc (k, x') 47 | else acc 48 | else z :: acc) 49 | [::] xs 50 | else if f None is Some x 51 | then rcons xs (k, x) 52 | else xs. 53 | 54 | Definition IntMap_insert : forall a, nat -> a -> IntMap a -> IntMap a := 55 | fun _ k x m => IntMap_alter (fun _ => Some x) k m. 56 | 57 | Definition IntMap_map {a b} (f : a -> b) (m : IntMap a) : IntMap b := 58 | let: getIntMap xs := m in 59 | getIntMap (map (fun x => (fst x, f (snd x))) xs). 60 | 61 | Lemma IntMap_map_id : forall a (m : IntMap a), IntMap_map id m = m. 62 | Proof. 63 | move=> a [m]. 64 | case: m => //= [m ?]. 65 | rewrite unsplit. 66 | by case: m. 67 | Qed. 68 | 69 | Lemma IntMap_map_comp : forall a b c (m : IntMap a) (f : b -> c) (g : a -> b), 70 | IntMap_map f \o IntMap_map g =1 IntMap_map (f \o g). 71 | Proof. 72 | move=> a b c [m] f g [xs] /=. 73 | elim: xs => //= [? ? IHxs]. 74 | rewrite -map_comp /funcomp in IHxs *. 75 | by congr (getIntMap _). 76 | Qed. 77 | 78 | Definition IntMap_mapWithKey {a b} (f : nat -> a -> b) (m : IntMap a) : 79 | IntMap b := 80 | let: getIntMap xs := m in 81 | let f z := let: (k, x) := z in (k, f k x) in 82 | getIntMap (map f xs). 83 | 84 | Lemma getIntMap_inj {a} : injective (@getIntMap a). 85 | Proof. by move=> ? ?; invert. Qed. 86 | 87 | Lemma IntMap_mapWithKey_id : forall a (m : IntMap a), 88 | IntMap_mapWithKey (const id) m = m. 89 | Proof. 90 | move=> a [m]. 91 | elim: m => //= [[x y] ? ?]. 92 | congr (getIntMap ((x, y) :: _)). 93 | exact: getIntMap_inj. 94 | Qed. 95 | 96 | Lemma IntMap_mapWithKey_comp : 97 | forall a b c (m : IntMap a) (f : b -> c) (g : a -> b), 98 | IntMap_mapWithKey (const f) \o IntMap_mapWithKey (const g) 99 | =1 IntMap_mapWithKey (const (f \o g)). 100 | Proof. 101 | move=> a b c [m] f g [xs] /=. 102 | elim: xs => //= [[x y] xs IHxs]. 103 | congr (getIntMap (_ :: _)). 104 | exact: getIntMap_inj. 105 | Qed. 106 | 107 | (* The implementation of this function is in LinearScan.Utils.hs *) 108 | Definition IntMap_mergeWithKey' {a b c} 109 | (combine : nat -> a -> b -> option c) 110 | (only1 : seq (nat * a) -> seq (nat * c)) 111 | (only2 : seq (nat * b) -> seq (nat * c)) 112 | (m1 : seq (nat * a)) (m2 : seq (nat * b)) : seq (nat * c) := [::]. 113 | 114 | Definition IntMap_mergeWithKey {a b c} (combine : nat -> a -> b -> option c) 115 | (only1 : IntMap a -> IntMap c) (only2 : IntMap b -> IntMap c) 116 | (m1 : IntMap a) (m2 : IntMap b) : IntMap c := 117 | let: getIntMap xs1 := m1 in 118 | let: getIntMap xs2 := m2 in 119 | let only1' xs := 120 | let: getIntMap xs' := only1 (getIntMap xs) in xs' in 121 | let only2' xs := 122 | let: getIntMap xs' := only2 (getIntMap xs) in xs' in 123 | getIntMap (IntMap_mergeWithKey' combine only1' only2' xs1 xs2). 124 | 125 | Definition IntMap_foldl {a b} (f : a -> b -> a) (z : a) (m : IntMap b) : a := 126 | let: getIntMap xs := m in foldl (fun acc x => f acc (snd x)) z xs. 127 | 128 | Definition IntMap_foldr {a b} (f : b -> a -> a) (z : a) (m : IntMap b) : a := 129 | let: getIntMap xs := m in foldr (fun x => f (snd x)) z xs. 130 | 131 | Definition IntMap_foldlWithKey 132 | {a b} (f : a -> nat -> b -> a) (z : a) (m : IntMap b) : a := 133 | let: getIntMap xs := m in foldl (fun acc x => f acc (fst x) (snd x)) z xs. 134 | 135 | Definition IntMap_foldrWithKey 136 | {a b} (f : b -> nat -> a -> a) (z : a) (m : IntMap b) : a := 137 | let: getIntMap xs := m in foldr (fun x => f (snd x) (fst x)) z xs. 138 | 139 | Definition IntMap_toList {a} (m : IntMap a) : seq (nat * a) := 140 | let: getIntMap xs := m in xs. 141 | 142 | Definition IntMap_addToList (k : nat) `(x : a) (m : IntMap (seq a)) : 143 | IntMap (seq a) := 144 | IntMap_alter (fun mxs => Some (if mxs is Some xs 145 | then x :: xs 146 | else [:: x])) k m. 147 | 148 | Definition IntMap_combine {a b c} 149 | (f : nat -> option a -> option b -> option c) : 150 | IntMap a -> IntMap b -> IntMap c := 151 | IntMap_mergeWithKey 152 | (fun idx x y => f idx (Some x) (Some y)) 153 | (IntMap_foldrWithKey 154 | (fun x idx rest => 155 | let mres := f idx (Some x) None in 156 | if mres is Some res 157 | then IntMap_insert idx res rest 158 | else rest) emptyIntMap) 159 | (IntMap_foldrWithKey 160 | (fun y idx rest => 161 | let mres := f idx None (Some y) in 162 | if mres is Some res 163 | then IntMap_insert idx res rest 164 | else rest) emptyIntMap). 165 | 166 | Section EqIntMap. 167 | 168 | Variable a : eqType. 169 | 170 | Definition eqIntMap (s1 s2 : IntMap a) := 171 | match s1, s2 with 172 | | getIntMap xs, getIntMap ys => xs == ys 173 | end. 174 | 175 | Lemma eqIntMapP : Equality.axiom eqIntMap. 176 | Proof. 177 | move. 178 | case=> [s1]. 179 | case=> [s2] /=. 180 | case: (s1 =P s2) => [<-|neqx]; last by right; case. 181 | by constructor. 182 | Qed. 183 | 184 | Canonical IntMap_eqMixin := EqMixin eqIntMapP. 185 | Canonical IntMap_eqType := Eval hnf in EqType (IntMap a) IntMap_eqMixin. 186 | 187 | End EqIntMap. 188 | 189 | Definition IntMap_groupOn {a} (p : a -> nat) (l : seq a) : 190 | IntMap (NonEmpty a) := 191 | forFold emptyIntMap l $ fun acc x => 192 | let n := p x in 193 | IntMap_alter (fun mxs => if mxs is Some xs 194 | then Some (NE_Cons x xs) 195 | else Some [::: x]) n acc. 196 | *) -------------------------------------------------------------------------------- /src/Control/Monad.v: -------------------------------------------------------------------------------- 1 | Require Export Hask.Control.Applicative. 2 | 3 | Generalizable All Variables. 4 | Set Primitive Projections. 5 | Set Universe Polymorphism. 6 | Unset Transparent Obligations. 7 | 8 | Class Monad (m : Type -> Type) := { 9 | is_applicative :> Applicative m; 10 | 11 | join : forall {a : Type}, m (m a) -> m a 12 | }. 13 | 14 | Arguments join {m _ _} _. 15 | 16 | Definition bind `{Monad m} {X Y : Type} (f : (X -> m Y)) : m X -> m Y := 17 | join \o fmap f. 18 | 19 | Definition return_ `{Monad m} {a : Type} : a -> m a := pure. 20 | 21 | Declare Scope monad_scope. 22 | Delimit Scope monad_scope with monad. 23 | 24 | Notation "join[ M ]" := (@join M _ _) (at level 9) : monad_scope. 25 | Notation "join[ M N ]" := (@join (M \o N) _ _) (at level 9) : monad_scope. 26 | 27 | Notation "m >>= f" := (bind f m) (at level 42, right associativity) : monad_scope. 28 | Notation "a >> b" := (a >>= fun _ => b)%monad (at level 81, right associativity) : monad_scope. 29 | 30 | Bind Scope monad_scope with Monad. 31 | 32 | Definition kleisli_compose `{Monad m} `(f : a -> m b) `(g : b -> m c) : 33 | a -> m c := fun x => (f x >>= g)%monad. 34 | 35 | Infix ">=>" := kleisli_compose (at level 42, right associativity) : monad_scope. 36 | Notation "f <=< g" := 37 | (kleisli_compose g f) (at level 42, right associativity) : monad_scope. 38 | 39 | Notation "f >=[ m ]=> g" := 40 | (@kleisli_compose _ m _ _ f _ g) (at level 42, right associativity) : monad_scope. 41 | Notation "f <=[ m ]=< g" := 42 | (@kleisli_compose _ m _ _ g _ f) (at level 42, right associativity) : monad_scope. 43 | 44 | Notation "X <- A ; B" := (A >>= (fun X => B))%monad 45 | (at level 81, right associativity, only parsing) : monad_scope. 46 | 47 | Notation "A ;; B" := (A >>= (fun _ => B))%monad 48 | (at level 81, right associativity, only parsing) : monad_scope. 49 | 50 | Open Scope monad_scope. 51 | 52 | Definition when `{Monad m} `(b : bool) (x : m unit) : m unit := 53 | if b then x else return_ tt. 54 | 55 | Definition unless `{Monad m} `(b : bool) (x : m unit) : m unit := 56 | if negb b then x else return_ tt. 57 | 58 | Fixpoint mapM `{Applicative m} {A B : Type} (f : A -> m B) (l : list A) : 59 | m (list B) := 60 | match l with 61 | | nil => pure nil 62 | | cons x xs => liftA2 (@cons _) (f x) (mapM f xs) 63 | end. 64 | 65 | Definition forM `{Applicative m} {A B : Type} (l : list A) (f : A -> m B) : 66 | m (list B) := mapM f l. 67 | 68 | Fixpoint mapM_ `{Applicative m} {A B : Type} (f : A -> m B) (l : list A) : m unit := 69 | match l with 70 | | nil => pure tt 71 | | cons x xs => liftA2 (const id) (f x) (mapM_ f xs) 72 | end. 73 | 74 | Definition forM_ `{Applicative m} {A B : Type} (l : list A) (f : A -> m B) : m unit := 75 | mapM_ f l. 76 | 77 | Definition foldM `{Monad m} {A B : Type} 78 | (f : A -> B -> m A) (s : A) (l : list B) : m A := 79 | let fix go xs z := 80 | match xs with 81 | | nil => pure z 82 | | cons y ys => f z y >>= go ys 83 | end in 84 | go l s. 85 | 86 | Definition forFoldM `{Monad m} {A B : Type} 87 | (s : A) (l : list B) (f : A -> B -> m A) : m A := foldM f s l. 88 | 89 | Definition foldrM `{Monad m} {A B : Type} 90 | (f : B -> A -> m A) (s : A) (l : list B) : m A := 91 | let fix go xs z := 92 | match xs with 93 | | nil => pure z 94 | | cons y ys => go ys z >>= f y 95 | end in 96 | go l s. 97 | 98 | Definition forFoldrM `{Monad m} {A B : Type} 99 | (s : A) (l : list B) (f : B -> A -> m A) : m A := foldrM f s l. 100 | 101 | Fixpoint flatten `(xs : list (list A)) : list A := 102 | match xs with 103 | | nil => nil 104 | | cons x xs' => app x (flatten xs') 105 | end. 106 | 107 | Definition concatMapM `{Applicative m} {A B : Type} 108 | (f : A -> m (list B)) (l : list A) : m (list B) := 109 | fmap flatten (mapM f l). 110 | 111 | Fixpoint replicateM_ `{Monad m} (n : nat) (x : m unit) : m unit := 112 | match n with 113 | | O => pure tt 114 | | S n' => x >> replicateM_ n' x 115 | end. 116 | 117 | Fixpoint insertM `{Monad m} {A : Type} (P : A -> A -> m bool) 118 | (z : A) (l : list A) : m (list A) := 119 | match l with 120 | | nil => pure (cons z nil) 121 | | cons x xs => 122 | b <- P x z ; 123 | if (b : bool) 124 | then cons x <$> insertM P z xs 125 | else pure (cons z (cons x xs)) 126 | end. 127 | Arguments insertM {m H A} P z l : simpl never. 128 | 129 | Class Monad_Distributes `{Monad M} `{Applicative N} := 130 | { prod : forall A, N (M (N A)) -> M (N A) 131 | }. 132 | 133 | Arguments prod M {_} N {_ Monad_Distributes} A _. 134 | 135 | Module MonadLaws. 136 | 137 | Include ApplicativeLaws. 138 | 139 | Class MonadLaws (m : Type -> Type) `{Monad m} := { 140 | has_applicative_laws :> ApplicativeLaws m; 141 | 142 | join_fmap_join : forall a, join \o fmap (@join m _ a) = join \o join; 143 | join_fmap_pure : forall a, join \o fmap (pure (a:=a)) = id; 144 | join_pure : forall a, join \o pure = @id (m a); 145 | join_fmap_fmap : forall a b (f : a -> b), 146 | join \o fmap (fmap f) = fmap f \o join 147 | }. 148 | 149 | Corollary join_fmap_join_x `{MonadLaws m} : forall a x, 150 | join (fmap (join (a:=a)) x) = join (join x). 151 | Proof. 152 | intros. 153 | replace (join[m] (join[m] x)) with ((join[m] \o join[m]) x). 154 | rewrite <- join_fmap_join. 155 | reflexivity. 156 | reflexivity. 157 | Qed. 158 | 159 | Corollary join_fmap_pure_x `{MonadLaws m} : forall a x, 160 | join (fmap (pure (a:=a)) x) = x. 161 | Proof. 162 | intros. 163 | replace x with (id x) at 2; auto. 164 | rewrite <- join_fmap_pure. 165 | reflexivity. 166 | Qed. 167 | 168 | Corollary join_pure_x `{MonadLaws m} : forall a x, 169 | join (pure x) = @id (m a) x. 170 | Proof. 171 | intros. 172 | rewrite <- join_pure. 173 | reflexivity. 174 | Qed. 175 | 176 | Corollary join_fmap_fmap_x `{MonadLaws m} : forall (a b : Type) (f : a -> b) x, 177 | join (fmap (fmap f) x) = fmap f (join x). 178 | Proof. 179 | intros. 180 | replace (fmap[m] f (join[m] x)) with ((fmap[m] f \o join[m]) x). 181 | rewrite <- join_fmap_fmap. 182 | reflexivity. 183 | reflexivity. 184 | Qed. 185 | 186 | (* These proofs are due to Mark P. Jones and Luc Duponcheel in their article 187 | "Composing monads", Research Report YALEU/DCS/RR-1004, December 1993. 188 | 189 | Given any Monad M, and any Premonad N (i.e., having pure), and further given 190 | an operation [prod] and its accompanying four laws, it can be shown that M 191 | N is closed under composition. 192 | *) 193 | Class Monad_DistributesLaws `{Applicative (M \o N)} `{Monad_Distributes M N} := 194 | { 195 | m_monad_laws :> MonadLaws M; 196 | n_applicative_laws :> ApplicativeLaws N; 197 | 198 | prod_fmap_fmap : forall A B (f : A -> B), 199 | prod M N B \o fmap[N] (fmap[M \o N] f) = fmap[M \o N] f \o prod M N A; 200 | prod_pure : forall A, prod M N A \o pure[N] = @id (M (N A)); 201 | prod_fmap_pure : forall A, prod M N A \o fmap[N] (pure[M \o N]) = pure[M]; 202 | prod_fmap_join_fmap_prod : forall A, 203 | prod M N A \o fmap[N] (join[M] \o fmap[M] (prod M N A)) 204 | = join[M] \o fmap[M] (prod M N A) \o prod M N (M (N A)) 205 | }. 206 | 207 | End MonadLaws. 208 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/State.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Ltac. 3 | Require Import Hask.Control.Monad. 4 | Require Import Hask.Control.Monad.State. 5 | Require Import Hask.Control.Monad.Trans.Class. 6 | 7 | Generalizable All Variables. 8 | Set Primitive Projections. 9 | Set Universe Polymorphism. 10 | Unset Transparent Obligations. 11 | Set Implicit Arguments. 12 | Unset Strict Implicit. 13 | Unset Printing Implicit Defensive. 14 | 15 | (****************************************************************************** 16 | * The StateT Monad transformer 17 | *) 18 | 19 | Definition StateT (s : Type) (m : Type -> Type) (a : Type):= 20 | s -> m (a * s)%type. 21 | 22 | Definition getT `{Applicative m} {s : Type} : StateT s m s := 23 | fun i => pure (i, i). 24 | Definition getsT `{Applicative m} {s a : Type} f : StateT s m a := 25 | fun s => pure (f s, s). 26 | Definition putT `{Applicative m} {s : Type} x : StateT s m unit := 27 | fun _ => pure (tt, x). 28 | 29 | Definition modifyT `{Applicative m} {s : Type} (f : s -> s) : StateT s m unit := 30 | fun i => pure (tt, f i). 31 | 32 | #[export] 33 | Program Instance StateT_Functor {s} `{Functor m} : Functor (StateT s m) := { 34 | fmap := fun A B f (x : StateT s m A) => fun st => 35 | x st <&> first f 36 | }. 37 | 38 | Definition StateT_ap `{Monad m} {s : Type} {a b : Type} 39 | (f : StateT s m (a -> b)) (x : StateT s m a) : StateT s m b := fun st => 40 | join (f st <&> fun z => match z with 41 | | (f', st') => x st' <&> first f' 42 | end). 43 | 44 | #[export] 45 | Program Instance StateT_Applicative `{Monad m} {s : Type} : 46 | Applicative (StateT s m) := { 47 | pure := fun _ x => fun st => pure (x, st); 48 | ap := @StateT_ap m _ s 49 | }. 50 | 51 | Definition StateT_join `{Monad m} {s a : Type} (x : StateT s m (StateT s m a)) : 52 | StateT s m a := join \o fmap (curry apply) \o x. 53 | 54 | #[export] 55 | Program Instance StateT_Monad `{Monad m} {s : Type} : Monad (StateT s m) := { 56 | join := @StateT_join m _ s 57 | }. 58 | 59 | #[export] 60 | Instance StateT_MonadTrans {s} : MonadTrans (StateT s) := 61 | { lift := fun m _ _ A x s => fmap (fun k => (k, s)) x 62 | }. 63 | 64 | Definition liftStateT `{Monad m} `(x : State s a) : StateT s m a := 65 | st <- getT ; 66 | let (a, st') := x st in 67 | putT st' ;; 68 | pure a. 69 | 70 | Require Import FunctionalExtensionality. 71 | 72 | Module StateTLaws. 73 | 74 | Include MonadLaws. 75 | 76 | Lemma first_id : forall a z, first (a:=a) (b:=a) (z:=z) id = id. 77 | Proof. 78 | unfold first. 79 | intros a z. 80 | extensionality x. 81 | destruct x; auto. 82 | Qed. 83 | 84 | #[export] 85 | Program Instance StateT_FunctorLaws {s} `{FunctorLaws m} : 86 | FunctorLaws (StateT s m). 87 | Next Obligation. Admitted. 88 | Next Obligation. Admitted. 89 | (* Obligation 1. *) 90 | (* move=> x. *) 91 | (* extensionality st. *) 92 | (* rewrite first_id. *) 93 | (* replace (fun z : a * s => (z.1, z.2)) with (@id (a * s)%type); last first. *) 94 | (* by extensionality z; case z. *) 95 | (* by rewrite fmap_id. *) 96 | (* Qed. *) 97 | (* Obligation 2. *) 98 | (* rewrite /funcomp => x. *) 99 | (* extensionality st. *) 100 | (* rewrite fmap_comp_x /first. *) 101 | (* f_equal. *) 102 | (* extensionality y. *) 103 | (* by case: y. *) 104 | (* Qed. *) 105 | 106 | #[export] 107 | Program Instance StateT_Applicative `{MonadLaws m} {s : Type} : 108 | ApplicativeLaws (StateT s m). 109 | Next Obligation. Admitted. 110 | Next Obligation. Admitted. 111 | Next Obligation. Admitted. 112 | Next Obligation. Admitted. 113 | Next Obligation. Admitted. 114 | (* Obligation 1. *) 115 | (* move=> x. *) 116 | (* extensionality st. *) 117 | (* rewrite /StateT_ap fmap_pure_x join_pure_x. *) 118 | (* set f := (X in fmap X). *) 119 | (* replace f with (@id (a * s)%type); last first. *) 120 | (* extensionality z. *) 121 | (* by case: z. *) 122 | (* by rewrite fmap_id. *) 123 | (* Qed. *) 124 | (* Obligation 2. *) 125 | (* extensionality st. *) 126 | (* rewrite /StateT_ap. *) 127 | (* set f := (X in join (fmap X _)). *) 128 | (* set g := (X in fmap f (join (fmap X _))). *) 129 | (* set h := (X in fmap g (join (fmap X _))). *) 130 | (* set i := (X in join (fmap X (u st))). *) 131 | (* rewrite -!join_fmap_fmap_x !fmap_comp_x fmap_pure_x *) 132 | (* join_pure_x -join_fmap_join_x. *) 133 | (* f_equal; rewrite !fmap_comp_x; f_equal. *) 134 | (* extensionality u'. *) 135 | (* case: u' => f' st'. *) 136 | (* rewrite /i -join_fmap_fmap_x. *) 137 | (* f_equal; rewrite !fmap_comp_x; f_equal. *) 138 | (* extensionality v'. *) 139 | (* case: v' => f'' st''. *) 140 | (* rewrite /f /first !fmap_comp_x; f_equal. *) 141 | (* extensionality w'. *) 142 | (* case: w' => f''' st'''. *) 143 | (* by rewrite /funcomp. *) 144 | (* Qed. *) 145 | (* Obligation 3. *) 146 | (* extensionality st. *) 147 | (* by rewrite /StateT_ap fmap_pure_x join_pure_x fmap_pure_x. *) 148 | (* Qed. *) 149 | (* Obligation 4. *) 150 | (* extensionality st. *) 151 | (* rewrite /StateT_ap fmap_pure_x. *) 152 | (* set f := (X in join (fmap X _)). *) 153 | (* set g := (X in _ = join (pure (fmap X _))). *) 154 | (* rewrite join_pure_x. *) 155 | (* recomp; f_equal. *) 156 | (* extensionality z. *) 157 | (* have H1 : pure \o g = f. *) 158 | (* rewrite /f /g /funcomp. *) 159 | (* extensionality x. *) 160 | (* case: x => f' st'. *) 161 | (* by rewrite fmap_pure_x. *) 162 | (* by rewrite -H1 /funcomp -fmap_comp_x join_fmap_pure_x. *) 163 | (* Qed. *) 164 | (* Obligation 5. *) 165 | (* move=> x. *) 166 | (* extensionality st. *) 167 | (* rewrite /StateT_ap fmap_pure_x join_pure_x. *) 168 | (* f_equal. *) 169 | (* Qed. *) 170 | 171 | #[export] 172 | Program Instance StateT_Monad `{MonadLaws m} {s : Type} : 173 | MonadLaws (StateT s m). 174 | Next Obligation. Admitted. 175 | Next Obligation. Admitted. 176 | Next Obligation. Admitted. 177 | Next Obligation. Admitted. 178 | (* Obligation 1. *) 179 | (* move=> f. *) 180 | (* extensionality st. *) 181 | (* rewrite /StateT_join /= -!ap_fmap -ap_comp !ap_homo *) 182 | (* !ap_fmap -join_fmap_fmap_x -join_fmap_join_x fmap_comp_x. *) 183 | (* f_equal. *) 184 | (* rewrite fmap_comp_x. *) 185 | (* f_equal. *) 186 | (* extensionality y. *) 187 | (* by case: y => f' st'. *) 188 | (* Qed. *) 189 | (* Obligation 2. *) 190 | (* move=> f. *) 191 | (* extensionality st. *) 192 | (* rewrite /StateT_join /= fmap_comp_x /curry /apply /first. *) 193 | (* set h := (X in fmap X _). *) 194 | (* replace h with (@pure m _ (a * s)%type); last first. *) 195 | (* extensionality z. *) 196 | (* by case: z. *) 197 | (* by rewrite join_fmap_pure_x. *) 198 | (* Qed. *) 199 | (* Obligation 3. *) 200 | (* move=> f. *) 201 | (* extensionality st. *) 202 | (* by rewrite /StateT_join /= fmap_pure_x join_pure_x. *) 203 | (* Qed. *) 204 | (* Obligation 4. *) 205 | (* move=> x. *) 206 | (* extensionality st. *) 207 | (* rewrite /StateT_join /= -join_fmap_fmap_x. *) 208 | (* f_equal; rewrite !fmap_comp_x; f_equal. *) 209 | (* extensionality y. *) 210 | (* by case: y. *) 211 | (* Qed. *) 212 | 213 | End StateTLaws. 214 | -------------------------------------------------------------------------------- /src/Data/Functor/Yoneda.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Ltac. 3 | Require Import Hask.Data.Functor.Identity. 4 | Require Import Hask.Data.Functor.Kan. 5 | Require Import Hask.Control.Monad. 6 | 7 | Generalizable All Variables. 8 | Set Primitive Projections. 9 | Set Universe Polymorphism. 10 | Unset Transparent Obligations. 11 | Set Asymmetric Patterns. 12 | 13 | Definition Yoneda (f : Type -> Type) (a : Type) := 14 | forall r : Type, (a -> r) -> f r. 15 | 16 | (* #[export] *) 17 | (* Instance Yoneda_lemma `{Functor f} : forall a, Yoneda f a ≅ f a := { *) 18 | (* iso_to := fun x => x _ id; *) 19 | (* iso_from := fun x _ k => fmap k x *) 20 | (* }. *) 21 | 22 | #[export] 23 | Instance Yoneda_Functor {f : Type -> Type} : Functor (Yoneda f) := { 24 | fmap := fun _ _ g k _ h => k _ (h \o g) 25 | }. 26 | 27 | #[export] 28 | Instance Yoneda_Applicative `{Applicative f} : 29 | Applicative (Yoneda f) := { 30 | pure := fun _ x => fun _ k => pure (k x); 31 | ap := fun a b g x => fun _ k => g _ (comp k) <*> x _ id 32 | }. 33 | 34 | Definition Yoneda_join `{Monad m} `(k : Yoneda m (Yoneda m a)) : Yoneda m a := 35 | fun _ h => join (k _ (fun y => y _ h)). 36 | 37 | #[export] 38 | Instance Yoneda_Monad `{Monad m} : Monad (Yoneda m) := { 39 | join := @Yoneda_join m _ 40 | }. 41 | 42 | Require Import FunctionalExtensionality. 43 | 44 | Module YonedaLaws. 45 | 46 | (* Include IsomorphismLaws. *) 47 | Include MonadLaws. 48 | 49 | (* Parametricity theorem. *) 50 | Corollary Yoneda_parametricity : forall `{Functor f} a b c (k : Yoneda f a) 51 | (g : b -> c) (h : a -> b), fmap g (k _ h) = k _ (g \o h). 52 | Proof. 53 | intros. 54 | pose proof (@Ran_parametricity a b c Identity _ f _). 55 | simpl in H0. 56 | unfold id in H0. 57 | Admitted. 58 | (* jww (2017-04-24): Universe inconsistency in Coq 8.6 *) 59 | (* 60 | apply (H0 k g h). 61 | Qed. 62 | *) 63 | 64 | (* #[export] *) 65 | (* Program Instance Yoneda_lemma `{FunctorLaws f} : *) 66 | (* forall a, @IsomorphismLaws (Yoneda f a) (f a) (Yoneda_lemma a). *) 67 | (* Obligation 1. *) 68 | (* extensionality x. *) 69 | (* simpl. *) 70 | (* extensionality r. *) 71 | (* extensionality g. *) 72 | (* apply Yoneda_parametricity. *) 73 | (* Qed. *) 74 | (* Obligation 2. *) 75 | (* extensionality x. *) 76 | (* unfold comp. *) 77 | (* rewrite fmap_id. *) 78 | (* reflexivity. *) 79 | (* Qed. *) 80 | 81 | #[export] 82 | Program Instance Yoneda_FunctorLaws {f : Type -> Type} : FunctorLaws (Yoneda f). 83 | 84 | #[export] 85 | Program Instance Yoneda_ApplicativeLaws `{ApplicativeLaws f} : 86 | ApplicativeLaws (Yoneda f). 87 | Obligation 1. 88 | extensionality x. 89 | extensionality r. 90 | extensionality k0. 91 | rewrite ap_fmap, <- fmap_comp, fmap_id. 92 | unfold comp, id. 93 | apply Yoneda_parametricity. 94 | Qed. 95 | Obligation 2. 96 | extensionality r. 97 | extensionality k. 98 | rewrite <- ap_comp; f_equal. 99 | repeat rewrite ap_fmap; f_equal. 100 | repeat rewrite Yoneda_parametricity; f_equal. 101 | Qed. 102 | Obligation 3. 103 | extensionality r. 104 | extensionality k. 105 | rewrite ap_fmap. 106 | unfold comp. 107 | rewrite <- fmap_comp_x. 108 | repeat rewrite fmap_pure_x. 109 | reflexivity. 110 | Qed. 111 | Obligation 4. 112 | extensionality r. 113 | extensionality k. 114 | rewrite ap_fmap, <- fmap_comp, ap_interchange. 115 | unfold comp. 116 | rewrite ap_fmap. 117 | repeat rewrite Yoneda_parametricity. 118 | f_equal. 119 | Qed. 120 | Obligation 5. 121 | extensionality k. 122 | extensionality r. 123 | extensionality g. 124 | rewrite ap_fmap, <- fmap_comp_x. 125 | unfold comp. 126 | repeat rewrite Yoneda_parametricity. 127 | f_equal. 128 | Qed. 129 | 130 | #[export] 131 | Program Instance Yoneda_MonadLaws `{MonadLaws m} : MonadLaws (Yoneda m). 132 | Obligation 1. 133 | extensionality k. 134 | unfold Yoneda_join. 135 | extensionality r. 136 | extensionality h. 137 | simpl. 138 | rewrite <- join_fmap_join_x, Yoneda_parametricity. 139 | reflexivity. 140 | Qed. 141 | Obligation 2. 142 | extensionality k. 143 | unfold Yoneda_join. 144 | extensionality r. 145 | extensionality h. 146 | unfold comp. 147 | replace (fun x : a => pure[m] (h x)) with (pure[m] \o h). 148 | rewrite <- Yoneda_parametricity. 149 | rewrite join_fmap_pure_x. 150 | reflexivity. 151 | reflexivity. 152 | Qed. 153 | Obligation 3. 154 | extensionality k. 155 | unfold Yoneda_join. 156 | extensionality r. 157 | extensionality h. 158 | unfold comp. 159 | rewrite join_pure_x. 160 | reflexivity. 161 | Qed. 162 | 163 | End YonedaLaws. 164 | 165 | (**************************************************************************) 166 | 167 | (* The contravariant Yoneda lemma, made applicable to covariant functors by 168 | changing it from a universally quantified function to an existentially 169 | quantified construction of two arguments. *) 170 | 171 | Inductive Coyoneda (f : Type -> Type) (a : Type) := 172 | COYO : forall x, (x -> a) -> f x -> Coyoneda f a. 173 | 174 | Arguments COYO {f a x} _ _. 175 | 176 | Definition liftCoyoneda {f : Type -> Type} {a : Type} : f a -> Coyoneda f a := 177 | COYO id. 178 | 179 | Definition lowerCoyoneda `{Functor f} {a : Type} (c : Coyoneda f a) : f a := 180 | match c with COYO _ g h => fmap g h end. 181 | 182 | #[export] 183 | Instance Coyoneda_Functor (f : Type -> Type) : Functor (Coyoneda f) := { 184 | fmap := fun _ _ f x => match x with COYO _ g h => COYO (f \o g) h end 185 | }. 186 | 187 | Require Import FunctionalExtensionality. 188 | 189 | Module CoyonedaLaws. 190 | 191 | Include FunctorLaws. 192 | 193 | #[export] 194 | Program Instance Coyoneda_FunctorLaws (f : Type -> Type) : 195 | FunctorLaws (Coyoneda f). 196 | Obligation 1. extensionality x. destruct x; reflexivity. Qed. 197 | Obligation 2. extensionality x. destruct x; reflexivity. Qed. 198 | 199 | Theorem coyo_to `{FunctorLaws f} : forall a (x : f a), 200 | lowerCoyoneda (liftCoyoneda x) = x. 201 | Proof. 202 | intros a x. 203 | unfold lowerCoyoneda, liftCoyoneda. 204 | rewrite fmap_id. 205 | reflexivity. 206 | Qed. 207 | 208 | Theorem coyo_lower_naturality `{FunctorLaws f} : forall a b (g : a -> b), 209 | fmap g \o lowerCoyoneda (f:=f) = lowerCoyoneda \o fmap g. 210 | Proof. 211 | intros a b k. 212 | extensionality x. 213 | destruct x as [x g h]; simpl. 214 | rewrite fmap_comp_x. 215 | reflexivity. 216 | Qed. 217 | 218 | Axiom coyo_parametricity : forall `{FunctorLaws f} a b (g : a -> b), 219 | COYO g = COYO id \o fmap g. 220 | 221 | Theorem coyo_lift_naturality `{FunctorLaws f} : forall a b (g : a -> b), 222 | fmap g \o liftCoyoneda (f:=f) = liftCoyoneda \o fmap g. 223 | Proof. 224 | intros a b g. 225 | unfold liftCoyoneda. 226 | extensionality x. 227 | simpl. 228 | replace (g \o id) with g; auto. 229 | rewrite coyo_parametricity. 230 | reflexivity. 231 | Qed. 232 | 233 | Theorem coyo_from `{FunctorLaws f} : forall a (x : Coyoneda f a), 234 | liftCoyoneda (lowerCoyoneda x) = x. 235 | Proof. 236 | intros a [x g h]. 237 | unfold lowerCoyoneda. 238 | replace (liftCoyoneda ((fmap[f] g) h)) with ((liftCoyoneda \o (fmap[f] g)) h). 239 | rewrite <- coyo_lift_naturality. 240 | reflexivity. 241 | reflexivity. 242 | Qed. 243 | 244 | End CoyonedaLaws. 245 | -------------------------------------------------------------------------------- /src/Control/Monad/Freer.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | 9 | Definition Free (f : Type -> Type) (a : Type) := 10 | forall r, (a -> r) -> (forall x, (x -> r) -> f x -> r) -> r. 11 | 12 | Definition iter `{Functor f} `(phi : f a -> a) (fr : Free f a) : a := 13 | fr _ id (fun _ k x => phi (fmap k x)). 14 | 15 | Definition liftF {f : Type -> Type} {a : Type} (x : f a) : Free f a := 16 | fun r p j => j a p x. 17 | 18 | Definition uniter `(psi : Free f a -> a) : f a -> a := 19 | psi \o liftF. 20 | 21 | Definition retract `{Monad f} `(fr : Free f a) : f a := 22 | fr _ pure (fun _ k x => x >>= k). 23 | 24 | Definition hoistFree `(n : forall a, f a -> g a) `(fr : Free f b) : 25 | Free g b := fun r p j => fr _ p (fun _ k v => j _ k (n _ v)). 26 | 27 | Definition foldFree `{Monad m} `(n : forall x, f x -> m x) `(fr : Free f a) : 28 | m a := fr _ pure (fun _ k x => join $ fmap k (n _ x)). 29 | 30 | Definition foldFreeCPS `(n : forall x r, f x -> (x -> r) -> r) 31 | `(fr : Free f a) : forall r, (a -> r) -> r := fun r p => 32 | fr r p (fun t k x => n t r x k). 33 | 34 | #[export] 35 | Instance Free_Functor `{Functor f} : Functor (Free f) := { 36 | fmap := fun _ _ k fr => fun _ p j => fr _ (p \o k) j 37 | }. 38 | 39 | #[export] 40 | Instance Free_Applicative `{Functor f} : Applicative (Free f) := { 41 | pure := fun _ x => fun _ p j => p x; 42 | ap := fun _ _ mf mx => 43 | fun _ p j => mf _ (fun f => mx _ (fun x => p (f x)) j) j 44 | }. 45 | 46 | #[export] 47 | Instance Free_Monad `{Functor f} : Monad (Free f) := { 48 | join := fun _ mm => fun _ p j => mm _ (fun m => m _ p j) j 49 | }. 50 | 51 | Require Import FunctionalExtensionality. 52 | 53 | Module FreeLaws. 54 | 55 | Include MonadLaws. 56 | 57 | #[export] 58 | Program Instance Free_FunctorLaws `{FunctorLaws f} : FunctorLaws (Free f). 59 | #[export] 60 | Program Instance Free_ApplicativeLaws `{FunctorLaws f} : 61 | ApplicativeLaws (Free f). 62 | #[export] 63 | Program Instance Free_MonadLaws `{FunctorLaws f} : MonadLaws (Free f). 64 | 65 | Theorem retract_liftF_id `{MonadLaws f} : forall a, 66 | retract \o liftF = @id (f a). 67 | Admitted. 68 | (* Proof. *) 69 | (* move=> *. *) 70 | (* rewrite /retract /liftF. *) 71 | (* exact: join_fmap_pure. *) 72 | (* Qed. *) 73 | 74 | Theorem retract_distributes `{Monad f} `{MonadLaws f} : forall a (x y : Free f a), 75 | retract (x >> y) = (retract x >> retract y). 76 | Admitted. 77 | (* Proof. *) 78 | (* move=> ?. *) 79 | (* elim=> [?|? ? IHx ?] y; rewrite /bind /=. *) 80 | (* by rewrite -ap_fmap ap_homo join_pure_x. *) 81 | (* rewrite -join_fmap_fmap_x fmap_comp_x *) 82 | (* -join_fmap_join_x fmap_comp_x. *) 83 | (* congr (join (fmap _ _)). *) 84 | (* extensionality x. *) 85 | (* exact: IHx. *) 86 | (* Qed. *) 87 | 88 | Theorem retract_naturality `{MonadLaws f} : forall a b (g : a -> b), 89 | fmap g \o retract (f:=f) = retract \o fmap g. 90 | Admitted. 91 | (* Proof. *) 92 | (* move=> a b g x. *) 93 | (* rewrite /=. *) 94 | (* elim: x => [?|? ? IHx ?] /=. *) 95 | (* by rewrite fmap_pure_x. *) 96 | (* rewrite -join_fmap_fmap_x fmap_comp_x. *) 97 | (* congr (join (fmap _ _)). *) 98 | (* extensionality y => /=. *) 99 | (* exact: IHx. *) 100 | (* Qed. *) 101 | 102 | (* 103 | Axiom Free_parametricity : forall `{FunctorLaws f} a b (g : a -> b), 104 | Join (Pure \o g) = Join Pure \o fmap g. 105 | *) 106 | 107 | Theorem liftF_naturality `{FunctorLaws f} : forall a b (g : a -> b), 108 | fmap g \o liftF (f:=f) = liftF \o fmap g. 109 | Admitted. 110 | (* Proof. *) 111 | (* move=> a b g x. *) 112 | (* rewrite /= /liftF. *) 113 | (* have ->: ([eta Free_bind (Pure \o g)] \o Pure) = Pure \o g. *) 114 | (* move=> ?. *) 115 | (* extensionality y. *) 116 | (* by rewrite /funcomp /Free_bind. *) 117 | (* exact: Free_parametricity. *) 118 | (* Qed. *) 119 | 120 | Corollary liftF_naturality_x `{FunctorLaws f} : forall a b (g : a -> b) x, 121 | fmap g (liftF x) = liftF (fmap g x). 122 | Proof. 123 | intros. 124 | replace ((fmap[Free f] g) (liftF x)) with (((fmap[Free f] g) \o liftF) x). 125 | rewrite liftF_naturality. 126 | reflexivity. 127 | reflexivity. 128 | Qed. 129 | 130 | Theorem uniter_iter_id `{MonadLaws f} : forall a, 131 | uniter \o iter = @id (f a -> a). 132 | Admitted. 133 | (* Proof. *) 134 | (* move=> * x. *) 135 | (* extensionality z. *) 136 | (* rewrite /uniter /=. *) 137 | (* have ->: iter x \o Pure = id by []. *) 138 | (* by rewrite fmap_id. *) 139 | (* Qed. *) 140 | 141 | (* 142 | Theorem iter_uniter_id `{MonadLaws f} : forall a, 143 | iter \o uniter = @id (Free f a -> a). 144 | Proof. 145 | move=> a x. 146 | extensionality z. 147 | rewrite /uniter /=. 148 | elim: z => /= [?|? ? IHz ?]. 149 | (* _a_ = x (Pure _a_) *) 150 | (* This is true by parametricity. *) 151 | move/functional_extensionality in IHz. 152 | rewrite -liftF_naturality_x. 153 | rewrite /funcomp IHz /= /funcomp. 154 | congr (x (Join _ _)). 155 | extensionality y. 156 | rewrite /Free_bind. 157 | (* Pure (x (_f_ y)) = _f_ y *) 158 | (* This is false if _f_ y returns Join. *) 159 | *) 160 | 161 | End FreeLaws. 162 | 163 | (* 164 | Fixpoint to_free `(v : Free.Free f a) : Freer.Free f a := 165 | match v with 166 | | Free.Pure x => fun _ p _ => p x 167 | | Free.Join r k x => fun _ p j => j _ (fun r => to_free (k r) p j) x 168 | end. 169 | 170 | Definition from_free `(v : Freer.Free f a) : Free.Free f a := 171 | v _ Pure (@Join f a). 172 | 173 | Lemma from_to_free : forall `(x : Free.Free f a), from_free (to_free x) = x. 174 | Proof. 175 | intros. 176 | unfold from_free. 177 | induction x; simpl. 178 | reflexivity. 179 | f_equal. 180 | extensionality r. 181 | rewrite H. 182 | reflexivity. 183 | Qed. 184 | 185 | Lemma free_ind : 186 | forall `{Functor f} {A} (P : Freer.Free f A -> Prop) 187 | (Hpure : forall (k : A), P (Pure k)) 188 | (Hjoin : forall x (v : f x), P x -> P x) 189 | (x : Free f A), P x. 190 | Proof. 191 | intros. 192 | destruct (x (Free.Free f A) Pure (@Join f A)). 193 | apply Hpure. 194 | apply Hpure. 195 | apply Hjoin. 196 | Qed. 197 | 198 | Lemma from_free_inj : forall `(x : Freer.Free f a) y, 199 | from_free x = from_free y -> x = y. 200 | Proof. 201 | Admitted. 202 | 203 | Lemma to_from_free : forall `(x : Freer.Free f a), to_free (from_free x) = x. 204 | Proof. 205 | intros. 206 | change (from_free (to_free (from_free x)) = from_free x). 207 | replace x with (from_free x). 208 | rewrite <- from_to_free. 209 | unfold to_free. 210 | 211 | Lemma inside_out : forall (f : Free IO unit) x, 212 | f (IO_ unit) x 213 | (fun t k (v : IO t) => 214 | match v with 215 | | PutStrLn s z => IOBind_ (putStrLn_ s) (k z) 216 | | Monitor s z => IOBind_ (putStrLn_ s) (k z) 217 | end) = 218 | IOBind_ (x tt) (f (IO_ unit) IOReturn_ 219 | (fun t k (v : IO t) => 220 | match v with 221 | | PutStrLn s z => IOBind_ (putStrLn_ s) (k z) 222 | | Monitor s z => IOBind_ (putStrLn_ s) (k z) 223 | end)). 224 | Proof. 225 | intros. 226 | compute. 227 | *) 228 | -------------------------------------------------------------------------------- /src/Control/Monad/Free.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | 4 | Generalizable All Variables. 5 | Set Primitive Projections. 6 | Set Universe Polymorphism. 7 | Unset Transparent Obligations. 8 | Set Asymmetric Patterns. 9 | 10 | Inductive Free (f : Type -> Type) (a : Type) := 11 | | Pure : a -> Free f a 12 | | Join : forall x, (x -> Free f a) -> f x -> Free f a. 13 | 14 | Arguments Pure {f a} _. 15 | Arguments Join {f a x} _ _. 16 | 17 | Fixpoint iter `{Functor f} `(phi : f a -> a) (fr : Free f a) : a := 18 | match fr with 19 | | Pure x => x 20 | | Join _ g h => phi $ fmap (iter phi \o g) h 21 | end. 22 | 23 | Definition liftF {f : Type -> Type} {a : Type} : f a -> Free f a := Join Pure. 24 | 25 | Definition uniter `{Functor f} `(psi : Free f a -> a) : f a -> a := 26 | psi \o liftF. 27 | 28 | Fixpoint retract `{Monad f} `(fr : Free f a) : f a := 29 | match fr with 30 | | Pure x => pure x 31 | | Join _ g h => h >>= (retract \o g) 32 | end. 33 | 34 | Fixpoint hoistFree `(n : forall a, f a -> g a) `(fr : Free f b) : 35 | Free g b := 36 | match fr with 37 | | Pure x => Pure x 38 | | Join _ g h => Join (hoistFree n \o g) (n _ h) 39 | end. 40 | 41 | Fixpoint foldFree `{Monad m} `(n : forall x, f x -> m x) `(fr : Free f a) : 42 | m a := 43 | match fr with 44 | | Pure x => pure x 45 | | Join _ g h => join $ fmap (foldFree n \o g) (n _ h) 46 | end. 47 | 48 | Fixpoint cutoff (n : nat) `(fr : Free f a) : Free f (option a) := 49 | match n with 50 | | O => Pure None 51 | | S n' => 52 | match fr with 53 | | Pure x => Pure (Some x) 54 | | Join _ g h => Join (cutoff n \o g) h 55 | end 56 | end. 57 | 58 | (* jww (2015-06-02): With universe polymorphism this should work fine. *) 59 | (* Definition wrap {f : Type -> Type} {a : Type} : *) 60 | (* f (Free f a) -> Free f a := Join id. *) 61 | 62 | Definition Free_bind `(k : a -> Free f b) : Free f a -> Free f b := 63 | fun x0 => let fix go x := match x with 64 | | Pure a => k a 65 | | Join _ g h => Join (go \o g) h 66 | end in 67 | go x0. 68 | 69 | #[export] 70 | Program Instance Free_Functor `{Functor f} : Functor (Free f) := { 71 | fmap := fun _ _ k => Free_bind (Pure \o k) 72 | }. 73 | 74 | #[export] 75 | Program Instance Free_Applicative `{Functor f} : 76 | Applicative (Free f) := { 77 | pure := fun _ => Pure; 78 | ap := fun _ _ mf mx => Free_bind (flip fmap mx) mf 79 | }. 80 | 81 | #[export] 82 | Program Instance Free_Monad `{Functor f} : Monad (Free f) := { 83 | join := fun _ => Free_bind id 84 | }. 85 | 86 | (* 87 | Require Import FunctionalExtensionality. 88 | 89 | Module FreeLaws. 90 | 91 | Include MonadLaws. 92 | 93 | Ltac reduce_free H := 94 | unfold id, comp, flip; 95 | try extensionality XX; 96 | simpl; auto; 97 | try match goal with 98 | | [ HF : Free _ _ |- _ ] => 99 | induction HF as [|? ? H ?]; simpl; auto 100 | end; 101 | try f_equal; 102 | try apply f_equal2; auto; 103 | try extensionality YY; 104 | try apply H. 105 | 106 | #[export] 107 | Program Instance Free_FunctorLaws `{FunctorLaws f} : FunctorLaws (Free f). 108 | Obligation 1. reduce_free IHx. Qed. 109 | Obligation 2. reduce_free IHx. Qed. 110 | 111 | #[export] 112 | Program Instance Free_ApplicativeLaws `{FunctorLaws f} : 113 | ApplicativeLaws (Free f). 114 | Obligation 1. reduce_free IHx. Qed. 115 | Obligation 2. 116 | induction u as [?|? ? IHu ?]. 117 | induction v as [?|? ? IHv ?]; simpl. 118 | reduce_free IHw. 119 | reduce_free IHv. 120 | reduce_free IHu. 121 | Qed. 122 | 123 | #[export] 124 | Program Instance Free_MonadLaws `{FunctorLaws f} : MonadLaws (Free f). 125 | Obligation 1. reduce_free IHx. Qed. 126 | Obligation 2. reduce_free IHx. Qed. 127 | Obligation 4. reduce_free IHx. Qed. 128 | 129 | Theorem retract_liftF_id `{MonadLaws f} : forall a, 130 | retract \o liftF = @id (f a). 131 | Proof. 132 | intros. 133 | unfold retract, liftF, comp. 134 | apply join_fmap_pure. 135 | Qed. 136 | 137 | Theorem retract_distributes `{MonadLaws f} : forall a (x y : Free f a), 138 | retract (x >> y) = (retract x >> retract y). 139 | Admitted. 140 | (* Proof. *) 141 | (* move=> ?. *) 142 | (* elim=> [?|? ? IHx ?] y; rewrite /bind /=. *) 143 | (* by rewrite -ap_fmap ap_homo join_pure_x. *) 144 | (* rewrite -join_fmap_fmap_x fmap_comp_x *) 145 | (* -join_fmap_join_x fmap_comp_x. *) 146 | (* congr (join (fmap _ _)). *) 147 | (* extensionality x. *) 148 | (* exact: IHx. *) 149 | (* Qed. *) 150 | 151 | Theorem retract_naturality `{MonadLaws f} : forall a b (g : a -> b), 152 | fmap g \o retract (f:=f) = retract \o fmap g. 153 | Admitted. 154 | (* Proof. *) 155 | (* move=> a b g x. *) 156 | (* rewrite /=. *) 157 | (* elim: x => [?|? ? IHx ?] /=. *) 158 | (* by rewrite fmap_pure_x. *) 159 | (* rewrite -join_fmap_fmap_x fmap_comp_x. *) 160 | (* congr (join (fmap _ _)). *) 161 | (* extensionality y => /=. *) 162 | (* exact: IHx. *) 163 | (* Qed. *) 164 | 165 | Axiom Free_parametricity : forall `{FunctorLaws f} a b (g : a -> b), 166 | Join (Pure \o g) = Join Pure \o fmap g. 167 | 168 | Theorem liftF_naturality `{FunctorLaws f} : forall a b (g : a -> b), 169 | fmap g \o liftF (f:=f) = liftF \o fmap g. 170 | Admitted. 171 | (* Proof. *) 172 | (* move=> a b g x. *) 173 | (* rewrite /= /liftF. *) 174 | (* have ->: ([eta Free_bind (Pure \o g)] \o Pure) = Pure \o g. *) 175 | (* move=> ?. *) 176 | (* extensionality y. *) 177 | (* by rewrite /funcomp /Free_bind. *) 178 | (* exact: Free_parametricity. *) 179 | (* Qed. *) 180 | 181 | Corollary liftF_naturality_x `{FunctorLaws f} : forall a b (g : a -> b) x, 182 | fmap g (liftF x) = liftF (fmap g x). 183 | Proof. 184 | intros. 185 | replace ((fmap[Free f] g) (liftF x)) with (((fmap[Free f] g) \o liftF) x). 186 | rewrite liftF_naturality. 187 | reflexivity. 188 | reflexivity. 189 | Qed. 190 | 191 | Theorem uniter_iter_id `{MonadLaws f} : forall a, 192 | uniter \o iter = @id (f a -> a). 193 | Admitted. 194 | (* Proof. *) 195 | (* move=> * x. *) 196 | (* extensionality z. *) 197 | (* rewrite /uniter /=. *) 198 | (* have ->: iter x \o Pure = id by []. *) 199 | (* by rewrite fmap_id. *) 200 | (* Qed. *) 201 | 202 | (* 203 | Theorem iter_uniter_id `{MonadLaws f} : forall a, 204 | iter \o uniter = @id (Free f a -> a). 205 | Proof. 206 | move=> a x. 207 | extensionality z. 208 | rewrite /uniter /=. 209 | elim: z => /= [?|? ? IHz ?]. 210 | (* _a_ = x (Pure _a_) *) 211 | (* This is true by parametricity. *) 212 | move/functional_extensionality in IHz. 213 | rewrite -liftF_naturality_x. 214 | rewrite /funcomp IHz /= /funcomp. 215 | congr (x (Join _ _)). 216 | extensionality y. 217 | rewrite /Free_bind. 218 | (* Pure (x (_f_ y)) = _f_ y *) 219 | (* This is false if _f_ y returns Join. *) 220 | *) 221 | 222 | End FreeLaws. 223 | *) 224 | 225 | CoInductive CoFree (h : Type -> Type) (a : Type) := 226 | CoF : a -> forall x, (x -> CoFree h a) -> h x -> CoFree h a. 227 | 228 | Arguments CoF {h a} _ {x} _ _. 229 | 230 | CoFixpoint unfold `(k : b -> a * f b) (z : b) : CoFree f a := 231 | match k z with (x, j) => CoF x (unfold k) j end. 232 | 233 | CoFixpoint CoFree_map {h} `(f : a -> b) (c : CoFree h a) : 234 | CoFree h b := 235 | match c with CoF x s g h => CoF (f x) (CoFree_map f \o g) h end. 236 | 237 | #[export] 238 | Program Instance CoFree_Functor `{Functor h} : Functor (CoFree h) := { 239 | fmap := fun _ _ => CoFree_map 240 | }. 241 | 242 | Module CoFreeLaws. 243 | 244 | Include FunctorLaws. 245 | 246 | (* 247 | #[export] 248 | Program Instance CoFree_FunctorLaws `{FunctorLaws h} : FunctorLaws (CoFree h). 249 | Obligation 1. 250 | move=> x. 251 | destruct x. 252 | Obligation 2. 253 | move=> x. 254 | destruct x. 255 | *) 256 | 257 | End CoFreeLaws. 258 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Either.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Control.Monad. 3 | Require Import Hask.Control.Monad.Trans.Class. 4 | Require Import Hask.Control.Monad.Morph. 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | 11 | Definition EitherT (X : Type) (M : Type -> Type) (Y : Type) : Type := 12 | M (Either X Y). 13 | 14 | Definition EitherT_map {E M} `{Functor M} {X Y} 15 | (f : X -> Y) (x : EitherT E M X) : EitherT E M Y := 16 | (fmap[M] (fmap[Either E] f)) x. 17 | 18 | #[export] 19 | Instance EitherT_Functor {E M} `{Functor M} : Functor (EitherT E M) := 20 | { fmap := fun _ _ => EitherT_map 21 | }. 22 | (* jww (2015-06-17): NYI 23 | Proof. 24 | - (* fun_identity *) 25 | intros. 26 | extensionality x. 27 | unfold EitherT_map. 28 | destruct x. 29 | repeat (rewrite fun_identity). 30 | unfold id. 31 | reflexivity. 32 | 33 | - (* fun_composition *) 34 | intros. 35 | extensionality x. 36 | unfold EitherT_map. 37 | destruct x. 38 | repeat (rewrite <- fun_composition). 39 | unfold compose. 40 | reflexivity. 41 | Defined. 42 | *) 43 | 44 | Definition EitherT_pure {E M} `{Applicative M} {X} 45 | : X -> EitherT E M X := pure[M] \o pure[Either E]. 46 | 47 | Definition EitherT_apply {E M} `{Applicative M} {X Y} 48 | (mf : EitherT E M (X -> Y)) (mx : EitherT E M X) : EitherT E M Y := 49 | liftA2 (@ap _ Either_Applicative X Y) mf mx. 50 | 51 | #[export] 52 | Instance EitherT_Applicative {E M} `{Applicative M} 53 | : Applicative (EitherT E M) := 54 | { pure := fun _ => EitherT_pure 55 | ; ap := fun _ _ => EitherT_apply 56 | }. 57 | (* jww (2015-06-17): NYI 58 | Proof. 59 | - (* app_identity *) intros. extensionality x. 60 | unfold EitherT_apply, EitherT_pure. 61 | destruct x. 62 | unfold id, compose. 63 | f_equal. 64 | apply (@app_identity_x (fun X => fobj (fobj X)) 65 | (Applicative_Compose M (Either E))). 66 | 67 | - (* app_composition *) intros. 68 | unfold EitherT_apply, EitherT_pure. 69 | destruct u. destruct v. destruct w. 70 | unfold compose. 71 | f_equal. 72 | apply (@app_composition (fun X => fobj (fobj X)) 73 | (Applicative_Compose M (Either E))). 74 | 75 | - (* app_homomorphism *) intros. 76 | unfold EitherT_apply, EitherT_pure. f_equal. 77 | unfold compose. 78 | f_equal. 79 | apply (@app_homomorphism (fun X => fobj (fobj X)) 80 | (Applicative_Compose M (Either E))). 81 | 82 | - (* app_interchange *) intros. 83 | unfold EitherT_apply, EitherT_pure. 84 | destruct u. 85 | unfold compose. 86 | f_equal. 87 | apply (@app_interchange (fun X => fobj (fobj X)) 88 | (Applicative_Compose M (Either E))). 89 | 90 | - (* app_fmap_unit *) intros. 91 | unfold EitherT_apply, EitherT_pure. 92 | unfold compose. 93 | f_equal. 94 | rewrite_app_homomorphisms. 95 | reflexivity. 96 | Defined. 97 | *) 98 | 99 | Definition EitherT_join {E M} `{Monad M} {X} (x : EitherT E M (EitherT E M X)) : 100 | EitherT E M X := 101 | join (fmap (fun y => match y with 102 | | Left e => pure (Left e) 103 | | Right mx' => mx' 104 | end) x). 105 | 106 | #[export] 107 | Instance EitherT_Monad {E M} `{Monad M} : Monad (EitherT E M) := 108 | { join := fun _ => EitherT_join 109 | }. 110 | (* jww (2015-06-17): NYI 111 | Proof. 112 | - (* monad_law_1 *) intros. extensionality x. simpl. 113 | unfold compose, EitherT_join. 114 | destruct x. simpl. 115 | f_equal. simpl. 116 | unfold Either_map. 117 | repeat (rewrite fun_composition_x). 118 | unfold compose. 119 | rewrite <- monad_law_4_x. 120 | unfold compose. 121 | rewrite <- monad_law_1_x. 122 | repeat (rewrite fun_composition_x). 123 | repeat f_equal. 124 | unfold compose. 125 | extensionality x. destruct x. 126 | rewrite <- app_fmap_unit. 127 | rewrite app_homomorphism. 128 | rewrite monad_law_3_x. 129 | reflexivity. 130 | destruct e. reflexivity. 131 | 132 | - (* monad_law_2 *) intros. extensionality x. simpl. 133 | unfold compose, EitherT_join, EitherT_pure. 134 | simpl. destruct x. 135 | unfold EitherT_map, id. 136 | simpl. f_equal. 137 | rewrite fun_composition_x. 138 | unfold compose, Either_map. 139 | rewrite <- uncompose with (f := join). 140 | assert ((fun x : Either E X => 141 | match 142 | match x with 143 | | Left e => Left E (EitherT E M X) e 144 | | Right x' => 145 | Right E (EitherT E M X) 146 | (EitherT_ E M X ((pure/M) (Right E X x'))) 147 | end 148 | with 149 | | Left e => (pure/M) (Left E X e) 150 | | Right (EitherT_ mx') => mx' 151 | end) = (@pure M _ (Either E X))). 152 | extensionality x. destruct x; reflexivity. rewrite H0. clear H0. 153 | apply monad_law_2_x. 154 | assumption. 155 | 156 | - (* monad_law_3 *) intros. extensionality x. simpl. 157 | unfold compose, EitherT_join, EitherT_pure. 158 | simpl. destruct x. 159 | unfold compose, id. f_equal. 160 | rewrite <- app_fmap_compose_x. 161 | rewrite <- uncompose with (f := join). 162 | rewrite monad_law_3. reflexivity. 163 | assumption. 164 | 165 | - (* monad_law_4 *) intros. extensionality x. simpl. 166 | unfold compose, EitherT_join, EitherT_map. 167 | simpl. destruct x. f_equal. 168 | rewrite <- monad_law_4_x. 169 | f_equal. 170 | repeat (rewrite fun_composition_x). 171 | unfold compose. 172 | f_equal. extensionality x. 173 | destruct x; simpl. 174 | unfold Either_map. simpl. 175 | rewrite <- app_fmap_compose_x. reflexivity. 176 | destruct e. reflexivity. 177 | Defined. 178 | *) 179 | 180 | #[export] 181 | Instance EitherT_MonadTrans {E} : MonadTrans (EitherT E) := 182 | { lift := fun m _ _ A => fmap Right 183 | }. 184 | (* jww (2015-06-17): NYI 185 | Proof. 186 | - (* trans_law_1 *) intros. extensionality x. 187 | repeat (rewrite <- comp_assoc). 188 | rewrite <- app_fmap_compose. 189 | reflexivity. 190 | - (* trans_law_2 *) intros. 191 | unfold bind, compose. simpl. 192 | repeat (rewrite fun_composition_x). 193 | unfold compose. simpl. f_equal. 194 | rewrite <- monad_law_4_x. f_equal. 195 | rewrite fun_composition_x. 196 | reflexivity. 197 | Defined. 198 | *) 199 | 200 | #[export] 201 | Program Instance EitherT_MFunctor {E} : MFunctor (EitherT E) := 202 | { hoist := fun M N _ _ A nat => nat (Either E A) 203 | }. 204 | (* jww (2015-06-17): NYI 205 | Proof. 206 | - (* hoist_law_1 *) intros. extensionality x. 207 | destruct x. subst. 208 | reflexivity. 209 | - (* hoist_law_2 *) intros. extensionality x. 210 | destruct x. 211 | unfold compose. 212 | reflexivity. 213 | Defined. 214 | *) 215 | 216 | (* 217 | #[export] 218 | Instance EitherT_MMonad {E} 219 | `{Monad (Either E)} 220 | : MMonad (EitherT E) EitherT_MFunctor EitherT_MonadTrans := 221 | { embed := fun M N nd tnd A f m => 222 | EitherT_ E N A (match m with 223 | EitherT_ m' => match f (Either E A) m' with 224 | EitherT_ m'' => 225 | fmap (fun x => match x with 226 | | Left e => Left E A e 227 | | Right (Left e) => Left E A e 228 | | Right (Right x) => Right E A x 229 | end) m'' 230 | end 231 | end) 232 | }. 233 | Proof. 234 | - (* embed_law_1 *) intros. extensionality x. 235 | destruct x. 236 | unfold id. 237 | f_equal. 238 | inversion td. 239 | - (* embed_law_2 *) intros. 240 | - (* embed_law_3 *) intros. 241 | Defined. 242 | *) 243 | -------------------------------------------------------------------------------- /src/Ltac.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.micromega.Lia. 2 | 3 | Set Implicit Arguments. 4 | Unset Strict Implicit. 5 | Unset Printing Implicit Defensive. 6 | Generalizable All Variables. 7 | 8 | Ltac inv H := inversion H; subst; simpl; clear H. 9 | Ltac contra := intros top; contradiction top; clear top. 10 | Ltac invert := intros top; inversion top; clear top. 11 | 12 | Tactic Notation "invert" "as" simple_intropattern(pat) := 13 | intros top; inversion top as pat; clear top. 14 | 15 | Lemma ltn_leq_trans : forall n m p : nat, m < n -> n <= p -> m < p. 16 | Proof. intros. lia. Qed. 17 | 18 | Definition comp {a b c} (f : b -> c) (g : a -> b) (x : a) : c := f (g x). 19 | Arguments comp {a b c} f g x /. 20 | 21 | Infix "\o" := comp (at level 50). 22 | 23 | Theorem comp_id_left : forall {A B} (f : A -> B), id \o f = f. 24 | Proof. reflexivity. Qed. 25 | 26 | #[export] Hint Resolve comp_id_left : core. 27 | 28 | Theorem comp_id_right : forall {A B} (f : A -> B), f \o id = f. 29 | Proof. reflexivity. Qed. 30 | 31 | #[export] Hint Resolve comp_id_right : core. 32 | 33 | Theorem comp_assoc : forall {A B C D} (f : C -> D) (g : B -> C) (h : A -> B), 34 | f \o (g \o h) = (f \o g) \o h. 35 | Proof. reflexivity. Qed. 36 | 37 | #[export] Hint Resolve comp_assoc : core. 38 | 39 | Theorem uncompose : forall {A B C} (f : B -> C) (g : A -> B) (x : A) (y : C), 40 | (f \o g) x = f (g x). 41 | Proof. reflexivity. Qed. 42 | 43 | Ltac uncompose k := 44 | rewrite <- (uncompose k); 45 | repeat (rewrite <- comp_assoc). 46 | 47 | Definition const {A B : Type} (x : A) : B -> A := fun _ => x. 48 | 49 | (* 50 | Ltac breakup := 51 | repeat match goal with 52 | | [ H: is_true (_ && _) |- _ ] => move/andP: H => [? ?] 53 | | [ |- is_true (_ && _) ] => apply/andP; split 54 | | [ H: is_true (_ || _) |- _ ] => move/orP: H => [?|?] 55 | | [ |- is_true (_ || _) ] => apply/orP; split 56 | | [ H: is_true (?X < ?Y < ?Z) |- _ ] => move/andP: H => [? ?] 57 | | [ H: is_true (?X <= ?Y <= ?Z) |- _ ] => move/andP: H => [? ?] 58 | | [ H: is_true (?X < ?Y <= ?Z) |- _ ] => move/andP: H => [? ?] 59 | | [ H: is_true (?X <= ?Y < ?Z) |- _ ] => move/andP: H => [? ?] 60 | | [ |- is_true (?X < ?Y < ?Z) ] => apply/andP; split 61 | | [ |- is_true (?X <= ?Y <= ?Z) ] => apply/andP; split 62 | | [ |- is_true (?X < ?Y <= ?Z) ] => apply/andP; split 63 | | [ |- is_true (?X <= ?Y < ?Z) ] => apply/andP; split 64 | | [ H: is_true (~~ (?X < ?Y < ?Z)) |- _ ] => move/nandP in H 65 | | [ H: is_true (~~ (?X <= ?Y < ?Z)) |- _ ] => move/nandP in H 66 | | [ H: is_true (~~ (?X < ?Y <= ?Z)) |- _ ] => move/nandP in H 67 | | [ H: is_true (~~ (?X <= ?Y <= ?Z)) |- _ ] => move/nandP in H 68 | | [ |- is_true (~~ (?X < ?Y < ?Z)) ] => apply/nandP 69 | | [ |- is_true (~~ (?X <= ?Y < ?Z)) ] => apply/nandP 70 | | [ |- is_true (~~ (?X < ?Y <= ?Z)) ] => apply/nandP 71 | | [ |- is_true (~~ (?X <= ?Y <= ?Z)) ] => apply/nandP 72 | end; 73 | repeat match goal with 74 | | [ H1: is_true (?X < ?Y), H2: is_true (?Y < ?Z) |- _ ] => 75 | match goal with 76 | | [ H: is_true (X < Z) |- _ ] => idtac 77 | | _ => move: (ltn_trans H1 H2) => ? 78 | end 79 | | [ H1: is_true (?X < ?Y), H2: is_true (?Y <= ?Z) |- _ ] => 80 | match goal with 81 | | [ H: is_true (X < Z) |- _ ] => idtac 82 | | _ => move: (ltn_leq_trans H1 H2) => ? 83 | end 84 | | [ H1: is_true (?X <= ?Y), H2: is_true (?Y < ?Z) |- _ ] => 85 | match goal with 86 | | [ H: is_true (X < Z) |- _ ] => idtac 87 | | _ => move: (leq_ltn_trans H1 H2) => ? 88 | end 89 | | [ H1: is_true (?X <= ?Y), H2: is_true (?Y <= ?Z) |- _ ] => 90 | match goal with 91 | | [ H: is_true (X <= Z) |- _ ] => idtac 92 | | _ => move: (leq_trans H1 H2) => ? 93 | end 94 | end; 95 | intuition. 96 | 97 | Lemma negneg : forall (a : eqType) (x y : a), ~~ (x != y) -> x = y. 98 | Proof. 99 | move=> a x y H. 100 | move/negbTE in H. 101 | case E: (x == y). 102 | by move/eqP in E. 103 | move/eqP in E. 104 | by move/eqP in H. 105 | Qed. 106 | 107 | Lemma negb_eq : forall (T : eqType) (a b : T), ~~ (a != b) = (a == b). 108 | Proof. by move=> T a b; case: (a == b). Qed. 109 | 110 | Ltac ordered := abstract ( 111 | intuition; 112 | breakup; 113 | repeat match goal with 114 | | [ H: (_ <= _) = false |- _ ] => move/negbT in H 115 | | [ H: (_ < _) = false |- _ ] => move/negbT in H 116 | end; 117 | repeat match goal with 118 | | [ H: is_true (~~ (?X < ?Y)) |- _ ] => rewrite -leqNgt in H 119 | | [ H: is_true (~~ (?X <= ?Y)) |- _ ] => rewrite -ltnNge in H 120 | | [ H: is_true (~~ (?X == ?Y)) |- _ ] => idtac 121 | | [ H: is_true (~~ (?X != ?Y)) |- _ ] => rewrite negb_eq in H 122 | | [ |- is_true (~~ (?X < ?Y)) ] => rewrite -leqNgt 123 | | [ |- is_true (~~ (?X <= ?Y)) ] => rewrite -ltnNge 124 | | [ |- is_true (~~ (?X == ?Y)) ] => idtac 125 | | [ |- is_true (~~ (?X != ?Y)) ] => rewrite negb_eq 126 | end; 127 | repeat match goal with 128 | | [ H: is_true (?X < ?Y) |- _ ] => move/ltP in H 129 | | [ H: is_true (?X <= ?Y) |- _ ] => move/leP in H 130 | | [ H: is_true (?X == ?Y) |- _ ] => move/eqP in H 131 | | [ H: is_true (?X != ?Y) |- _ ] => move/eqP in H 132 | | [ |- is_true (?X < ?Y) ] => apply/ltP 133 | | [ |- is_true (?X <= ?Y) ] => apply/leP 134 | | [ |- is_true (?X == ?Y) ] => apply/eqP 135 | | [ |- is_true (?X != ?Y) ] => apply/eqP 136 | end; 137 | omega). 138 | 139 | Lemma ltn_addn1 : forall n m, n < m -> n.+1 < m.+1. 140 | Proof. by []. Qed. 141 | 142 | Lemma leq_addn1 : forall n m, n <= m -> n.+1 <= m.+1. 143 | Proof. by []. Qed. 144 | 145 | Ltac undoubled := 146 | breakup; 147 | do [ apply/ltn_addn1; rewrite ltn_double 148 | | apply/leq_addn1; rewrite leq_double 149 | | rewrite doubleS ]; 150 | do [ ordered 151 | | do [ exact/ltnW/ltnW 152 | | exact/ltnW 153 | | exact/leqW/leqW 154 | | exact/leqW ]; 155 | ordered ]. 156 | 157 | Lemma Forall_all : forall (T : Type) (a : pred T) (s : seq T), 158 | reflect (List.Forall a s) (all a s). 159 | Proof. 160 | move=> T a. 161 | elim=> [|x xs IHxs] //=. 162 | by constructor; constructor. 163 | case E: (a x) => /=. 164 | case A: (all a xs). 165 | constructor. 166 | constructor. 167 | by rewrite E. 168 | exact/IHxs. 169 | constructor. 170 | move=> Hcontra. 171 | inversion Hcontra; subst. 172 | rewrite A in IHxs. 173 | by move/IHxs in H2. 174 | constructor. 175 | move=> Hcontra. 176 | inversion Hcontra; subst. 177 | by rewrite E in H1. 178 | Qed. 179 | 180 | Ltac match_all := 181 | repeat match goal with 182 | | [ H: List.Forall _ ?Z |- _ ] => move/Forall_all in H 183 | | [ |- List.Forall _ ?Z ] => apply/Forall_all 184 | end; 185 | abstract match goal with 186 | | [ H: is_true (all _ ?Z) |- is_true (all _ ?Z) ] => 187 | move/allP in H; 188 | apply/allP; 189 | intros x_1 H_1; 190 | specialize (H x_1 H_1); 191 | clear H_1; 192 | ordered 193 | end. 194 | *) 195 | 196 | Ltac move_to_top x := 197 | match reverse goal with 198 | | H : _ |- _ => try move x after H 199 | end. 200 | 201 | Tactic Notation "assert_eq" ident(x) constr(v) := 202 | let H := fresh in 203 | assert (x = v) as H by reflexivity; 204 | clear H. 205 | 206 | Tactic Notation "Case_aux" ident(x) constr(name) := 207 | first [ 208 | set (x := name); move_to_top x 209 | | assert_eq x name; move_to_top x 210 | | fail 1 "because we are working on a different case" ]. 211 | 212 | Tactic Notation "Case" constr(name) := Case_aux Case name. 213 | Tactic Notation "SCase" constr(name) := Case_aux SCase name. 214 | Tactic Notation "SSCase" constr(name) := Case_aux SSCase name. 215 | Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name. 216 | Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name. 217 | Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name. 218 | Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name. 219 | Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name. 220 | -------------------------------------------------------------------------------- /research/Conduit.v: -------------------------------------------------------------------------------- 1 | Require Export Cont. 2 | Require Export EitherT. 3 | Require Export Trans. 4 | Require Category. 5 | 6 | (* A type-wrapper is not strictly necessary here, since the Functor, 7 | Applicative and Monad behaviors are all directly based on Cont. In Haskell 8 | it is needed, so we match that behavior here, to prove that nothing is 9 | violated owing to the wrapping. 10 | *) 11 | Inductive Source (M : Type -> Type) (R : Type) (A : Type) : Type := 12 | Source_ : Cont (R -> EitherT R M R) A -> Source M R A. 13 | 14 | Definition Source_map {M : Type -> Type} `{Functor M} {R X Y} 15 | (f : X -> Y) (x : Source M R X) : Source M R Y := 16 | match x with Source_ k => Source_ M R Y (fmap f k) end. 17 | 18 | #[export] 19 | Instance Source_Functor {M : Type -> Type} `{Functor M} {R} 20 | : Functor (Source M R) := 21 | { fmap := @Source_map M _ R 22 | }. 23 | Proof. 24 | - (* fun_identity *) intros. extensionality x. 25 | unfold Source_map. 26 | destruct x. 27 | unfold id. 28 | f_equal. simpl. 29 | unfold Cont_map. 30 | destruct c. 31 | f_equal. 32 | - (* fun_composition *) intros. extensionality x. 33 | unfold Source_map. 34 | destruct x. simpl. 35 | unfold compose, Cont_map. 36 | f_equal. 37 | destruct c. 38 | f_equal. 39 | Defined. 40 | 41 | Definition Source_apply {M : Type -> Type} `{Applicative M} 42 | {R X Y} (f : Source M R (X -> Y)) (x : Source M R X) : Source M R Y := 43 | match f with 44 | Source_ k => match x with 45 | Source_ j => Source_ M R Y (ap k j) 46 | end 47 | end. 48 | 49 | #[export] 50 | Instance Source_Applicative {M : Type -> Type} `{Applicative M} 51 | {R} : Applicative (Source M R) := 52 | { is_functor := Source_Functor 53 | ; pure := fun A x => Source_ M R A (pure x) 54 | ; ap := @Source_apply M _ R 55 | }. 56 | Proof. 57 | - (* app_identity *) 58 | intros. extensionality x. 59 | destruct x. 60 | unfold id, Source_apply. 61 | f_equal. simpl. 62 | apply (@app_identity_x _ Cont_Applicative). 63 | 64 | - (* app_composition *) 65 | intros. 66 | unfold Source_apply. 67 | destruct u. destruct v. destruct w. 68 | f_equal. 69 | apply app_composition. 70 | 71 | - (* app_homomorphism *) 72 | intros. 73 | unfold Source_apply. 74 | f_equal. 75 | 76 | - (* app_interchange *) 77 | intros. 78 | unfold Source_apply. 79 | destruct u. 80 | f_equal. 81 | apply app_interchange. 82 | 83 | - (* app_fmap_unit *) 84 | intros. extensionality x. 85 | unfold Source_apply. 86 | destruct x. simpl. 87 | f_equal. 88 | unfold Cont_map. 89 | destruct c. 90 | f_equal. 91 | Defined. 92 | 93 | Definition getSource {M : Type -> Type} {R X} (x : Source M R X) 94 | : Cont (R -> EitherT R M R) X := 95 | match x with Source_ k => k end. 96 | 97 | Definition Source_join {M : Type -> Type} `{Monad M} 98 | {R X} : Source M R (Source M R X) -> Source M R X := 99 | Source_ M R X ∘ join ∘ fmap getSource ∘ getSource. 100 | 101 | #[export] 102 | Program Instance Source_Monad {M : Type -> Type} `{Monad M} {R} 103 | : Monad (Source M R) := 104 | { is_applicative := Source_Applicative 105 | ; join := fun _ => Source_join 106 | }. 107 | Obligation 1. (* monad_law_1 *) 108 | intros. extensionality x. simpl. 109 | unfold Source_join, Source_map, id, compose. 110 | destruct x. 111 | destruct c. simpl. 112 | unfold compose, flip. 113 | repeat f_equal. 114 | extensionality p. f_equal. 115 | extensionality q. f_equal. 116 | destruct q. 117 | destruct c. 118 | reflexivity. 119 | Qed. 120 | Obligation 2. (* monad_law_2 *) 121 | intros. extensionality x. simpl. 122 | unfold Source_join, Source_map, id, compose. 123 | destruct x. 124 | f_equal. simpl. 125 | pose proof (@fun_composition_x _ (@Cont_Functor (R -> EitherT R M R))). 126 | simpl in H0. 127 | rewrite H0. 128 | pose proof (@monad_law_2_x _ (@Cont_Monad (R -> EitherT R M R))). 129 | simpl in H1. 130 | unfold compose. simpl. 131 | apply H1. 132 | Qed. 133 | Obligation 3. (* monad_law_3 *) 134 | intros. extensionality x. simpl. 135 | unfold Source_join, id, compose. 136 | destruct x. 137 | f_equal. simpl. 138 | unfold compose. 139 | destruct c. 140 | f_equal. 141 | Qed. 142 | Obligation 4. (* monad_law_4 *) 143 | intros. extensionality x. simpl. 144 | unfold Source_join, Source_map, compose. 145 | destruct x. 146 | destruct c. 147 | f_equal. simpl. 148 | f_equal. 149 | extensionality p. 150 | extensionality q. 151 | unfold compose. 152 | f_equal. 153 | extensionality r. 154 | extensionality s. 155 | destruct r. 156 | destruct c. 157 | reflexivity. 158 | Admitted. 159 | 160 | Definition source {M : Type -> Type} `{Monad M} {R A} 161 | (await : R -> (R -> A -> EitherT R M R) -> EitherT R M R) 162 | : Source M R A := 163 | Source_ M R A (Cont_ (R -> EitherT R M R) A (flip await ∘ flip)). 164 | 165 | Theorem source_distributes 166 | : forall {M : Type -> Type} `{Monad M} {R A} 167 | (m : EitherT R M A) (f : A -> EitherT R M A), 168 | source (fun (r : R) (yield : R -> A -> EitherT R M R) => 169 | m >>= yield r) 170 | >>= (fun x : A => 171 | source (fun (r : R) (yield : R -> A -> EitherT R M R) => 172 | f x >>= yield r)) = 173 | source (fun (r : R) (yield : R -> A -> EitherT R M R) => 174 | m >>= f >>= yield r). 175 | Admitted. 176 | (* 177 | Proof. 178 | intros. 179 | unfold bind, flip. 180 | simpl join. 181 | simpl fmap. 182 | unfold source, flip, compose. 183 | unfold Source_join, compose. 184 | simpl join. simpl. 185 | unfold compose, flip. simpl. 186 | f_equal. f_equal. 187 | extensionality p. extensionality q. 188 | pose (@monad_law_4_x (EitherT R M) EitherT_Monad). 189 | simpl in e. rewrite <- e. clear e. 190 | pose (@monad_law_1_x (EitherT R M) EitherT_Monad). 191 | simpl in e. rewrite <- e. clear e. 192 | f_equal. 193 | pose (@fun_composition_x (EitherT R M) EitherT_Functor). 194 | simpl in e. repeat (rewrite e). clear e. 195 | f_equal. 196 | Qed. 197 | *) 198 | 199 | #[export] 200 | Instance Source_MonadTrans {M : Type -> Type} `{Monad M} {R} 201 | : @MonadTrans (fun N => Source N R) M _ Source_Monad := 202 | { lift := fun _ m => source (fun r yield => lift m >>= yield r) 203 | }. 204 | Proof. 205 | - (* trans_law_1 *) intros. 206 | unfold source. simpl pure. 207 | extensionality e. unfold compose at 1. 208 | f_equal. f_equal. 209 | unfold flip. unfold compose at 1. 210 | unfold bind. 211 | rewrite trans_law_1_x. 212 | pose proof app_fmap_compose_x. 213 | specialize (H0 (EitherT R M) is_applicative A (EitherT R M R)). 214 | simpl join. 215 | simpl pure. 216 | simpl pure in H0. 217 | extensionality p. extensionality q. 218 | rewrite <- H0. 219 | pose proof monad_law_3_x. 220 | specialize (H1 (EitherT R M) EitherT_Monad R (p e q)). 221 | simpl join in H1. 222 | simpl pure in H1. 223 | assumption. 224 | 225 | - (* trans_law_2 *) intros. 226 | pose (@trans_law_2 (EitherT R) M _ _ _ A). 227 | unfold compose. rewrite e. 228 | rewrite source_distributes. 229 | reflexivity. 230 | Defined. 231 | 232 | (* 233 | Require Export Category. 234 | 235 | (* Src is the category of simple-conduit Sources: 236 | 237 | Objects are sources 238 | Morphisms are the source homomorphisms (aka conduits) 239 | 240 | Identity is just simple identity 241 | Composition is just simple composition, since monadic folds 242 | are simply functions modulo type wrapping. 243 | 244 | Thus, the proof are extremely trivial and follow immediately from the 245 | definitions. 246 | 247 | Another way to say it is that since, by naturality, the image of a functor 248 | is always a sub-category in its codomain, and since Sources are functors, 249 | they must also then be categories. 250 | *) 251 | #[export] 252 | Instance Src {M : Type -> Type} `{Monad M} {R} 253 | : Category (sigT (Source M R)) 254 | (fun dom ran => projT1 dom → projT1 ran) := 255 | { id := fun _ x => id x 256 | ; compose := fun _ _ _ f g x => f (g x) 257 | }. 258 | Proof. 259 | (* The proofs of all of these follow trivially from their definitions. *) 260 | - (* right_identity *) crush. 261 | - (* left_identity *) crush. 262 | - (* comp_assoc *) crush. 263 | Defined. 264 | *) 265 | -------------------------------------------------------------------------------- /src/Haskell.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | Require Import Hask.Data.IntMap. 3 | Require Import Hask.Data.IntSet. 4 | Require Import Hask.Data.List. 5 | Require Import Hask.Data.NonEmpty. 6 | Require Import Hask.Data.Vector. 7 | Require Import Coq.Strings.String. 8 | 9 | Generalizable All Variables. 10 | Set Primitive Projections. 11 | Set Universe Polymorphism. 12 | Unset Transparent Obligations. 13 | Set Implicit Arguments. 14 | Unset Strict Implicit. 15 | Unset Printing Implicit Defensive. 16 | 17 | Extraction Language Haskell. 18 | 19 | Unset Extraction KeepSingleton. 20 | Set Extraction AutoInline. 21 | Set Extraction Optimize. 22 | Set Extraction AccessOpaque. 23 | 24 | (* Ssr *) 25 | 26 | Extract Inductive unit => "()" [ "()" ]. 27 | Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"]. 28 | Extract Inductive sumbool => "Prelude.Bool" ["Prelude.True" "Prelude.False"]. 29 | Extract Inductive sum => "Prelude.Either" [ "Prelude.Left" "Prelude.Right" ]. 30 | Extract Inductive list => "[]" ["[]" "(:)"]. 31 | Extract Inductive prod => "(,)" ["(,)"]. 32 | Extract Inductive sigT => "(,)" ["(,)"]. 33 | Extract Inductive option => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"]. 34 | Extract Inductive sumor => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"]. 35 | 36 | (* Extract Inductive ordinal => "Prelude.Int" [""]. *) 37 | 38 | (* Extract Inlined Constant addn => "(Prelude.+)". *) 39 | Extract Inlined Constant andb => "(Prelude.&&)". 40 | Extract Inlined Constant app => "(Prelude.++)". 41 | (* Extract Inlined Constant cat => "(Prelude.++)". *) 42 | (* Extract Inlined Constant eqb => "(Prelude.==)". *) 43 | (* Extract Inlined Constant eqn => "(Prelude.==)". *) 44 | (* Extract Inlined Constant filter => "Prelude.filter". *) 45 | (* Extract Inlined Constant foldl => "Data.List.foldl'". *) 46 | (* Extract Inlined Constant foldr => "Prelude.foldr". *) 47 | Extract Inlined Constant fst => "Prelude.fst". 48 | (* Extract Inlined Constant has => "Data.List.any". *) 49 | Extract Inlined Constant length => "Data.List.length". 50 | (* Extract Inlined Constant leq => "(Prelude.<=)". *) 51 | (* Extract Inlined Constant map => "Prelude.map". *) 52 | (* Extract Inlined Constant maxn => "Prelude.max". *) 53 | (* Extract Inlined Constant minn => "Prelude.min". *) 54 | Extract Inlined Constant minus => "(Prelude.-)". 55 | Extract Inlined Constant mult => "(Prelude.*)". 56 | Extract Inlined Constant negb => "Prelude.not". 57 | Extract Inlined Constant orb => "(Prelude.||)". 58 | Extract Inlined Constant plus => "(Prelude.+)". 59 | (* Extract Inlined Constant predn => "Prelude.pred". *) 60 | Extract Inlined Constant proj1_sig => "". 61 | Extract Inlined Constant projT1 => "Prelude.fst". 62 | (* Extract Inlined Constant size => "Data.List.length". *) 63 | Extract Inlined Constant snd => "Prelude.snd". 64 | (* Extract Inlined Constant subn => "(Prelude.-)". *) 65 | 66 | (* Extraction Implicit eq_rect [ x y ]. *) 67 | (* Extraction Implicit eq_rect_r [ x y ]. *) 68 | (* Extraction Implicit eq_rec [ x y ]. *) 69 | (* Extraction Implicit eq_rec_r [ x y ]. *) 70 | 71 | Extract Inlined Constant eq_rect => "". 72 | Extract Inlined Constant eq_rect_r => "". 73 | Extract Inlined Constant eq_rec => "". 74 | Extract Inlined Constant eq_rec_r => "". 75 | 76 | (* Extraction Implicit funcomp [ u ]. *) 77 | 78 | (* Extract Inlined Constant funcomp => "(Prelude..)". *) 79 | 80 | (* Extract Inductive simpl_fun => "(->)" [""]. *) 81 | 82 | (* Extract Inlined Constant fun_of_simpl => "(Prelude.$)". *) 83 | (* Extract Inlined Constant SimplRel => "". *) 84 | 85 | (* Extract Inlined Constant ord_max => "". *) 86 | 87 | (* Extraction Implicit nat_of_ord [ n ]. *) 88 | (* Extraction Implicit widen_ord [ n m ]. *) 89 | 90 | (* Extract Inlined Constant nat_of_ord => "Prelude.id". *) 91 | (* Extract Inlined Constant widen_ord => "Prelude.id". *) 92 | 93 | (* Extract Inlined Constant ssr_have => "(Prelude.flip (Prelude.$))". *) 94 | 95 | (* Prelude *) 96 | 97 | (** Danger! Using Int is efficient, but requires we know we won't exceed 98 | its bounds. *) 99 | Extract Inductive Datatypes.nat => "Prelude.Int" ["0" "(Prelude.succ)"] 100 | "(\fO fS n -> if n Prelude.<= 0 then fO () else fS (n Prelude.- 1))". 101 | 102 | Extract Inductive string => "Prelude.String" ["[]" "(:)"]. 103 | 104 | Extract Inductive comparison => 105 | "Prelude.Ordering" ["Prelude.LT" "Prelude.EQ" "Prelude.GT"]. 106 | 107 | Extract Inlined Constant Arith.Plus.tail_plus => "(Prelude.+)". 108 | 109 | (* Data.IntMap *) 110 | 111 | (* Extract Inductive IntMap => "Data.IntMap.IntMap" *) 112 | (* ["Data.IntMap.fromList"] "(\fS m -> fS m)". *) 113 | 114 | (* Extract Inlined Constant IntMap_mergeWithKey' => *) 115 | (* "Hask.Utils.intMap_mergeWithKey'". *) 116 | 117 | (* Extract Inlined Constant IntMap_lookup => "Data.IntMap.lookup". *) 118 | (* Extract Inlined Constant IntMap_insert => "Data.IntMap.insert". *) 119 | (* Extract Inlined Constant IntMap_alter => "Data.IntMap.alter". *) 120 | (* Extract Inlined Constant IntMap_map => "Data.IntMap.map". *) 121 | (* Extract Inlined Constant IntMap_foldl => "Data.IntMap.foldl". *) 122 | (* Extract Inlined Constant IntMap_foldlWithKey => "Data.IntMap.foldlWithKey". *) 123 | (* Extract Inlined Constant IntMap_mergeWithKey => "Data.IntMap.mergeWithKey". *) 124 | (* Extract Inlined Constant IntMap_toList => "Data.IntMap.toList". *) 125 | 126 | (* Data.IntSet *) 127 | 128 | (* Extract Inductive IntSet => "Data.IntSet.IntSet" *) 129 | (* ["Data.IntSet.fromList"] "(\fS m -> fS m)". *) 130 | 131 | (* Extract Inlined Constant IntSet_member => "Data.IntSet.member". *) 132 | (* Extract Inlined Constant IntSet_insert => "Data.IntSet.insert". *) 133 | (* Extract Inlined Constant IntSet_delete => "Data.IntSet.delete". *) 134 | (* Extract Inlined Constant IntSet_union => "Data.IntSet.union". *) 135 | (* Extract Inlined Constant IntSet_difference => "Data.IntSet.difference". *) 136 | (* Extract Inlined Constant IntSet_foldl => "Data.IntSet.foldl'". *) 137 | 138 | (* Data.List *) 139 | 140 | (* Extract Inlined Constant safe_hd => "Prelude.head". *) 141 | (* Extract Inlined Constant sumlist => "Data.List.sum". *) 142 | (* Extract Inlined Constant lebf => "Data.Ord.comparing". *) 143 | (* Extract Inlined Constant insert => "Data.List.insertBy". *) 144 | 145 | (* Extract Inlined Constant List.destruct_list => "Hask.Utils.uncons". *) 146 | (* Extract Inlined Constant list_membership => "Prelude.const". *) 147 | 148 | (* Data.NonEmpty *) 149 | 150 | Extract Inductive NonEmpty => "[]" ["(:[])" "(:)"] 151 | "(\ns nc l -> case l of [x] -> ns x; (x:xs) -> nc x xs)". 152 | 153 | (* Extract Inlined Constant NE_length => "Prelude.length". *) 154 | (* Extract Inlined Constant NE_to_list => "Prelude.id". *) 155 | (* Extract Inlined Constant NE_head => "Prelude.head". *) 156 | (* Extract Inlined Constant NE_last => "Prelude.last". *) 157 | (* Extract Inlined Constant NE_map => "Prelude.map". *) 158 | (* Extract Inlined Constant NE_foldl => "Data.List.foldl'". *) 159 | 160 | (* Data.Vector *) 161 | 162 | (* Extract Constant Vec "a" => "[]". *) 163 | (* Extraction Inline Vec. *) 164 | 165 | (* Extract Inlined Constant vnil => "[]". *) 166 | (* Extract Inlined Constant vsing => "[]". *) 167 | (* Extract Inlined Constant vcons => "(:)". *) 168 | (* Extract Inlined Constant vshiftin => "Hask.Utils.vshiftin". *) 169 | (* Extract Inlined Constant vreplace => "Hask.Utils.vreplace". *) 170 | (* Extract Inlined Constant vec_rect => "Hask.Utils.vec_rect". *) 171 | (* Extract Inlined Constant vconst => "Data.List.replicate". *) 172 | (* Extract Inlined Constant vfoldl => "Hask.Utils.vfoldl'". *) 173 | (* Extract Inlined Constant vapp => "Prelude.(++)". *) 174 | (* Extract Inlined Constant vmap => "Hask.Utils.vmap". *) 175 | (* Extract Inlined Constant vnth => "Hask.Utils.vnth". *) 176 | (* Extract Inlined Constant vec_to_seq => "Hask.Utils.vec_id". *) 177 | (* Extract Inlined Constant seq_to_vec => "Hask.Utils.vec_id". *) 178 | 179 | (* Extract Inlined Constant vfoldl_with_index *) 180 | (* => "(Hask.Utils.vfoldl'_with_index)". *) 181 | (* Extract Inlined Constant vmap_with_index *) 182 | (* => "(Hask.Utils.vmap_with_index)". *) 183 | 184 | Extraction Blacklist String List Vector Prelude. 185 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/FiatState.v: -------------------------------------------------------------------------------- 1 | (* Require Import Hask.Prelude. *) 2 | Require Import Hask.Ltac. 3 | Require Import Hask.Control.Monad. 4 | (* Require Import Hask.Control.Monad.Trans.Class. *) 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Unset Printing Implicit Defensive. 13 | 14 | (****************************************************************************** 15 | * The StateT Monad transformer 16 | *) 17 | 18 | Definition StateT (s : Type) (m : Type -> Type) (a : Type):= 19 | s -> m (s * a)%type. 20 | 21 | Definition getT `{Applicative m} {s : Type} : StateT s m s := 22 | fun i => pure (i, i). 23 | Definition getsT `{Applicative m} {s a : Type} f : StateT s m a := 24 | fun s => pure (s, f s). 25 | Definition putT `{Applicative m} {s : Type} x : StateT s m unit := 26 | fun _ => pure (x, tt). 27 | 28 | Definition modifyT `{Applicative m} {s : Type} (f : s -> s) : StateT s m unit := 29 | fun i => pure (f i, tt). 30 | 31 | Definition StateT_ap `{Monad m} {s : Type} {a b : Type} 32 | (mf : StateT s m (a -> b)) (mx : StateT s m a) : StateT s m b := fun st => 33 | p <- mf st; 34 | match p with 35 | (st', f) => 36 | p <- mx st'; 37 | match p with 38 | (st'', x) => 39 | pure (st'', f x) 40 | end 41 | end. 42 | 43 | Definition StateT_join `{Monad m} {s a : Type} (x : StateT s m (StateT s m a)) : 44 | StateT s m a := fun s => 45 | p <- x s; 46 | match p with 47 | (s', x') => x' s' 48 | end. 49 | 50 | (* 51 | Require Import FunctionalExtensionality. 52 | 53 | Module StateTLaws. 54 | 55 | Include MonadLaws. 56 | 57 | Lemma second_id : forall a z, second (a:=a) (b:=a) (z:=z) id = id. 58 | Proof. 59 | unfold second. 60 | intros a z. 61 | extensionality x. 62 | destruct x; auto. 63 | Qed. 64 | 65 | #[export] 66 | Program Instance StateT_FunctorLaws {s} `{FunctorLaws m} : 67 | FunctorLaws (StateT s m). 68 | Next Obligation. Admitted. 69 | Next Obligation. Admitted. 70 | (* Obligation 1. *) 71 | (* move=> x. *) 72 | (* extensionality st. *) 73 | (* rewrite first_id. *) 74 | (* replace (fun z : a * s => (z.1, z.2)) with (@id (a * s)%type); last first. *) 75 | (* by extensionality z; case z. *) 76 | (* by rewrite fmap_id. *) 77 | (* Qed. *) 78 | (* Obligation 2. *) 79 | (* rewrite /funcomp => x. *) 80 | (* extensionality st. *) 81 | (* rewrite fmap_comp_x /first. *) 82 | (* f_equal. *) 83 | (* extensionality y. *) 84 | (* by case: y. *) 85 | (* Qed. *) 86 | 87 | #[export] 88 | Program Instance StateT_Applicative `{MonadLaws m} {s : Type} : 89 | ApplicativeLaws (StateT s m). 90 | Next Obligation. Admitted. 91 | Next Obligation. Admitted. 92 | Next Obligation. Admitted. 93 | Next Obligation. Admitted. 94 | Next Obligation. Admitted. 95 | (* Obligation 1. *) 96 | (* move=> x. *) 97 | (* extensionality st. *) 98 | (* rewrite /StateT_ap fmap_pure_x join_pure_x. *) 99 | (* set f := (X in fmap X). *) 100 | (* replace f with (@id (a * s)%type); last first. *) 101 | (* extensionality z. *) 102 | (* by case: z. *) 103 | (* by rewrite fmap_id. *) 104 | (* Qed. *) 105 | (* Obligation 2. *) 106 | (* extensionality st. *) 107 | (* rewrite /StateT_ap. *) 108 | (* set f := (X in join (fmap X _)). *) 109 | (* set g := (X in fmap f (join (fmap X _))). *) 110 | (* set h := (X in fmap g (join (fmap X _))). *) 111 | (* set i := (X in join (fmap X (u st))). *) 112 | (* rewrite -!join_fmap_fmap_x !fmap_comp_x fmap_pure_x *) 113 | (* join_pure_x -join_fmap_join_x. *) 114 | (* f_equal; rewrite !fmap_comp_x; f_equal. *) 115 | (* extensionality u'. *) 116 | (* case: u' => f' st'. *) 117 | (* rewrite /i -join_fmap_fmap_x. *) 118 | (* f_equal; rewrite !fmap_comp_x; f_equal. *) 119 | (* extensionality v'. *) 120 | (* case: v' => f'' st''. *) 121 | (* rewrite /f /first !fmap_comp_x; f_equal. *) 122 | (* extensionality w'. *) 123 | (* case: w' => f''' st'''. *) 124 | (* by rewrite /funcomp. *) 125 | (* Qed. *) 126 | (* Obligation 3. *) 127 | (* extensionality st. *) 128 | (* by rewrite /StateT_ap fmap_pure_x join_pure_x fmap_pure_x. *) 129 | (* Qed. *) 130 | (* Obligation 4. *) 131 | (* extensionality st. *) 132 | (* rewrite /StateT_ap fmap_pure_x. *) 133 | (* set f := (X in join (fmap X _)). *) 134 | (* set g := (X in _ = join (pure (fmap X _))). *) 135 | (* rewrite join_pure_x. *) 136 | (* recomp; f_equal. *) 137 | (* extensionality z. *) 138 | (* have H1 : pure \o g = f. *) 139 | (* rewrite /f /g /funcomp. *) 140 | (* extensionality x. *) 141 | (* case: x => f' st'. *) 142 | (* by rewrite fmap_pure_x. *) 143 | (* by rewrite -H1 /funcomp -fmap_comp_x join_fmap_pure_x. *) 144 | (* Qed. *) 145 | (* Obligation 5. *) 146 | (* move=> x. *) 147 | (* extensionality st. *) 148 | (* rewrite /StateT_ap fmap_pure_x join_pure_x. *) 149 | (* f_equal. *) 150 | (* Qed. *) 151 | 152 | #[export] 153 | Program Instance StateT_Monad `{MonadLaws m} {s : Type} : 154 | MonadLaws (StateT s m). 155 | Next Obligation. Admitted. 156 | Next Obligation. Admitted. 157 | Next Obligation. Admitted. 158 | Next Obligation. Admitted. 159 | (* Obligation 1. *) 160 | (* move=> f. *) 161 | (* extensionality st. *) 162 | (* rewrite /StateT_join /= -!ap_fmap -ap_comp !ap_homo *) 163 | (* !ap_fmap -join_fmap_fmap_x -join_fmap_join_x fmap_comp_x. *) 164 | (* f_equal. *) 165 | (* rewrite fmap_comp_x. *) 166 | (* f_equal. *) 167 | (* extensionality y. *) 168 | (* by case: y => f' st'. *) 169 | (* Qed. *) 170 | (* Obligation 2. *) 171 | (* move=> f. *) 172 | (* extensionality st. *) 173 | (* rewrite /StateT_join /= fmap_comp_x /curry /apply /first. *) 174 | (* set h := (X in fmap X _). *) 175 | (* replace h with (@pure m _ (a * s)%type); last first. *) 176 | (* extensionality z. *) 177 | (* by case: z. *) 178 | (* by rewrite join_fmap_pure_x. *) 179 | (* Qed. *) 180 | (* Obligation 3. *) 181 | (* move=> f. *) 182 | (* extensionality st. *) 183 | (* by rewrite /StateT_join /= fmap_pure_x join_pure_x. *) 184 | (* Qed. *) 185 | (* Obligation 4. *) 186 | (* move=> x. *) 187 | (* extensionality st. *) 188 | (* rewrite /StateT_join /= -join_fmap_fmap_x. *) 189 | (* f_equal; rewrite !fmap_comp_x; f_equal. *) 190 | (* extensionality y. *) 191 | (* by case: y. *) 192 | (* Qed. *) 193 | 194 | End StateTLaws. 195 | *) 196 | 197 | (* #[export] *) 198 | (* Instance Tuple_Functor {S} : Functor (fun a => (S * a)%type) | 9 := { *) 199 | (* fmap := fun _ _ f p => (fst p, f (snd p)) *) 200 | (* }. *) 201 | 202 | #[export] 203 | Instance StateT_Functor `{Functor m} {S} : Functor (StateT S m) := { 204 | fmap := fun _ _ f x => fun s => 205 | x s <&> fun p => 206 | match p with 207 | (s', a) => (s', f a) 208 | end 209 | }. 210 | 211 | #[export] 212 | Instance StateT_Applicative `{Monad m} {S} : Applicative (StateT S m) := { 213 | pure := fun _ x => fun s => pure (s, x); 214 | ap := @StateT_ap _ _ _ 215 | }. 216 | 217 | #[export] 218 | Instance StateT_Monad `{Monad m} {S} : Monad (StateT S m) := { 219 | join := @StateT_join _ _ _ 220 | }. 221 | 222 | Require Import FunctionalExtensionality. 223 | 224 | Module StateTLaws. 225 | 226 | Import MonadLaws. 227 | 228 | (* #[export] *) 229 | (* Program Instance Tuple_FunctorLaws {S} : FunctorLaws (fun a => (S * a)%type). *) 230 | (* Obligation 1. *) 231 | (* extensionality p. *) 232 | (* destruct p; reflexivity. *) 233 | (* Qed. *) 234 | 235 | (* #[export] *) 236 | (* Program Instance StateT_FunctorLaws `{FunctorLaws m} {S} : *) 237 | (* FunctorLaws (StateT S m) := *) 238 | (* @Compose_FunctorLaws _ Impl_Functor Impl_FunctorLaws *) 239 | (* _ _ (@Compose_FunctorLaws m _ _ _ _ (@Tuple_FunctorLaws S)). *) 240 | 241 | (* 242 | #[export] 243 | Program Instance StateT_ApplicativeLaws `{MonadLaws m} {S} : 244 | ApplicativeLaws (StateT S m). 245 | Obligation 1. 246 | extensionality x. 247 | extensionality st. 248 | unfold StateT_ap, StateT_join, id; simpl. 249 | rewrite fmap_pure_x, join_pure_x. 250 | unfold second; simpl. 251 | setoid_rewrite fst_snd. 252 | setoid_rewrite <- surjective_pairing. 253 | rewrite fmap_id. 254 | reflexivity. 255 | Qed. 256 | Obligation 2. 257 | Abort. 258 | 259 | #[export] 260 | Program Instance StateT_MonadLaws `{MonadLaws m} {S} : 261 | MonadLaws (StateT S m). 262 | *) 263 | 264 | End StateTLaws. 265 | 266 | (* 267 | Require Import Hask.Control.Monad.State. 268 | 269 | Definition liftStateT `{Monad m} `(x : State s a) : StateT s m a := 270 | st <- getT ; 271 | let (a, st') := x st in 272 | putT st' ;; 273 | pure a. 274 | *) 275 | -------------------------------------------------------------------------------- /src/Data/NonEmpty.v: -------------------------------------------------------------------------------- 1 | Require Import Hask.Prelude. 2 | 3 | Require Import Coq.Sorting.Sorted. 4 | Require Import Coq.Classes.RelationClasses. 5 | 6 | Generalizable All Variables. 7 | Set Primitive Projections. 8 | Set Universe Polymorphism. 9 | Unset Transparent Obligations. 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Unset Printing Implicit Defensive. 13 | 14 | (** ** NonEmpty lists *) 15 | 16 | Inductive NonEmpty (a : Type) : Type := 17 | | NE_Sing : a -> NonEmpty a 18 | | NE_Cons : a -> NonEmpty a -> NonEmpty a. 19 | 20 | Arguments NE_Sing [_] _. 21 | Arguments NE_Cons [_] _ _. 22 | 23 | (* 24 | Notation "[ ::: x1 ]" := (NE_Sing x1) 25 | (at level 0, format "[ ::: x1 ]") : seq_scope. 26 | 27 | Fixpoint NE_from_list {a} (x : a) (xs : seq a) : NonEmpty a := 28 | match xs with 29 | | nil => NE_Sing x 30 | | cons y ys => NE_Cons x (NE_from_list y ys) 31 | end. 32 | 33 | Notation "[ ::: x & s ]" := (NE_from_list x s) 34 | (at level 0, only parsing) : seq_scope. 35 | 36 | Fixpoint NE_length {a} (ne : NonEmpty a) : nat := 37 | match ne with 38 | | NE_Sing x => 1 39 | | NE_Cons x xs => 1 + NE_length xs 40 | end. 41 | 42 | Fixpoint NE_to_list {a} (ne : NonEmpty a) : list a := 43 | match ne with 44 | | NE_Sing x => cons x nil 45 | | NE_Cons x xs => cons x (NE_to_list xs) 46 | end. 47 | 48 | Coercion NE_to_list : NonEmpty >-> list. 49 | 50 | Lemma NE_to_list_from_list {a} : forall (x : a) xs, 51 | NE_to_list (NE_from_list x xs) = x :: xs. 52 | Proof. 53 | move=> x xs. 54 | elim: xs => //= [y ys IHys] in x *. 55 | by rewrite IHys. 56 | Defined. 57 | 58 | Definition NE_head {a} (ne : NonEmpty a) : a := 59 | match ne with 60 | | NE_Sing x => x 61 | | NE_Cons x _ => x 62 | end. 63 | 64 | Fixpoint NE_last {a} (ne : NonEmpty a) : a := 65 | match ne with 66 | | NE_Sing x => x 67 | | NE_Cons x xs => NE_last xs 68 | end. 69 | 70 | Fixpoint NE_belast a (ne : NonEmpty a) : seq a := 71 | match ne with 72 | | NE_Sing x => [::] 73 | | NE_Cons x xs => x :: NE_belast xs 74 | end. 75 | 76 | Fixpoint NE_rcons {a} (ne : NonEmpty a) z := 77 | match ne with 78 | | NE_Sing x => NE_Cons x (NE_Sing z) 79 | | NE_Cons x xs => NE_Cons x (NE_rcons xs z) 80 | end. 81 | 82 | CoInductive NE_last_spec {a} : NonEmpty a -> Type := 83 | | NE_LastSing x : NE_last_spec [::: x] 84 | | NE_LastRcons s x : NE_last_spec (NE_rcons s x). 85 | 86 | Lemma NE_lastI a (x : a) s : 87 | NE_Cons x s = NE_rcons (NE_from_list x (NE_belast s)) (NE_last s). 88 | Proof. 89 | elim: s => //= [y ys IHys] in x *. 90 | by rewrite IHys. 91 | Qed. 92 | 93 | Lemma NE_lastP a s : @NE_last_spec a s. 94 | Proof. case: s => [|x s]; [left | rewrite NE_lastI; right]. Qed. 95 | 96 | Lemma NE_Cons_spec a (x : a) xs : NE_Cons x xs = NE_from_list x (NE_to_list xs). 97 | Proof. 98 | by elim: xs => //= [y ys IHys] in x *; congr (NE_Cons _ _). 99 | Qed. 100 | 101 | Lemma ne_list : forall a (x : a) xs ns, 102 | NE_to_list ns = x :: xs -> ns = NE_from_list x xs. 103 | Proof. 104 | move=> a x xs ns H. 105 | replace ns with (NE_from_list x xs); last first. 106 | case: ns => [r|r rs] in H *. 107 | by inversion H. 108 | by inversion H; rewrite NE_Cons_spec. 109 | by []. 110 | Defined. 111 | 112 | Lemma NE_head_from_list a (x : a) xs : 113 | NE_head (NE_from_list x xs) = head x (x :: xs). 114 | Proof. by elim E: xs => // [*] in x *. Qed. 115 | 116 | Lemma NE_last_from_list a (x : a) xs : NE_last (NE_from_list x xs) = last x xs. 117 | Proof. by elim: xs => //= [*] in x *. Qed. 118 | 119 | Fixpoint NE_map {a b : Type} (f : a -> b) (ne : NonEmpty a) : NonEmpty b := 120 | match ne with 121 | | NE_Sing x => NE_Sing (f x) 122 | | NE_Cons x xs => NE_Cons (f x) (NE_map f xs) 123 | end. 124 | 125 | Definition NE_foldl {a b : Type} (f : a -> b -> a) (z : a) 126 | (ne : NonEmpty b) : a := foldl f z ne. 127 | Arguments NE_foldl {a b} f z ne /. 128 | 129 | Definition NE_foldr {a b : Type} (f : b -> a -> a) (z : a) 130 | (ne : NonEmpty b) : a := foldr f z ne. 131 | Arguments NE_foldr {a b} f z ne /. 132 | 133 | Fixpoint NE_mapAccumL {A X Y : Type} (f : A -> X -> (A * Y)) 134 | (s : A) (v : NonEmpty X) : A * NonEmpty Y := 135 | match v with 136 | | NE_Sing x => 137 | let: (s', y) := f s x in 138 | (s', NE_Sing y) 139 | | NE_Cons x xs => 140 | let: (s', y) := f s x in 141 | let: (s'', ys) := NE_mapAccumL f s' xs in 142 | (s'', NE_Cons y ys) 143 | end. 144 | 145 | Fixpoint NE_append {a : Type} (l1 l2 : NonEmpty a) : NonEmpty a := 146 | match l1 with 147 | | NE_Sing x => NE_Cons x l2 148 | | NE_Cons x xs => NE_Cons x (NE_append xs l2) 149 | end. 150 | 151 | Lemma NE_head_append_spec : forall {a} {xs ys : NonEmpty a}, 152 | NE_head (NE_append xs ys) = NE_head xs. 153 | Proof. induction xs; auto. Qed. 154 | 155 | Lemma NE_last_append_spec : forall {a} {xs ys : NonEmpty a}, 156 | NE_last (NE_append xs ys) = NE_last ys. 157 | Proof. induction xs; auto. Qed. 158 | 159 | Lemma NE_append_from_list : forall {a} (x : a) xs y ys, 160 | NE_from_list x (xs ++ y :: ys) = 161 | NE_append (NE_from_list x xs) (NE_from_list y ys). 162 | Proof. 163 | move=> a x xs y ys. 164 | elim: xs => //= [z zs IHzs] in x y ys *. 165 | f_equal. 166 | exact: IHzs. 167 | Defined. 168 | 169 | (* 170 | Definition NE_last_ind P a : 171 | (forall (x : a), P a [::: x]) 172 | -> (forall s x, P a s -> P a (NE_rcons s x)) 173 | -> forall s, P a s. 174 | Proof. 175 | move=> Hsing Hlast s. 176 | elim: s => [x|x s2 IHs2]. 177 | exact: Hsing. 178 | replace (NE_Cons x s2) with (NE_append [::: x] s2); last by []. 179 | set s := [::: x]. 180 | elim: s2 => [x2|x2 s3 IHs3] in IHs2 *. 181 | replace (NE_append s [::: x2]) 182 | with (NE_rcons s x2); last by []. 183 | exact: (Hlast s x2 (Hsing _)). 184 | replace (NE_append s (NE_Cons x2 s3)) 185 | with (NE_append (NE_rcons [::: x] x2) s3); last by []. 186 | *) 187 | 188 | Section Sorted. 189 | 190 | Variable A : Set. 191 | Variable R : A -> A -> Prop. 192 | Context `{H : Transitive A R}. 193 | 194 | Inductive NE_Forall (P : A -> Prop) : NonEmpty A -> Prop := 195 | | NE_Forall_sing : forall x, P x -> NE_Forall P (NE_Sing x) 196 | | NE_Forall_cons : forall x l, P x -> NE_Forall P l 197 | -> NE_Forall P (NE_Cons x l). 198 | 199 | #[export] Hint Constructors NE_Forall : core. 200 | 201 | Definition NE_all_true (f : A -> bool) := NE_Forall (fun x => f x = true). 202 | Definition NE_all_false (f : A -> bool) := NE_Forall (fun x => f x = false). 203 | 204 | Lemma NE_Forall_head : forall P (xs : NonEmpty A), 205 | NE_Forall P xs -> P (NE_head xs). 206 | Proof. induction xs; intros; inversion H0; assumption. Qed. 207 | 208 | Lemma NE_Forall_last : forall P (xs : NonEmpty A), 209 | NE_Forall P xs -> P (NE_last xs). 210 | Proof. 211 | intros. induction xs; simpl in *. 212 | inversion H0. assumption. 213 | apply IHxs. inversion H0. assumption. 214 | Qed. 215 | 216 | Section Membership. 217 | 218 | Fixpoint NE_member (z : A) (ne : NonEmpty A) : Prop := 219 | match ne with 220 | | NE_Sing x => x = z 221 | | NE_Cons x xs => (x = z) \/ NE_member z xs 222 | end. 223 | 224 | Lemma NE_Forall_member_spec (z : A) (ne : NonEmpty A) : 225 | forall f, NE_Forall f ne -> NE_member z ne -> f z. 226 | Proof. 227 | induction ne; simpl; intros. 228 | inversion H0. subst. assumption. 229 | inversion H1. 230 | inversion H0. subst. assumption. 231 | apply IHne. 232 | inversion H0. assumption. 233 | assumption. 234 | Qed. 235 | 236 | End Membership. 237 | 238 | Inductive NE_StronglySorted : NonEmpty A -> Prop := 239 | | NE_SSorted_sing a : NE_StronglySorted (NE_Sing a) 240 | | NE_SSorted_cons a l : NE_StronglySorted l -> NE_Forall (R a) l 241 | -> NE_StronglySorted (NE_Cons a l). 242 | 243 | Lemma NE_StronglySorted_to_list : forall xs, 244 | NE_StronglySorted xs -> StronglySorted R (NE_to_list xs). 245 | Proof. 246 | elim=> [x|x xs IHxs] /=. 247 | by constructor; constructor. 248 | move=> Hsort. 249 | constructor. 250 | apply: IHxs. 251 | by inversion Hsort. 252 | case: xs => [y|y ys] in IHxs Hsort *. 253 | constructor. 254 | inversion Hsort; subst. 255 | by inversion H3. 256 | by constructor. 257 | constructor. 258 | inversion Hsort; subst. 259 | by inversion H3. 260 | inversion Hsort; subst. 261 | specialize (IHxs H2). 262 | inversion IHxs. 263 | rewrite -/NE_to_list. 264 | inversion H3; subst. 265 | have: forall a, R y a -> R x a. 266 | move=> a Ha. 267 | exact: transitivity H8 Ha. 268 | move/List.Forall_impl. 269 | exact. 270 | Qed. 271 | 272 | End Sorted. 273 | 274 | Arguments NE_all_true [A] f _. 275 | Arguments NE_all_false [A] f _. 276 | 277 | Module NonEmptyNotations. 278 | 279 | Notation " [ x ] " := (NE_Sing x) : list_scope. 280 | Notation " [ x ; y ] " := (NE_Cons x (NE_Sing y)) : list_scope. 281 | Notation " [ x ; y ; z ] " := (NE_Cons x (NE_Cons y (NE_Sing z))) : list_scope. 282 | Notation " [ x ; y ; z ; w ] " := 283 | (NE_Cons x (NE_Cons y (NE_Cons z (NE_Sing w)))) : list_scope. 284 | Notation " [ x ; y ; z ; w ; v ] " := 285 | (NE_Cons x (NE_Cons y (NE_Cons z (NE_Cons w (NE_Sing v))))) : list_scope. 286 | 287 | Infix "++" := NE_append. 288 | 289 | End NonEmptyNotations. 290 | *) 291 | --------------------------------------------------------------------------------