-
Notifications
You must be signed in to change notification settings - Fork 11
/
monad_model.v
2552 lines (2236 loc) · 90.5 KB
/
monad_model.v
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
Require Import JMeq.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import finmap.
From mathcomp Require boolp.
From mathcomp Require Import classical_sets.
From infotheo Require convex classical_sets_ext.
Require Import preamble.
From HB Require Import structures.
Require Import hierarchy monad_lib fail_lib state_lib trace_lib.
Require Import monad_transformer.
(******************************************************************************)
(* Models for various monads *)
(* *)
(* Sample models for monads in hierarchy.v (see also other *_model.v files). *)
(* As for naming, we tend to use the identifier acto for the actions on *)
(* objects and actm for the actions on morphisms. *)
(* *)
(* Instances of monads (Modules): *)
(* IdentityMonad == identity monad idfun *)
(* ListMonad == list monad seq *)
(* SetMonad == set monads using classical_sets *)
(* ExceptMonad == exception monad E + A *)
(* option_monad == alias for ExceptMonad.acto unit *)
(* OutputMonad == output monad X * seq L *)
(* EnvironmentMonad == environment monad E -> A *)
(* StateMonad == state monad S -> A * S *)
(* ContMonad == continuation monad (A -> r) -> r *)
(* *)
(* Sigma-operations (with algebraicity proofs): *)
(* empty_op == empty operation *)
(* append_op == append operation *)
(* flush_op == flush operation *)
(* output_op == output operation *)
(* ask_op == ask operation *)
(* local_op == local operation *)
(* throw_op == throw operation *)
(* handle_op == handle operation *)
(* get_op == get operation *)
(* put_op == put operation *)
(* abort_op == abort operation *)
(* acallcc_op == algebraic callcc operation *)
(* *)
(* Models of interfaces: *)
(* Module Fail == failMonad for option_monad, ListMonad.acto, set *)
(* Module Except == exceptMonad for ExcetMonad.acto unit *)
(* Module State == stateMonad for StateMonad.acto S *)
(* Module Alt == altMonad for ListMonad.acto, set *)
(* Module AltCI == altCIMonad for ListMonad.acto, set *)
(* Module Nondet == nondetMonad for ListMonad.acto, set *)
(* Module ModelStateTrace == stateTraceMonad for StateMonad.acto (S * seq T) *)
(* Module ModelCont == contMonad for ContMonad.acto r *)
(* Module ModelShiftReset == shiftResetMonad for ContMonad.acto r *)
(* Module ModelReify == reifyModel for StateMonad.acto (S * seq T) *)
(* Module ModelStateTraceReify == stateTraceReify monad for *)
(* StateMonad.acto (S * seq T) *)
(* Module ModelBacktrackableState == from the ground up using fsets, i.e., *)
(* redefinition of monads state-fail-alt- *)
(* nondet-failR0-preplusmonad-nondetstate *)
(* for S -> {fset (A * S)} *)
(* Module ModelArray == array monad *)
(* Module ModelPlusArray == plus array monad *)
(* Module ModelMonadStateRun == stateRunMonad for MS *)
(* Module ModelMonadExceptStateRun == exceptStateRunMonad *)
(* *)
(* Module ModelTypedStoreRun == model for typed store (and crun) *)
(* *)
(* Module TrivialPlusArray == another, degenerate model of MonadPlusArray *)
(* *)
(* references: *)
(* - Wadler, P. Monads and composable continuations. LISP and Symbolic *)
(* Computation 7, 39–55 (1994) *)
(******************************************************************************)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Local Open Scope monae_scope.
(* TODO *)
Section PR_to_fset.
Local Open Scope fset_scope.
Variables (K V : choiceType) (f : K -> V).
Lemma imfset_set1 x : f @` [fset x] = [fset f x].
Proof.
apply/fsetP => y.
by apply/imfsetP/fset1P=> [[x' /fset1P-> //]| ->]; exists x; rewrite ?fset11.
Qed.
Variables (T : choiceType) (I : eqType) (r : seq I).
(* In order to avoid "&& true" popping up everywhere, *)
(* we prepare a specialized version of bigfcupP *)
Lemma bigfcupP' x (F : I -> {fset T}) :
reflect (exists2 i : I, (i \in r) & x \in F i)
(x \in \bigcup_(i <- r | true) F i).
Proof.
apply: (iffP idP) => [|[i ri]]; last first.
by apply: fsubsetP x; rewrite bigfcup_sup.
rewrite big_seq_cond; elim/big_rec: _ => [|i _ /andP[ri Pi] _ /fsetUP[|//]].
by rewrite in_fset0.
by exists i; rewrite ?ri.
Qed.
End PR_to_fset.
(* TODO: move *)
Section assoc.
Variables (I : eqType) (S : UU0).
Definition insert i s (a : I -> S) j := if i == j then s else a j.
Lemma insert_insert i s' s a :
insert i s' (insert i s a) = insert i s' a.
Proof.
by apply boolp.funext => j; rewrite /insert; case: ifPn => // /negbTE ->.
Qed.
Lemma insert_same i a s : insert i s a i = s.
Proof. by rewrite /insert eqxx. Qed.
Lemma insert_same2 i a : insert i (a i) a = a.
Proof.
by apply boolp.funext => j; rewrite /insert; case: ifPn => // /eqP ->.
Qed.
Lemma insertC j i v u a : i != j ->
insert j v (insert i u a) = insert i u (insert j v a).
Proof.
move=> h; apply boolp.funext => k; rewrite /insert; case: ifPn => // /eqP <-{k}.
by rewrite (negbTE h).
Qed.
Lemma insertC2 j i v a : insert j v (insert i v a) = insert i v (insert j v a).
Proof.
apply boolp.funext => k; rewrite /insert; case: ifPn => // /eqP <-{k}.
by rewrite if_same.
Qed.
End assoc.
Module IdentityMonad.
Section identitymonad.
Let bind := fun A B (a : A) (f : A -> B) => f a.
Let left_neutral : BindLaws.left_neutral bind (NId idfun).
Proof. by []. Qed.
Let right_neutral : BindLaws.right_neutral bind (NId idfun).
Proof. by []. Qed.
Let associative : BindLaws.associative bind. Proof. by []. Qed.
Let acto := (@idfun UU0).
HB.instance Definition _ := isMonad_ret_bind.Build
acto left_neutral right_neutral associative.
End identitymonad.
End IdentityMonad.
HB.export IdentityMonad.
Module ListMonad.
Section listmonad.
Definition acto := fun A : UU0 => seq A.
Local Notation M := acto.
Let ret : idfun ~~> M := fun (A : UU0) x => (@cons A) x [::].
Let bind := fun A B (m : M A) (f : A -> M B) => flatten (map f m).
Let left_neutral : BindLaws.left_neutral bind ret.
Proof. by move=> A B m f; rewrite /bind /ret /= cats0. Qed.
Let right_neutral : BindLaws.right_neutral bind ret.
Proof. by move=> A m; rewrite /bind flatten_seq1. Qed.
Let associative : BindLaws.associative bind.
Proof.
move=> A B C; elim => // h t; rewrite /bind => ih f g.
by rewrite /= map_cat flatten_cat /= ih.
Qed.
HB.instance Definition _ :=
isMonad_ret_bind.Build M left_neutral right_neutral associative.
End listmonad.
End ListMonad.
HB.export ListMonad.
Lemma list_bindE (A B : UU0) (M := ListMonad.acto) (m : M A) (f : A -> M B) :
m >>= f = flatten (map f m).
Proof. by []. Qed.
Module SetMonad.
Section setmonad.
Local Open Scope classical_set_scope.
Definition acto := set.
Local Notation M := acto.
Let ret : idfun ~~> M := @set1.
Let bind := fun A B => @bigcup B A.
Let left_neutral : BindLaws.left_neutral bind ret.
Proof. move=> ? ? ? ?; exact: bigcup_set1. Qed.
Let right_neutral : BindLaws.right_neutral bind ret.
Proof.
by move=> ? ?; rewrite /bind bigcup_imset1 image_id.
Qed.
Let associative : BindLaws.associative bind.
Proof. move=> ? ? ? ? ? ?; exact: bigcup_bigcup. Qed.
HB.instance Definition _ :=
isMonad_ret_bind.Build set left_neutral right_neutral associative.
End setmonad.
End SetMonad.
HB.export SetMonad.
Lemma set_bindE (A B : UU0) (M := [the monad of set]) (m : M A) (f : A -> M B) :
m >>= f = bigcup m f.
Proof. by []. Qed.
Module ExceptMonad.
Section exceptmonad.
Variable E : UU0.
Definition acto := fun A : UU0 => (E + A)%type.
Local Notation M := acto.
Let ret : idfun ~~> M := @inr E.
Let bind := fun A B (m : M A) (f : A -> M B) =>
match m with inl z => inl z | inr b => f b end.
Let left_neutral : BindLaws.left_neutral bind ret.
Proof. by []. Qed.
Let right_neutral : BindLaws.right_neutral bind ret.
Proof. by move=> ? []. Qed.
Let associative : BindLaws.associative bind.
Proof. by move=> ? ? ? []. Qed.
HB.instance Definition _ :=
isMonad_ret_bind.Build M left_neutral right_neutral associative.
End exceptmonad.
End ExceptMonad.
HB.export ExceptMonad.
Lemma except_bindE (E A B : UU0) (M := ExceptMonad.acto E)
(m : M A) (f : A -> M B) :
m >>= f = match m with inl z => inl z | inr b => f b end.
Proof. by []. Qed.
Definition option_monad := ExceptMonad.acto unit.
HB.instance Definition _ := Monad.on option_monad.
Module OutputMonad.
Section output.
Variable L : UU0.
Definition acto := fun X : UU0 => (X * seq L)%type.
Local Notation M := acto.
Let ret : idfun ~~> M := fun A a => (a, [::]).
Let bind := fun (A B : UU0) (m : M A) (f : A -> M B) =>
let: (x, w) := m in let: (x', w') := f x in (x', w ++ w').
Let left_neutral : BindLaws.left_neutral bind ret.
Proof. by move=> A B a f; rewrite /bind /=; case: f. Qed.
Let right_neutral : BindLaws.right_neutral bind ret.
Proof. by move=> A m; rewrite /bind /=; case: m => x w; rewrite cats0. Qed.
Let associative : BindLaws.associative bind.
Proof.
move=> A B C m f g; rewrite /bind; case: m => x w; case: f => x' w'.
by case: g => x'' w''; rewrite catA.
Qed.
HB.instance Definition _ :=
isMonad_ret_bind.Build M left_neutral right_neutral associative.
End output.
End OutputMonad.
HB.export OutputMonad.
Lemma output_bindE (L A B : UU0) (M := OutputMonad.acto L)
(m : M A) (f : A -> M B) :
m >>= f = let: (x, w) := m in let: (x', w') := f x in (x', w ++ w').
Proof. by []. Qed.
Module EnvironmentMonad.
Section environment.
Variable E : UU0.
Definition acto := fun A : UU0 => E -> A.
Local Notation M := acto.
Definition ret : idfun ~~> M := fun A x => fun e => x.
(* computation that ignores the environment *)
Let bind := fun (A B : UU0) (m : M A) (f : A -> M B) => fun e => f (m e) e.
(* binds m f applied the same environment to m and to the result of f *)
Let left_neutral : BindLaws.left_neutral bind ret.
Proof. by []. Qed.
Let right_neutral : BindLaws.right_neutral bind ret.
Proof. by []. Qed.
Let associative : BindLaws.associative bind.
Proof. by []. Qed.
HB.instance Definition _ :=
isMonad_ret_bind.Build M left_neutral right_neutral associative.
End environment.
End EnvironmentMonad.
HB.export EnvironmentMonad.
Lemma environment_bindE (E A B : UU0) (M := EnvironmentMonad.acto E)
(m : M A) (f : A -> M B) :
m >>= f = fun e => f (m e) e.
Proof. by []. Qed.
Module StateMonad.
Section state.
Variable S : UU0. (* type of states *)
Definition acto := fun A : UU0 => S -> A * S.
Local Notation M := acto.
Let ret : idfun ~~> M := fun A a => fun s => (a, s).
Let bind := fun (A B : UU0) (m : M A) (f : A -> M B) => uncurry f \o m.
Let left_neutral : BindLaws.left_neutral bind ret.
Proof. by move=> A B a f; apply boolp.funext. Qed.
Let right_neutral : BindLaws.right_neutral bind ret.
Proof.
by move=> A f; apply boolp.funext => s; rewrite /bind /=; case: (f s).
Qed.
Let associative : BindLaws.associative bind.
Proof.
move=> A B C a b c; rewrite /bind compA; congr (_ \o _).
by apply boolp.funext => -[].
Qed.
HB.instance Definition _ :=
isMonad_ret_bind.Build M left_neutral right_neutral associative.
End state.
End StateMonad.
HB.export StateMonad.
Lemma state_bindE (S A B : UU0) (M := StateMonad.acto S)
(m : M A) (f : A -> M B) : m >>= f = uncurry f \o m.
Proof. by []. Qed.
(* see Sect. 3 of of [Wadler, 94] for the model of the ret and the bind of the
continuation monad *)
Module ContMonad.
Section cont.
Variable r : UU0. (* the type of answers *)
Definition acto := fun A : UU0 => (A -> r) -> r.
Local Notation M := acto.
Let ret : idfun ~~> M := fun A a => fun k => k a.
Let bind := fun (A B : UU0) (m : M A) (f : A -> M B) => fun k => m (fun a => f a k).
Let left_neutral : BindLaws.left_neutral bind ret.
Proof. by move=> A B a f; apply boolp.funext => Br. Qed.
Let right_neutral : BindLaws.right_neutral bind ret.
Proof. by []. Qed.
Let associative : BindLaws.associative bind.
Proof. by []. Qed.
HB.instance Definition _ :=
isMonad_ret_bind.Build M left_neutral right_neutral associative.
End cont.
End ContMonad.
HB.export ContMonad.
Lemma cont_bindE (r A B : UU0) (M := ContMonad.acto r) (m : M A) (f : A -> M B) :
m >>= f = fun k => m (fun a => f a k).
Proof. by []. Qed.
Module Empty.
Section empty.
Definition acto (X : UU0) : UU0 := unit.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y := tt.
Let func_id : FunctorLaws.id actm.
Proof. by move=> A; apply boolp.funext => -[]. Qed.
Let func_comp : FunctorLaws.comp actm.
Proof. by move=> A B C f g; apply boolp.funext => -[]. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End empty.
End Empty.
HB.export monae.theories.models.monad_model.Empty.
Module Append.
Section append.
Definition acto (X : UU0) := (X * X)%type.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y :=
let: (x1, x2) := t in (f x1, f x2).
Let func_id : FunctorLaws.id actm.
Proof. by move=> A; apply boolp.funext => -[]. Qed.
Let func_comp : FunctorLaws.comp actm.
Proof. by move=> A B C f g; apply boolp.funext => -[]. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End append.
End Append.
HB.export Append.
Section appendop.
Local Notation M := [the monad of ListMonad.acto].
Definition empty : Empty.acto \o M ~~> M := fun A _ => @nil A.
Let naturality_empty : naturality (Empty.acto \o M) M empty.
Proof. by move=> A B h; exact: boolp.funext. Qed.
HB.instance Definition _ :=
isNatural.Build (Empty.acto \o M) M empty naturality_empty.
Definition empty_op : Empty.acto.-operation M := [the _ ~> _ of empty].
Lemma algebraic_empty : algebraicity empty_op.
Proof. by []. Qed.
Definition append : Append.acto \o M ~~> M :=
fun A x => let: (s1, s2) := x in (s1 ++ s2).
Let naturality_append : naturality (Append.acto \o M) M append.
Proof.
move=> A B h; apply boolp.funext => -[s1 s2] /=.
rewrite /actm /=.
by rewrite map_cat flatten_cat.
Qed.
HB.instance Definition _ :=
isNatural.Build (Append.acto \o M) M append naturality_append.
Definition append_op : Append.acto.-operation M := [the _ ~> _ of append].
Lemma algebraic_append : algebraicity append_op.
Proof.
move=> A B f [t1 t2] /=.
by rewrite 3!list_bindE -flatten_cat -map_cat.
Qed.
End appendop.
Module Output.
Section output.
Variable L : UU0.
Definition acto (X : UU0) := (seq L * X)%type.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y :=
let: (w, x) := t in (w, f x).
Let func_id : FunctorLaws.id actm.
Proof. by move=> A; apply boolp.funext; case. Qed.
Let func_comp : FunctorLaws.comp actm.
Proof. by move=> A B C f g; apply boolp.funext; case. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End output.
End Output.
HB.export Output.
Module Flush.
Section flush.
Definition acto (X : UU0) := X.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y := f t.
Let func_id : FunctorLaws.id actm. Proof. by []. Qed.
Let func_comp : FunctorLaws.comp actm. Proof. by []. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End flush.
End Flush.
HB.export Flush.
Section outputops.
Variable L : UU0.
Local Notation M := (OutputMonad.acto L).
Definition output : Output.acto L \o M ~~> M :=
fun A m => let: (x, w') := m.2 in (x, m.1 ++ w'). (*NB: w'++m.1 in the esop paper*)
Let naturality_output :
naturality (Output.acto L \o M) M output.
Proof.
move=> A B h.
apply boolp.funext => -[w [x w']].
by rewrite /output /= catA.
Qed.
HB.instance Definition _ := isNatural.Build
(Output.acto L \o M) M output naturality_output.
Definition output_op : (Output.acto L).-operation M := [the _ ~> _ of output].
Lemma algebraic_output : algebraicity output_op.
Proof.
move=> A B f [w [x w']].
rewrite output_bindE/=.
rewrite /output /=.
rewrite output_bindE.
by case: f => x' w''; rewrite catA.
Qed.
Definition flush : (Flush.acto \o M) ~~> M :=
fun A m => let: (x, _) := m in (x, [::]).
(* performing a computation in a modified environment *)
Let naturality_flush : naturality (Flush.acto \o M) M flush.
Proof. by move=> A B h; apply: boolp.funext => -[]. Qed.
HB.instance Definition _ := isNatural.Build
(Flush.acto \o M) M flush naturality_flush.
(* NB: flush is not algebraic *)
Definition flush_op : Flush.acto.-operation M :=
[the _ ~> _ of flush].
Lemma algebraic_flush : algebraicity flush_op.
Proof.
move=> A B f [x w].
rewrite output_bindE.
rewrite /flush_op /=.
rewrite /flush /=.
rewrite /actm /=.
rewrite output_bindE.
case: f => x' w'.
Abort.
End outputops.
(* wip *)
Module Output'.
Section output.
Variable L : UU0.
Local Notation M := (OutputMonad.acto L).
(* usual output operation *)
Definition output : seq L -> M unit := fun w => output_op _ _ (w, Ret tt).
Lemma outputE : output = fun w => (tt, w).
Proof.
apply boolp.funext => w.
by rewrite /output /= /monad_model.output /= cats0.
Qed.
(* TODO: complete with an interface for the output monad and instantiate *)
End output.
End Output'.
Module Ask.
Section ask.
Variable E : UU0.
Definition acto (X : UU0) := E -> X.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y := f \o t.
Let func_id : FunctorLaws.id actm. Proof. by []. Qed.
Let func_comp : FunctorLaws.comp actm. Proof. by []. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End ask.
End Ask.
HB.export Ask.
Module Local.
Section local.
Variable E : UU0.
Definition acto (X : UU0) := ((E -> E) * X)%type.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y :=
let: (e, x) := t in (e, f x).
Let func_id : FunctorLaws.id actm.
Proof. by move=> A; apply boolp.funext => -[]. Qed.
Let func_comp : FunctorLaws.comp actm.
Proof. by move=> A B C g h; apply boolp.funext => -[]. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End local.
End Local.
HB.export Local.
Section environmentops.
Variable E : UU0.
Local Notation M := (EnvironmentMonad.acto E).
Definition ask : (Ask.acto E \o M)(*E -> M A?*) ~~> M :=
fun A f s => f s s. (* reading the environment *)
Let naturality_ask : naturality (Ask.acto E \o M) M ask.
Proof. by []. Qed.
HB.instance Definition _ := isNatural.Build
(Ask.acto E \o M) M ask naturality_ask.
Definition ask_op : (Ask.acto E).-operation M :=
[the _ ~> _ of ask].
Lemma algebraic_ask : algebraicity ask_op.
Proof. by []. Qed.
Definition local : (Local.acto E \o M)(*(E -> E) * M A*) ~~> M :=
fun A x s => let: (e, t) := x in t (e s).
(* performing a computation in a modified environment *)
Let naturality_local : naturality (Local.acto E \o M) M local.
Proof. by move=> A B h; apply boolp.funext => -[]. Qed.
HB.instance Definition _ := isNatural.Build
(Local.acto E \o M) M local naturality_local.
Definition local_op : (Local.acto E).-operation M :=
[the _ ~> _ of local].
(* NB: local is not algebraic *)
Lemma algebraic_local : algebraicity local_op.
Proof.
move=> A B f t.
rewrite environment_bindE.
rewrite /local_op /=.
rewrite /local /=.
rewrite /actm /=.
case: t => /= ee m.
rewrite environment_bindE.
apply boolp.funext=> x /=.
Abort.
End environmentops.
(* wip *)
Module Environment.
Section environment.
Variable E : UU0.
Local Notation M := (EnvironmentMonad.acto E).
(* usual get operation *)
Definition ask : M E := ask_op _ _ Ret.
Lemma askE : ask = fun e => e. Proof. by []. Qed.
(* TODO: complete with an interface for the environment monad and instantiate, see Jaskelioff's PhD *)
End environment.
End Environment.
Module Throw.
Section throw.
Variable Z : UU0.
Definition acto (X : UU0) := Z.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y := t.
Let func_id : FunctorLaws.id actm. Proof. by []. Qed.
Let func_comp : FunctorLaws.comp actm. Proof. by []. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End throw.
End Throw.
HB.export Throw.
Module Handle.
Section handle.
Variable Z : UU0.
Definition acto (X : UU0) := (X * (Z -> X))%type.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y :=
let: (x, h) := t in (f x, fun z => f (h z)).
Let func_id : FunctorLaws.id actm.
Proof. by move=> A; apply boolp.funext => -[]. Qed.
Let func_comp : FunctorLaws.comp actm.
Proof. by move=> A B C g h; apply boolp.funext => -[]. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End handle.
End Handle.
HB.export Handle.
Section exceptops.
Variable Z : UU0.
Local Notation M := (ExceptMonad.acto Z).
Definition throw : (Throw.acto Z \o M) ~~> M :=
fun (A : UU0) z => inl z.
Let naturality_throw : naturality (Throw.acto Z \o M) M throw.
Proof. by []. Qed.
HB.instance Definition _ := isNatural.Build
(Throw.acto Z \o M) M throw naturality_throw.
Definition throw_op : (Throw.acto Z).-operation M :=
[the _ ~> _ of throw].
Lemma algebraic_throw : algebraicity throw_op.
Proof. by []. Qed.
HB.instance Definition _ := isAOperation.Build _ M throw algebraic_throw.
Definition throw_aop : (Throw.acto Z).-aoperation M :=
[the aoperation _ _ of throw].
Definition handle' A (m : M A) (h : Z -> M A) : M A :=
match m with inl z => h z | inr x => inr x end.
Definition handle : Handle.acto Z \o M ~~> M :=
fun A => uncurry (@handle' A).
Let naturality_handle : naturality (Handle.acto Z \o M) M handle.
Proof. by move=> A B h; apply boolp.funext => -[[]]. Qed.
HB.instance Definition _ := isNatural.Build
(Handle.acto Z \o M) M handle naturality_handle.
Definition handle_op : (Handle.acto Z).-operation M :=
[the _ ~> _ of handle].
(* NB: handle is not algebraic *)
Lemma algebraic_handle : algebraicity handle_op.
Proof.
move=> A B f t.
rewrite except_bindE.
rewrite /handle_op /=.
rewrite /handle /=.
rewrite /uncurry /=.
case: t => -[z//|a] g /=.
rewrite except_bindE.
case: (f a) => // z.
rewrite /handle'.
rewrite except_bindE.
case: (g z) => [z0|a0].
Abort.
End exceptops.
Arguments throw_op {Z}.
Arguments handle_op {Z}.
(* NB: see also Module Ask *)
Module StateOpsGet.
Section get.
Variable S : UU0.
Definition acto (X : UU0) := S -> X.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y := f \o t.
Let func_id : FunctorLaws.id actm.
Proof. by move=> A; apply boolp.funext. Qed.
Let func_comp : FunctorLaws.comp actm.
Proof. by move=> A B C g h; apply boolp.funext. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End get.
End StateOpsGet.
HB.export StateOpsGet.
Module StateOpsPut.
Section put.
Variable S : UU0.
Definition acto (X : UU0) := (S * X)%type.
Let actm (X Y : UU0) (f : X -> Y) (sx : acto X) : acto Y := (sx.1, f sx.2).
Let func_id : FunctorLaws.id actm.
Proof. by move=> A; apply boolp.funext => -[]. Qed.
Let func_comp : FunctorLaws.comp actm.
Proof. by move=> A B C g h; apply boolp.funext. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End put.
End StateOpsPut.
HB.export StateOpsPut.
Section stateops.
Variable S : UU0.
Local Notation M := (StateMonad.acto S).
Let get : StateOpsGet.acto S \o M ~~> M := fun A k s => k s s.
Let naturality_get : naturality (StateOpsGet.acto S \o M) M get.
Proof.
move=> A B h; apply boolp.funext => /= m; apply boolp.funext => s.
by rewrite FCompE.
Qed.
HB.instance Definition _ := isNatural.Build _ M get naturality_get.
Definition get_op : (StateOpsGet.acto S).-operation M :=
[the _ ~> _ of get].
Lemma algebraic_get : algebraicity get_op.
Proof. by []. Qed.
HB.instance Definition _ := isAOperation.Build
(StateOpsGet.acto S) M get algebraic_get.
Definition get_aop : (StateOpsGet.acto S).-aoperation M :=
[the aoperation _ _ of get].
Let put' A (s : S) (m : M A) : M A := fun _ => m s.
Let put : StateOpsPut.acto S \o M ~~> M :=
fun A => uncurry (put' (A := A)).
Let naturality_put : naturality (StateOpsPut.acto S \o M) M put.
Proof.
by move=> A B h; apply boolp.funext => /= -[s m /=]; apply boolp.funext.
Qed.
HB.instance Definition _ :=
isNatural.Build _ M put naturality_put.
Definition put_op : (StateOpsPut.acto S).-operation M :=
[the _ ~> _ of put].
Lemma algebraic_put : algebraicity put_op.
Proof. by move=> ? ? ? []. Qed.
HB.instance Definition _ := isAOperation.Build
(StateOpsPut.acto S) M put algebraic_put.
Definition put_aop : (StateOpsPut.acto S).-aoperation M :=
[the aoperation _ _ of put].
End stateops.
Arguments get_op {S}.
Arguments put_op {S}.
Module ContOpsAbort.
Section abort.
Variable r : UU0.
Definition acto (X : UU0) := r.
Let actm (A B : UU0) (f : A -> B) (x : acto A) : acto B := x.
Let func_id : FunctorLaws.id actm. Proof. by []. Qed.
Let func_comp : FunctorLaws.comp actm. Proof. by []. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End abort.
End ContOpsAbort.
HB.export ContOpsAbort.
Module ContOpsAcallcc.
Section acallcc.
Variable r : UU0.
Definition acto := fun A : UU0 => (A -> r) -> A.
Let actm (X Y : UU0) (f : X -> Y) (t : acto X) : acto Y :=
fun (g : Y -> r) => f (t (fun x => g (f x))).
Let func_id : FunctorLaws.id actm. Proof. by []. Qed.
Let func_comp : FunctorLaws.comp actm. Proof. by []. Qed.
HB.instance Definition _ := isFunctor.Build acto func_id func_comp.
End acallcc.
End ContOpsAcallcc.
HB.export ContOpsAcallcc.
Section contops.
Variable r : UU0.
Local Notation M := (ContMonad.acto r).
Definition abort : ContOpsAbort.acto r \o M ~~> M :=
fun (A : UU0) r _ => r.
Lemma naturality_abort : naturality (ContOpsAbort.acto r \o M) M abort.
Proof. by []. Qed.
HB.instance Definition _ := isNatural.Build _ M abort naturality_abort.
Definition abort_op : (ContOpsAbort.acto r).-operation M :=
[the _ ~> _ of abort].
Let algebraicity_abort : algebraicity abort_op.
Proof. by []. Qed.
HB.instance Definition _ := isAOperation.Build (ContOpsAbort.acto r) M
abort algebraicity_abort.
Definition abort_aop : (ContOpsAbort.acto r).-aoperation M :=
[the aoperation _ _ of abort].
(* alebgraic call/cc *)
Definition acallcc : (ContOpsAcallcc.acto r \o M)(*(f : (M A -> r) -> M A)*) ~~> M :=
fun A f k => f (fun m => m k) k.
Let naturality_acallcc : naturality (ContOpsAcallcc.acto r \o M) M acallcc.
Proof. by []. Qed.
HB.instance Definition _ :=
isNatural.Build _ M acallcc naturality_acallcc.
Definition acallcc_op : (ContOpsAcallcc.acto r).-operation M :=
[the _ ~> _ of acallcc].
Let algebraicity_callcc : algebraicity acallcc_op.
Proof. by []. Qed.
HB.instance Definition _ := isAOperation.Build (ContOpsAcallcc.acto r) M
acallcc algebraicity_callcc.
Definition callcc_aop : (ContOpsAcallcc.acto r).-aoperation M :=
[the aoperation _ _ of acallcc].
End contops.
Module Fail.
Section fail.
Definition option_fail : forall A, option_monad A := fun A => @throw unit A tt.
Let option_bindfailf : BindLaws.left_zero (@bind _) option_fail.
Proof. by []. Qed.
HB.instance Definition _ := Monad.on option_monad.
HB.instance Definition _ := @isMonadFail.Build option_monad
option_fail option_bindfailf.
Definition list_fail : forall A, ListMonad.acto A := fun A => @empty _ tt.
Let list_bindfailf : BindLaws.left_zero (@bind _) list_fail.
Proof. by []. Qed.
HB.instance Definition _ := @isMonadFail.Build ListMonad.acto list_fail list_bindfailf.
Definition set_fail : forall A, set A := @set0.
Let set_bindfailf : BindLaws.left_zero (@bind _) set_fail.
Proof.
move=> A B f /=; apply boolp.funext => b; rewrite boolp.propeqE.
by split=> // -[a []].
Qed.
HB.instance Definition _ := isMonadFail.Build set set_bindfailf.
End fail.
End Fail.
HB.export Fail.
Module Except.
Section except.
Let M : failMonad := option_monad.
Definition handle : forall A, M A -> M A -> M A :=
fun A m1 m2 => @handle_op unit _ (m1, (fun _ => m2)).
Lemma handleE : handle = (fun A m m' => if m is inr x then m else m').
Proof. by apply funext_dep => A; apply boolp.funext => -[]. Qed.
Let catchmfail : forall A, right_id fail (@handle A).
Proof. by move=> A; case => //; case. Qed.
Let catchfailm : forall A, left_id fail (@handle A).
Proof. by move=> A; case. Qed.
Let catchA : forall A, ssrfun.associative (@handle A).
Proof. by move=> A; case. Qed.
Let catchret : forall A x, @left_zero (M A) (M A) (Ret x) (@handle A).
Proof. by move=> A x; case. Qed.
HB.instance Definition _ := isMonadExcept.Build option_monad
catchmfail catchfailm catchA catchret.
End except.
End Except.
HB.export Except.
Module State.
Section state.
Variable S : UU0.
Local Notation M := (StateMonad.acto S).
Let get : M S := get_op _ Ret.
Lemma getE : get = fun s => (s, s). Proof. by []. Qed.
Let put : S -> M unit := fun s => put_op _ (s, Ret tt).
Lemma putE : put = fun s' _ => (tt, s').
Proof. by []. Qed.
Let putput : forall s s', put s >> put s' = put s'.
Proof. by []. Qed.
Let putget : forall s, put s >> get = put s >> Ret s.
Proof. by []. Qed.
Let getput : get >>= put = skip.
Proof. by []. Qed.
Let getget : forall (A : UU0) (k : S -> S -> M A), get >>= (fun s => get >>= k s) = get >>= fun s => k s s.
Proof. by []. Qed.
HB.instance Definition _ := isMonadState.Build S (StateMonad.acto S)
putput putget getput getget.
End state.
End State.
HB.export State.
Module Alt.
Section list.
Let M := ListMonad.acto.
Definition list_alt : forall T, M T -> M T -> M T := fun A => curry (@append A).
Let altA (T : UU0) : ssrfun.associative (@list_alt T).
Proof. by move=> a b c; rewrite /list_alt /= /curry /= catA. Qed.
Let alt_bindDl : BindLaws.left_distributive (@bind [the monad of ListMonad.acto]) list_alt.
Proof.
move=> A B /= s1 s2 k.
by rewrite list_bindE map_cat flatten_cat.
Qed.
HB.instance Definition _ := isMonadAlt.Build ListMonad.acto altA alt_bindDl.
End list.
(* NB: was at the top of the file *)
Lemma setUDl : @BindLaws.left_distributive _ (fun I A => @bigcup A I) (@setU).
Proof.
move=> A B /= p q r; apply boolp.funext => b; rewrite boolp.propeqE; split.
move=> -[a [?|?] ?]; by [left; exists a | right; exists a].
by rewrite /setU => -[[a ? ?]|[a ? ?]]; exists a => //; [left|right].
Qed.
Section set.
Let M := [the monad of set].
Let altA : forall T : UU0, ssrfun.associative (@setU T).
Proof. by move=> ?; exact: setUA. Qed.
Let alt_bindDl : BindLaws.left_distributive (@bind [the monad of set]) (@setU).
Proof.
rewrite /BindLaws.left_distributive /= => A B m1 m2 k.
by rewrite set_bindE setUDl.
Qed.
HB.instance Definition _ := isMonadAlt.Build set altA alt_bindDl.
End set.
End Alt.
HB.export Alt.
Module AltCI.
Section set.
Let M := [the altMonad of set].
Let altmm (A : UU0) : idempotent (@alt M A).
Proof. by move=> ?; exact: setUid. Qed.
Let altC (A : UU0) : commutative (@alt M A).
Proof. by move=> ?; exact: setUC. Qed.
HB.instance Definition _ := @isMonadAltCI.Build set altmm altC.
End set.
End AltCI.
HB.export AltCI.
Module Nondet.
Section list.
Let M : failMonad := [the failMonad of ListMonad.acto].
Let N : altMonad := [the altMonad of ListMonad.acto].
Let altfailm : @BindLaws.left_id _ (@fail M) (@alt N).
Proof. by []. Qed.
Let altmfail : @BindLaws.right_id _ (@fail M) (@alt N).
Proof.
move=> A l /=.
by rewrite /alt /= /list_alt /= /curry /= /fail /= /list_fail /= cats0.
Qed.
HB.instance Definition _ := isMonadNondet.Build ListMonad.acto altfailm altmfail.
End list.
Section set.
Local Notation M := [the failMonad of set].
Local Notation N := [the altMonad of set].
Let altfailm : @BindLaws.left_id _ (@fail M) (@alt N).
Proof.
move=> T m.
by rewrite /fail /= /set_fail /alt /= set0U.
Qed.
Let altmfail : @BindLaws.right_id _ (@fail M) (@alt N).
Proof.
move=> A l /=.
by rewrite /fail /= /alt /= /set_fail setU0.
Qed.
HB.instance Definition _ := isMonadNondet.Build set altfailm altmfail.
End set.
End Nondet.
HB.export Nondet.
Module PrePlus.
Section failr0.
Let M : failMonad := [the failMonad of set].
Let bindmfail : BindLaws.right_zero (@bind [the monad of set]) (@fail _).
Proof. by move=> T1 T2 A; rewrite /bind/= bigcup0. Qed.
HB.instance Definition _ := isMonadFailR0.Build set bindmfail.
End failr0.
Section set.
Let M : nondetMonad := [the nondetMonad of set].
Let alt_bindDr : BindLaws.right_distributive (@bind [the monad of set]) (@alt [the altMonad of set]).
Proof. by move=> T1 T2 A k1 k2; rewrite /bind/= bigcupU. Qed.
HB.instance Definition _ := isMonadPrePlus.Build set alt_bindDr.