├── .gitignore ├── Basics.agda ├── README.md ├── comedy.el ├── TypesMore.agda ├── Types4Crib.agda ├── Types4.agda ├── LICENSE ├── Bits.hs ├── Types4Crib.hs └── Types4.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /Basics.agda: -------------------------------------------------------------------------------- 1 | module Basics where 2 | 3 | data Zero : Set where 4 | record One : Set where constructor <> 5 | data Two : Set where tt ff : Two 6 | 7 | data Nat : Set where 8 | ze : Nat 9 | su : Nat -> Nat 10 | 11 | data _+_ (S T : Set) : Set where 12 | inl : S -> S + T 13 | inr : T -> S + T 14 | 15 | record Sg (S : Set)(T : S -> Set) : Set where 16 | constructor _,_ 17 | field 18 | fst : S 19 | snd : T fst 20 | open Sg public 21 | _*_ : Set -> Set -> Set 22 | S * T = Sg S \ _ -> T 23 | infixr 4 _,_ _*_ 24 | 25 | data _==_ {X : Set}(x : X) : X -> Set where 26 | refl : x == x 27 | 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # What are Types For, or are they only Against? 2 | being the materials from my YOW LambdaJam 2016 talk 3 | 4 | On the afternoon of Tuesday 26 April, 2016, I was hosting the [23rd Agda Implementors Meeting](http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.AIMXXIII) at the University of Strathclyde. I ducked 5 | out to give my last [CS410](https://github.com/pigworker/CS410-15) lecture of the year, then filled a bag 6 | with whisky and clothes and headed to Glasgow airport. 7 | 8 | On the morning of Thursday 28 April, 2016, I arrived at Brisbane airport, still wearing the 9 | same t-shirt. I cleared immigration and customs, was collected by a pre-booked cab, and delivered to 10 | Queensland University of Technology. There, they gave me a cup of black coffee and a clean t-shirt, and 11 | I gave this [talk](https://www.youtube.com/watch?v=3U3lV5VPmOU). 12 | 13 | This repo contains the code edited live in that talk (in files Types4.hs, then Types4.agda), the emacs 14 | key-bindings used to move between ‘slides’ and to (de)activate code regions, and some other 15 | random hackings from the plane. 16 | -------------------------------------------------------------------------------- /comedy.el: -------------------------------------------------------------------------------- 1 | (defun next-slide-please () 2 | (interactive) 3 | (search-forward "{---") 4 | (next-line) 5 | (recenter-top-bottom 0) 6 | ) 7 | (global-set-key "§" 'next-slide-please) 8 | 9 | (defun previous-slide-please () 10 | (interactive) 11 | (search-backward "{---") 12 | (previous-line) 13 | (search-backward "{---") 14 | (next-line) 15 | (recenter-top-bottom 0) 16 | ) 17 | (global-set-key "±" 'previous-slide-please) 18 | 19 | (defun comment-in-agda () 20 | (interactive) 21 | (search-forward "{-+}") 22 | (backward-delete-char 2) 23 | (insert-string "(-}") 24 | (search-forward "{+-}") 25 | (backward-delete-char 3) 26 | (insert-string "-)-}") 27 | (search-backward "{-(-}") 28 | (next-line) 29 | (agda2-load) 30 | ) 31 | (global-set-key [?\C-§] 'comment-in-agda) 32 | 33 | (defun comment-out-agda () 34 | (interactive) 35 | (search-backward "{-(-}") 36 | (forward-char 4) 37 | (backward-delete-char 2) 38 | (insert-string "+") 39 | (search-forward "-)-}") 40 | (backward-delete-char 4) 41 | (insert-string "+-}") 42 | (next-line) 43 | (agda2-load) 44 | ) 45 | (global-set-key [?\M-§] 'comment-out-agda) 46 | 47 | -------------------------------------------------------------------------------- /TypesMore.agda: -------------------------------------------------------------------------------- 1 | module TypesMore where 2 | 3 | open import Basics 4 | open import Types4 5 | 6 | module DESC (I : Set) where 7 | 8 | data Desc : Set1 where 9 | inx : I -> Desc 10 | sg : (A : Set)(D : A -> Desc) -> Desc 11 | _!_ : I -> Desc -> Desc 12 | 13 | Node : Desc -> (I -> Set) -> I -> Set 14 | Node (inx x) R i = x == i 15 | Node (sg A D) R i = Sg A \ a -> Node (D a) R i 16 | Node (x ! D) R i = R x * Node D R i 17 | 18 | data Mu (D : Desc)(i : I) : Set where 19 | [_] : Node D (Mu D) i -> Mu D i 20 | 21 | cata : forall D {X} -> ({i : I} -> Node D X i -> X i) -> 22 | forall {i} -> Mu D i -> X i 23 | mapCata : forall {D} E {X} -> ({i : I} -> Node D X i -> X i) -> 24 | forall {i} -> Node E (Mu D) i -> Node E X i 25 | cata D f [ x ] = f (mapCata D f x) 26 | mapCata (inx x) f q = q 27 | mapCata (sg A E) f (a , e) = a , mapCata (E a) f e 28 | mapCata (i ! E) f (x , e) = cata _ f x , mapCata E f e 29 | 30 | module ORN (J : Set)(ji : J -> I) where 31 | 32 | Hits : I -> Set 33 | Hits i = Sg J \ j -> ji j == i 34 | 35 | data Orn : Desc -> Set1 where 36 | inx : forall {i} -> Hits i -> Orn (inx i) 37 | sg : forall A {D} -> ((a : A) -> Orn (D a)) -> Orn (sg A D) 38 | _!_ : forall {i D} -> Hits i -> Orn D -> Orn (i ! D) 39 | ins : forall (X : Set) {D} -> (X -> Orn D) -> Orn D 40 | del : forall {A D} a -> Orn (D a) -> Orn (sg A D) 41 | 42 | open DESC 43 | 44 | NatDesc : Desc One 45 | NatDesc = sg Two \ { tt -> inx <> ; ff -> <> ! inx <> } 46 | 47 | NAT : Set 48 | NAT = Mu One NatDesc <> 49 | pattern ZE = [ tt , refl ] 50 | pattern SU n = [ ff , n , refl ] 51 | PLUS : NAT -> NAT -> NAT 52 | PLUS ZE y = y 53 | PLUS (SU x) y = SU (PLUS x y) 54 | 55 | open ORN 56 | 57 | orned : forall {I D J ji} -> Orn I J ji D -> Desc J 58 | orned (inx (j , q)) = inx j 59 | orned (sg A D) = sg A \ a -> orned (D a) 60 | orned ((j , q) ! O) = j ! orned O 61 | orned (ins X O) = sg X \ x -> orned (O x) 62 | orned (del a O) = orned O 63 | 64 | ListOrn : Set -> Orn One One _ NatDesc 65 | ListOrn X = sg Two \ 66 | { tt -> inx (<> , refl) 67 | ; ff -> ins X \ _ -> (<> , refl) ! (inx (<> , refl)) 68 | } 69 | 70 | forget : forall {I D J ji} (O : Orn I J ji D) {P : I -> Set} -> 71 | {j : J} -> Node J (orned O) (\ j -> P (ji j)) j -> 72 | Node I D P (ji j) 73 | forget (inx (j , refl)) refl = refl 74 | forget (sg A O) (a , o) = a , forget (O a) o 75 | forget ((j , refl) ! O) (p , o) = p , forget O o 76 | forget (ins X O) (x , o) = forget (O x) o 77 | forget (del a O) o = a , forget O o 78 | 79 | plain : forall {I D J ji} (O : Orn I J ji D) 80 | {j : J} -> Mu J (orned O) j -> Mu I D (ji j) 81 | plain O = cata _ (orned O) (\ x -> [ forget O {Mu _ _} x ]) 82 | -------------------------------------------------------------------------------- /Types4Crib.agda: -------------------------------------------------------------------------------- 1 | module Types4Crib where 2 | 3 | open import Basics public 4 | 5 | _<=_ : Nat -> Nat -> Set 6 | ze <= y = One 7 | su x <= ze = Zero 8 | su x <= su y = x <= y 9 | 10 | cmp : (x y : Nat) -> (x <= y) + (y <= x) 11 | cmp ze y = inl <> 12 | cmp (su x) ze = inr <> 13 | cmp (su x) (su y) = cmp x y 14 | 15 | data Bnd : Set where 16 | bot : Bnd 17 | # : Nat -> Bnd 18 | top : Bnd 19 | 20 | _ Bnd -> Set 21 | bot Set where 27 | leaf : (lu : l T23 l u ze 28 | node2 : forall {h} x 29 | (tlx : T23 l (# x) h)(txu : T23 (# x) u h) -> 30 | T23 l u (su h) 31 | node3 : forall {h} x y 32 | (tlx : T23 l (# x) h)(txy : T23 (# x) (# y) h)(tyu : T23 (# y) u h) -> 33 | T23 l u (su h) 34 | 35 | data Intv (l u : Bnd) : Set where 36 | intv : (x : Nat)(lx : l Intv l u 37 | 38 | TooBig : Bnd -> Bnd -> Nat -> Set 39 | TooBig l u h = Sg Nat \ x -> T23 l (# x) h * T23 (# x) u h 40 | 41 | insert : forall {h l u} -> Intv l u -> T23 l u h -> 42 | TooBig l u h + T23 l u h 43 | insert (intv x lx xu) (leaf lu) = inl (x , (leaf lx , leaf xu)) 44 | insert (intv x lx xu) (node2 y tly tyu) with cmp x y 45 | insert (intv x lx xu) (node2 y tly tyu) | inl xy with insert (intv x lx xy) tly 46 | insert (intv x lx xu) (node2 y tly tyu) | inl xy | inl (z , tlz , tzu) 47 | = inr (node3 z y tlz tzu tyu) 48 | insert (intv x lx xu) (node2 y tly tyu) | inl xy | inr tly' 49 | = inr (node2 y tly' tyu) 50 | insert (intv x lx xu) (node2 y tly tyu) | inr yx with insert (intv x yx xu) tyu 51 | insert (intv x lx xu) (node2 y tly tyu) | inr yx | inl (v , tyv , tvu) = inr (node3 y v tly tyv tvu) 52 | insert (intv x lx xu) (node2 y tly tyu) | inr yx | inr tyv' = inr (node2 y tly tyv') 53 | insert (intv x lx xu) (node3 y z tly tyz tzu) with cmp x y 54 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inl xy with insert (intv x lx xy) tly 55 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inl xy | inl (v , tlv , tvy) = inl (y , node2 v tlv tvy , node2 z tyz tzu) 56 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inl xy | inr tly' = inr (node3 y z tly' tyz tzu) 57 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr yx with cmp x z 58 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr yx | inl xz with insert (intv x yx xz) tyz 59 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr yx | inl xz | inl (v , tyv , tvz) 60 | = inl (v , node2 y tly tyv , node2 z tvz tzu) 61 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr yx | inl xz | inr tyz' 62 | = inr (node3 y z tly tyz' tzu) 63 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr yx | inr zx with insert (intv x zx xu) tzu 64 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr yx | inr zx | inl (v , tzv , tvu) = inl (z , node2 y tly tyz , node2 v tzv tvu) 65 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr yx | inr zx | inr tzu' = inr (node3 y z tly tyz tzu') 66 | -------------------------------------------------------------------------------- /Types4.agda: -------------------------------------------------------------------------------- 1 | module Types4 where 2 | 3 | open import Basics public 4 | 5 | {-----------------------------------------------------------------------} 6 | -- balanced search trees (based on my ICFP '14 paper 7 | -- How to Keep Your Neighbours in Order 8 | 9 | 10 | -- but the point here is to watch what the types buy us 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | {-----------------------------------------------------------------------} 33 | -- compare natural numbers {- might we visit Basics.agda? -} 34 | 35 | _<=_ : Nat -> Nat -> Set 36 | ze <= y = One 37 | su x <= ze = Zero 38 | su x <= su y = x <= y 39 | 40 | {-(-} 41 | cmp : (x y : Nat) -> (x <= y) + (y <= x) 42 | cmp ze y = inl <> 43 | cmp (su x) ze = inr <> 44 | cmp (su x) (su x₁) = cmp x x₁ 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 | -- loose bounds (one good idea, not always obvious) 71 | 72 | data Bnd : Set where 73 | bot : Bnd 74 | # : Nat -> Bnd 75 | top : Bnd 76 | 77 | _ Bnd -> Set 78 | bot Intv l u 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | {-----------------------------------------------------------------------} 96 | -- 2-3-trees, indexed by bounds and height 97 | 98 | data T23 (l u : Bnd) : (h : Nat) -> Set where 99 | 100 | leaf : (lu : l 101 | T23 l u ze 102 | 103 | node2 : forall {h} x 104 | (tlx : T23 l (# x) h)(txu : T23 (# x) u h) -> 105 | T23 l u (su h) 106 | 107 | node3 : forall {h} x y 108 | (tlx : T23 l (# x) h)(txy : T23 (# x) (# y) h)(tyu : T23 (# y) u h) -> 109 | T23 l u (su h) 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | {-----------------------------------------------------------------------} 119 | -- insertion 120 | 121 | TooBig : Bnd -> Bnd -> Nat -> Set 122 | TooBig l u h = Sg Nat \ x -> T23 l (# x) h * T23 (# x) u h 123 | 124 | {-(-} 125 | insert : forall {h l u} -> Intv l u -> T23 l u h -> 126 | TooBig l u h + T23 l u h 127 | insert (intv x lx xu) (leaf lu) = {!!} 128 | insert (intv x lx xu) (node2 x₁ t t₁) = {!!} 129 | insert (intv x lx xu) (node3 y z tly tyz tzu) with cmp x y 130 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inl xy with insert (intv x lx xy) tly 131 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inl xy | inl (v , tlv , tvy) 132 | = inl (y , node2 v tlv tvy , node2 z tyz tzu) 133 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inl xy | inr x₁ = {!!} 134 | insert (intv x lx xu) (node3 y z tly tyz tzu) | inr x₁ = {!!} 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 | -- confession 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | -- it took me about fifteen years to come up with that type for insert 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | {-----------------------------------------------------------------------} 186 | -- question (0) 187 | 188 | 189 | 190 | 191 | -- how can we make better use of the way types act as "problem statement?" 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | {-----------------------------------------------------------------------} 210 | -- question (1) 211 | 212 | 213 | 214 | 215 | -- how can we make better use of the way types act as "problem statement?" 216 | 217 | -- programmers should profit from the downpayment and focus on 218 | -- the actual choices 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | {-----------------------------------------------------------------------} 234 | -- question (2) 235 | 236 | 237 | 238 | 239 | -- how can we make better use of the way types act as "problem statement?" 240 | 241 | -- programmers should profit from the downpayment and focus on 242 | -- the actual choices 243 | 244 | -- "code" should be a readable record of a problem solving interaction 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | {-----------------------------------------------------------------------} 258 | -- question (3) 259 | 260 | 261 | 262 | 263 | -- how can we make better use of the way types act as "problem statement?" 264 | 265 | -- programmers should profit from the downpayment and focus on 266 | -- the actual choices 267 | 268 | -- "code" should be a readable record of a problem solving interaction 269 | 270 | -- we need tools to support redesign 271 | 272 | 273 | 274 | 275 | 276 | 277 | 278 | 279 | 280 | 281 | 282 | {-----------------------------------------------------------------------} 283 | -- an incomplete program is a formal document 284 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | CC0 1.0 Universal 2 | 3 | Statement of Purpose 4 | 5 | The laws of most jurisdictions throughout the world automatically confer 6 | exclusive Copyright and Related Rights (defined below) upon the creator and 7 | subsequent owner(s) (each and all, an "owner") of an original work of 8 | authorship and/or a database (each, a "Work"). 9 | 10 | Certain owners wish to permanently relinquish those rights to a Work for the 11 | purpose of contributing to a commons of creative, cultural and scientific 12 | works ("Commons") that the public can reliably and without fear of later 13 | claims of infringement build upon, modify, incorporate in other works, reuse 14 | and redistribute as freely as possible in any form whatsoever and for any 15 | purposes, including without limitation commercial purposes. These owners may 16 | contribute to the Commons to promote the ideal of a free culture and the 17 | further production of creative, cultural and scientific works, or to gain 18 | reputation or greater distribution for their Work in part through the use and 19 | efforts of others. 20 | 21 | For these and/or other purposes and motivations, and without any expectation 22 | of additional consideration or compensation, the person associating CC0 with a 23 | Work (the "Affirmer"), to the extent that he or she is an owner of Copyright 24 | and Related Rights in the Work, voluntarily elects to apply CC0 to the Work 25 | and publicly distribute the Work under its terms, with knowledge of his or her 26 | Copyright and Related Rights in the Work and the meaning and intended legal 27 | effect of CC0 on those rights. 28 | 29 | 1. Copyright and Related Rights. A Work made available under CC0 may be 30 | protected by copyright and related or neighboring rights ("Copyright and 31 | Related Rights"). Copyright and Related Rights include, but are not limited 32 | to, the following: 33 | 34 | i. the right to reproduce, adapt, distribute, perform, display, communicate, 35 | and translate a Work; 36 | 37 | ii. moral rights retained by the original author(s) and/or performer(s); 38 | 39 | iii. publicity and privacy rights pertaining to a person's image or likeness 40 | depicted in a Work; 41 | 42 | iv. rights protecting against unfair competition in regards to a Work, 43 | subject to the limitations in paragraph 4(a), below; 44 | 45 | v. rights protecting the extraction, dissemination, use and reuse of data in 46 | a Work; 47 | 48 | vi. database rights (such as those arising under Directive 96/9/EC of the 49 | European Parliament and of the Council of 11 March 1996 on the legal 50 | protection of databases, and under any national implementation thereof, 51 | including any amended or successor version of such directive); and 52 | 53 | vii. other similar, equivalent or corresponding rights throughout the world 54 | based on applicable law or treaty, and any national implementations thereof. 55 | 56 | 2. Waiver. To the greatest extent permitted by, but not in contravention of, 57 | applicable law, Affirmer hereby overtly, fully, permanently, irrevocably and 58 | unconditionally waives, abandons, and surrenders all of Affirmer's Copyright 59 | and Related Rights and associated claims and causes of action, whether now 60 | known or unknown (including existing as well as future claims and causes of 61 | action), in the Work (i) in all territories worldwide, (ii) for the maximum 62 | duration provided by applicable law or treaty (including future time 63 | extensions), (iii) in any current or future medium and for any number of 64 | copies, and (iv) for any purpose whatsoever, including without limitation 65 | commercial, advertising or promotional purposes (the "Waiver"). Affirmer makes 66 | the Waiver for the benefit of each member of the public at large and to the 67 | detriment of Affirmer's heirs and successors, fully intending that such Waiver 68 | shall not be subject to revocation, rescission, cancellation, termination, or 69 | any other legal or equitable action to disrupt the quiet enjoyment of the Work 70 | by the public as contemplated by Affirmer's express Statement of Purpose. 71 | 72 | 3. Public License Fallback. Should any part of the Waiver for any reason be 73 | judged legally invalid or ineffective under applicable law, then the Waiver 74 | shall be preserved to the maximum extent permitted taking into account 75 | Affirmer's express Statement of Purpose. In addition, to the extent the Waiver 76 | is so judged Affirmer hereby grants to each affected person a royalty-free, 77 | non transferable, non sublicensable, non exclusive, irrevocable and 78 | unconditional license to exercise Affirmer's Copyright and Related Rights in 79 | the Work (i) in all territories worldwide, (ii) for the maximum duration 80 | provided by applicable law or treaty (including future time extensions), (iii) 81 | in any current or future medium and for any number of copies, and (iv) for any 82 | purpose whatsoever, including without limitation commercial, advertising or 83 | promotional purposes (the "License"). The License shall be deemed effective as 84 | of the date CC0 was applied by Affirmer to the Work. Should any part of the 85 | License for any reason be judged legally invalid or ineffective under 86 | applicable law, such partial invalidity or ineffectiveness shall not 87 | invalidate the remainder of the License, and in such case Affirmer hereby 88 | affirms that he or she will not (i) exercise any of his or her remaining 89 | Copyright and Related Rights in the Work or (ii) assert any associated claims 90 | and causes of action with respect to the Work, in either case contrary to 91 | Affirmer's express Statement of Purpose. 92 | 93 | 4. Limitations and Disclaimers. 94 | 95 | a. No trademark or patent rights held by Affirmer are waived, abandoned, 96 | surrendered, licensed or otherwise affected by this document. 97 | 98 | b. Affirmer offers the Work as-is and makes no representations or warranties 99 | of any kind concerning the Work, express, implied, statutory or otherwise, 100 | including without limitation warranties of title, merchantability, fitness 101 | for a particular purpose, non infringement, or the absence of latent or 102 | other defects, accuracy, or the present or absence of errors, whether or not 103 | discoverable, all to the greatest extent permissible under applicable law. 104 | 105 | c. Affirmer disclaims responsibility for clearing rights of other persons 106 | that may apply to the Work or any use thereof, including without limitation 107 | any person's Copyright and Related Rights in the Work. Further, Affirmer 108 | disclaims responsibility for obtaining any necessary consents, permissions 109 | or other rights required for any use of the Work. 110 | 111 | d. Affirmer understands and acknowledges that Creative Commons is not a 112 | party to this document and has no duty or obligation with respect to this 113 | CC0 or use of the Work. 114 | 115 | For more information, please see 116 | 117 | -------------------------------------------------------------------------------- /Bits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds, KindSignatures, 2 | MultiParamTypeClasses, FunctionalDependencies, 3 | TypeSynonymInstances, FlexibleInstances, 4 | StandaloneDeriving, PatternGuards, PatternSynonyms #-} 5 | 6 | module Bits where 7 | 8 | import Prelude hiding ((/)) 9 | import Control.Monad 10 | import Control.Monad.Reader 11 | 12 | data Stage = Exp ExpStage | Val 13 | data ExpStage = Raw | Normal 14 | data Status = Done | Stuk 15 | 16 | data Syn :: Stage -> Status -> * where 17 | B :: Bool -> Syn s Done 18 | N :: Syn s Done 19 | (:&) :: Syn s Done -> Syn s Done -> Syn s Done 20 | L :: Abst s -> Syn s Done 21 | S :: Syn s Stuk -> Syn s Done 22 | I :: Cached TERM -> Syn (Exp Normal) Done 23 | P :: REF -> Syn s Stuk 24 | (:/) :: Syn s Stuk -> Syn s Done -> Syn s Stuk 25 | V :: Int -> Syn (Exp e) Stuk 26 | (:::) :: TERM -> TERM -> Syn (Exp Raw) Stuk 27 | 28 | data Abst :: Stage -> * where 29 | U :: Syn (Exp e) Done -> Abst (Exp e) 30 | (:.) :: ENV -> Syn (Exp Raw) Done -> Abst Val 31 | 32 | data REF = Name :< Cached TYPE deriving (Show, Eq) 33 | refType :: REF -> TYPE 34 | refType (_ :< s) = cached s 35 | 36 | type VAL = Syn Val Done 37 | type BLK = Syn Val Stuk 38 | type TERM = Syn (Exp Raw) Done 39 | type COMP = Syn (Exp Raw) Stuk 40 | type NORM = Syn (Exp Normal) Done 41 | type NEUT = Syn (Exp Normal) Stuk 42 | type ENV = [VAL] 43 | type TYPE = VAL 44 | 45 | deriving instance Eq (Syn s u) 46 | deriving instance Eq (Abst s) 47 | 48 | deriving instance Show (Syn s u) 49 | deriving instance Show (Abst s) 50 | 51 | newtype Cached x = Cache {cached :: x} 52 | instance Eq (Cached x) where _ == _ = True 53 | instance Show (Cached x) where show _ = "" 54 | 55 | type Name = String 56 | 57 | eval :: ENV -> Syn (Exp Raw) s -> VAL 58 | eval _ (B b) = B b 59 | eval g N = N 60 | eval g (a :& d) = eval g a :& eval g d 61 | eval g (L (U a)) = L (g :. a) 62 | eval g (S e) = eval g e 63 | eval g (P x) = S (P x) 64 | eval g (f :/ s) = eval g f / eval g s 65 | eval g (V i) = g !! i 66 | eval g (t ::: _) = eval g t 67 | 68 | fun :: Abst (Exp Raw) -> Abst Val 69 | fun (U a) = [] :. a 70 | 71 | class Slash f a v | f -> v where 72 | (/) :: f -> a -> v 73 | 74 | instance Slash VAL VAL VAL where 75 | S f / v = S (f :/ v) 76 | L a / v = a / v 77 | (a :& d) / B 0 = a 78 | (a :& d) / B 1 = d 79 | B 0 / Cond a f t = f 80 | B 1 / Cond a f t = t 81 | 82 | instance Slash (Abst Val) VAL VAL where 83 | (g :. t) / v = eval (v : g) t 84 | 85 | instance Slash VAL REF VAL where 86 | f / x = f / (S (P x) :: VAL) 87 | 88 | instance Slash (Abst Val) REF VAL where 89 | f / x = f / (S (P x) :: VAL) 90 | 91 | varOp :: (Int -> Either REF Int -> Maybe (Syn (Exp e) Stuk)) -> 92 | Int -> Syn (Exp e) u -> Syn (Exp e) u 93 | varOp r l (P x) | Just e <- r l (Left x) = e 94 | varOp r l (V i) | Just e <- r l (Right i) = e 95 | varOp r l (L (U a)) = L (U (varOp r (l + 1) a)) 96 | varOp r l (a :& d) = varOp r l a :& varOp r l d 97 | varOp r l (S e) = S (varOp r l e) 98 | varOp r l (f :/ s) = varOp r l f :/ varOp r l s 99 | varOp r l (t ::: y) = varOp r l t ::: varOp r l y 100 | varOp r l t = t 101 | 102 | instantiate :: Syn (Exp Raw) Stuk -> Int -> Either REF Int -> 103 | Maybe (Syn (Exp Raw) Stuk) 104 | instantiate e i (Right j) | i == j = Just e 105 | instantiate _ _ _ = Nothing 106 | 107 | abstract :: REF -> Int -> Either REF Int -> 108 | Maybe (Syn (Exp e) Stuk) 109 | abstract x i (Left y) | x == y = Just (V i) 110 | abstract _ _ _ = Nothing 111 | 112 | instance Slash (Abst (Exp Raw)) (Syn (Exp Raw) Stuk) 113 | (Syn (Exp Raw) Done) where 114 | U a / e = varOp (instantiate e) 0 a 115 | 116 | instance Slash (Abst (Exp Raw)) REF 117 | (Syn (Exp Raw) Done) where 118 | U a / x = varOp (instantiate (P x)) 0 a 119 | 120 | type TC = ReaderT Int Maybe 121 | 122 | class Discharge t a | t -> a, a -> t where 123 | (\\) :: REF -> t -> a 124 | 125 | instance Discharge () () where 126 | _ \\ () = () 127 | 128 | instance Discharge (Syn (Exp e) Done) (Abst (Exp e)) where 129 | x \\ t = U (varOp (abstract x) 0 t) 130 | 131 | (!-) :: Discharge t a => TYPE -> (REF -> TC t) -> TC a 132 | s !- f = do 133 | i <- ask 134 | let x = show i :< Cache s 135 | fmap (x \\) (local succ (f x)) 136 | 137 | pattern TC t = B 0 :& B 0 :& t 138 | pattern Type = TC (B 0 :& B 0 :& N) 139 | pattern Pi s t = TC (B 0 :& B 1 :& B 0 :& s :& L t :& N) 140 | pattern Sg s t = TC (B 0 :& B 1 :& B 1 :& s :& L t :& N) 141 | pattern Bit = TC (B 1 :& B 0 :& B 0 :& N) 142 | 143 | b0V :: VAL 144 | b0V = B 0 145 | b1V :: VAL 146 | b1V = B 1 147 | 148 | pattern Cond a f t = L a :& f :& t :& N 149 | 150 | 151 | quoteV :: TYPE -> VAL -> TC NORM 152 | quoteV Type (Pi s t) = do 153 | s' <- quoteV Type s 154 | t' <- s !- \ x -> quoteV Type (t / x) 155 | return (Pi s' t') 156 | quoteV (Pi s t) f = do 157 | a' <- s !- \ x -> quoteV (t / x) (f / x) 158 | return (L a') 159 | quoteV Type (Sg s t) = do 160 | s' <- quoteV Type s 161 | t' <- s !- \ x -> quoteV Type (t / x) 162 | return (Sg s' t') 163 | quoteV (Sg s t) p = do 164 | let a = p / b0V 165 | a' <- quoteV s a 166 | d' <- quoteV (t / a) (p / b1V) 167 | return (a' :& d') 168 | quoteV Type Bit = return Bit 169 | quoteV Bit (B b) = return (B b) 170 | quoteV _ (S e) = do 171 | (e', _) <- quoteB e 172 | return (S e') 173 | 174 | quoteB :: BLK -> TC (NEUT, TYPE) 175 | quoteB (P x) = return (P x, refType x) 176 | quoteB (f :/ a) = do 177 | (f', y) <- quoteB f 178 | a' <- quoteA y a 179 | return (f' :/ a', actType (S f, y) a) 180 | 181 | quoteA :: TYPE -> VAL -> TC NORM 182 | quoteA (Pi s t) a = quoteV s a 183 | quoteA (Sg s t) (B b) = return (B b) 184 | quoteA Bit (Cond a f t) = do 185 | a' <- Bit !- \ x -> quoteV Type (a / x) 186 | f' <- quoteV (a / b0V) f 187 | t' <- quoteV (a / b1V) t 188 | return (Cond a' f' t') 189 | 190 | checkV :: TYPE -> TERM -> TC VAL 191 | checkV w t = do 192 | check w t 193 | return (eval [] t) 194 | 195 | check :: TYPE -> TERM -> TC () 196 | check Type (Pi s t) = do 197 | s <- checkV Type s 198 | s !- \ x -> check Type (t / x) 199 | check (Pi s t) (L a) = do 200 | s !- \ x -> check (t / x) (a / x) 201 | check Type (Sg s t) = do 202 | s <- checkV Type s 203 | s !- \ x -> check Type (t / x) 204 | check (Sg s t) (a :& d) = do 205 | a <- checkV s a 206 | check (t / a) d 207 | check Type Bit = return () 208 | check Bit (B _) = return () 209 | check w (S e) = do 210 | v <- synth e 211 | v <<== w 212 | 213 | action :: TYPE -> TERM -> TC () 214 | action (Pi s t) a = check s a 215 | action (Sg s t) (B _) = return () 216 | action Bit (Cond a f t) = do 217 | Bit !- \ x -> check Type (a / x) 218 | check (fun a / b0V) f 219 | check (fun a / b1V) t 220 | action _ _ = fail "bad action" 221 | 222 | actType :: (VAL, TYPE) -> VAL -> TYPE 223 | actType (_, Pi s t) a = t / a 224 | actType (_, Sg s t) (B 0) = s 225 | actType (p, Sg s t) (B 1) = t / (p / b0V) 226 | actType (b, Bit) (Cond a f t) = a / b 227 | 228 | actionV :: TYPE -> TERM -> TC VAL 229 | actionV y a = do 230 | action y a 231 | return (eval [] a) 232 | 233 | synth :: COMP -> TC TYPE 234 | synth (P x) = return (refType x) 235 | synth (f :/ a) = do 236 | (f, y) <- synthV f 237 | a <- actionV y a 238 | return (actType (f, y) a) 239 | synth (t ::: y) = do 240 | y <- checkV Type y 241 | check y t 242 | return y 243 | 244 | synthV :: COMP -> TC (VAL, TYPE) 245 | synthV e = do 246 | y <- synth e 247 | return (eval [] e, y) 248 | 249 | (<<==) :: TYPE -> TYPE -> TC () 250 | Pi s t <<== Pi s' t' = do 251 | s' <<== s 252 | s' !- \ x -> (t / x) <<== (t' / x) 253 | Sg s t <<== Pi s' t' = do 254 | s <<== s' 255 | s !- \ x -> (t / x) <<== (t' / x) 256 | Bit <<== Bit = return () 257 | S e <<== S f = do 258 | (e, _) <- quoteB e 259 | (f, _) <- quoteB f 260 | guard (e == f) 261 | _ <<== _ = fail "no fit" 262 | 263 | instance Num Bool where 264 | fromInteger 0 = False 265 | fromInteger _ = True 266 | False + b = b 267 | True + b = not b 268 | True * b = b 269 | False * b = False 270 | abs b = b 271 | negate = not 272 | signum = id 273 | 274 | demand :: TYPE -> TERM -> VAL 275 | demand y t = v where 276 | Just v = runReaderT (checkV y t) 0 277 | 278 | myNotTyRaw :: TERM 279 | myNotTyRaw = Pi Bit (U Bit) 280 | 281 | myNotTy = demand Type myNotTyRaw 282 | 283 | myNotRaw :: TERM 284 | myNotRaw = L (U (S (V 0 :/ Cond (U Bit) (B 1) (B 0)))) 285 | 286 | myNot = demand myNotTy myNotRaw 287 | 288 | -------------------------------------------------------------------------------- /Types4Crib.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF she #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, TypeFamilies, 3 | FlexibleContexts #-} 4 | 5 | {-----------------------------------------------------------------------------} 6 | module 7 | 8 | 9 | 10 | 11 | -- What Are 12 | 13 | Types4 14 | 15 | -- Or Are They Only Against? 16 | 17 | 18 | 19 | -- I am Conor McBride 20 | 21 | -- and the Mathematically Structured Programming group 22 | -- at the University of Strathclyde, Glasgow, Scotland 23 | -- is 24 | 25 | where -- I come from. 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | import Data.Char 37 | import Data.Monoid 38 | import Control.Applicative 39 | import Data.Traversable 40 | 41 | 42 | {-----------------------------------------------------------------------} 43 | -- a parser for things is... (Fritz Ruehr) 44 | 45 | newtype P thing = P {parse :: String -> [(thing, String)]} deriving Monoid 46 | 47 | instance Monad P where 48 | return x = P $ \ s -> return (x, s) 49 | P pa >>= k = P $ \ s -> do 50 | (x, s) <- pa s 51 | parse (k x) s 52 | 53 | instance Alternative P where -- (what if P used Maybe?) 54 | empty = mempty 55 | (<|>) = mappend 56 | 57 | eat :: (Char -> Bool) -> P Char 58 | eat p = P $ \ s -> case s of 59 | c : s | p c -> [(c, s)] 60 | _ -> [] 61 | 62 | type Cell = Maybe Int 63 | 64 | pcell :: P Cell 65 | pcell = many (eat isSpace) *> 66 | (|Just (|read (|eat isDigit : (|[]|)|)|) 67 | |Nothing (- eat (=='.')-) 68 | |) 69 | 70 | 71 | 72 | 73 | 74 | {---------------------------------------------------------------------} 75 | -- the functor kit 76 | 77 | newtype I x = I x deriving Show 78 | newtype K a x = K a deriving Show 79 | data (f :*: g) x = f x :*: g x deriving Show 80 | data (f :+: g) x = L (f x) | R (g x) deriving Show 81 | newtype (f :.: g) x = C {unC :: f (g x)} deriving Show 82 | 83 | 84 | instance Applicative I where 85 | pure = I 86 | I f <*> I s = I (f s) 87 | 88 | instance (Applicative f, Applicative g) => Applicative (f :*: g) where 89 | hiding instance Functor 90 | pure x = pure x :*: pure x 91 | (ff :*: gf) <*> (fs :*: gs) = (ff <*> fs) :*: (gf <*> gs) 92 | 93 | instance (Applicative f, Applicative g) => Applicative (f :.: g) where 94 | hiding instance Functor 95 | pure x = C (|(|x|)|) 96 | C fgf <*> C fgs = C (|fgf <*> fgs|) 97 | 98 | instance Monoid a => Applicative (K a) where 99 | hiding instance Functor 100 | pure x = K mempty 101 | K f <*> K s = K (mappend f s) 102 | 103 | -- boring Functor and Traversable instances are elsewhere 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | instance Traversable (K a) where 116 | traverse f (K a) = (|(K a)|) 117 | instance Traversable I where 118 | hiding instance Functor 119 | traverse f (I x) = (|I (f x)|) 120 | instance (Functor f, Functor g) => Functor (f :*: g) where 121 | fmap k (fx :*: gx) = fmap k fx :*: fmap k gx 122 | instance (Traversable f, Traversable g) => Traversable (f :*: g) where 123 | hiding instance Functor 124 | traverse k (fx :*: gx) = (|traverse k fx :*: traverse k gx|) 125 | instance (Functor f, Functor g) => Functor (f :+: g) where 126 | fmap k (L fx) = L (fmap k fx) 127 | fmap k (R gx) = R (fmap k gx) 128 | instance (Traversable f, Traversable g) => Traversable (f :+: g) where 129 | hiding instance Functor 130 | traverse k (L fx) = (|L (traverse k fx)|) 131 | traverse k (R gx) = (|R (traverse k gx)|) 132 | instance (Functor f, Functor g) => Functor (f :.: g) where 133 | fmap k (C fgx) = C (fmap (fmap k) fgx) 134 | instance (Traversable f, Traversable g) => Traversable (f :.: g) where 135 | hiding instance Functor 136 | traverse k (C fgx) = (|C (traverse (traverse k) fgx)|) 137 | 138 | {---------------------------------------------------------------------} 139 | -- triples of triples, and their transposes 140 | 141 | type Triple = I :*: I :*: I 142 | 143 | pattern Tr a b c = I a :*: I b :*: I c 144 | 145 | type Zone = Triple :.: Triple 146 | 147 | czone :: Zone Char 148 | czone = C (Tr (Tr 'a' 'b' 'c') (Tr 'd' 'e' 'f') (Tr 'g' 'h' 'i')) 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | {---------------------------------------------------------------------} 162 | -- Newtype piggery-jokery 163 | 164 | class Newtype new where 165 | type Old new 166 | pack :: Old new -> new 167 | unpack :: new -> Old new 168 | 169 | newly :: (Newtype a, Newtype b) => (Old a -> Old b) -> a -> b 170 | newly f = pack . f . unpack 171 | 172 | ala :: (Newtype b, Newtype d) => ((a -> b) -> c -> d) -> (Old b -> b) 173 | -> (a -> Old b) -> c -> Old d 174 | ala hof _ f = unpack . hof (pack . f) 175 | 176 | infixl `ala` 177 | 178 | instance Newtype ((f :.: g) x) where 179 | type Old ((f :.: g) x) = f (g x) 180 | pack = C 181 | unpack = unC 182 | 183 | instance Newtype (Const a x) where 184 | type Old (Const a x) = a 185 | pack = Const 186 | unpack = getConst 187 | 188 | instance Newtype (I x) where 189 | type Old (I x) = x 190 | pack = I 191 | unpack (I x) = x 192 | 193 | instance Newtype (Product a) where 194 | type Old (Product a) = a 195 | pack = Product 196 | unpack = getProduct 197 | 198 | instance Newtype (Sum a) where 199 | type Old (Sum a) = a 200 | pack = Sum 201 | unpack = getSum 202 | 203 | instance Newtype Any where 204 | type Old Any = Bool 205 | pack = Any 206 | unpack = getAny 207 | 208 | instance Newtype All where 209 | type Old All = Bool 210 | pack = All 211 | unpack = getAll 212 | 213 | 214 | 215 | {-----------------------------------------------------------------------} 216 | -- sudoku boards 217 | 218 | type Board = Zone :.: Zone 219 | 220 | pboard :: P (Board Cell) 221 | pboard = sequenceA (pure pcell) 222 | 223 | tryThis :: String 224 | tryThis = unlines 225 | ["...23.6.." 226 | ,"1.......7" 227 | ,".4...518." 228 | ,"5.....9.." 229 | ,"..73.68.." 230 | ,"..4.....5" 231 | ,".867...5." 232 | ,"4.......9" 233 | ,"..3.62..." 234 | ] 235 | 236 | xpBoard :: Board Cell -> Board Cell 237 | xpBoard = newly sequenceA 238 | 239 | boxBoard :: Board Cell -> Board Cell 240 | boxBoard = newly (fmap C . newly (fmap sequenceA) . fmap unC) 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | {---------------------------------------------------------------------------} 261 | -- Milner's coincidence (0) 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 | -- Milner's coincidence (1) 291 | 292 | 293 | 294 | 295 | 296 | 297 | -- terms versus types 298 | 299 | 300 | 301 | 302 | 303 | 304 | 305 | 306 | 307 | 308 | 309 | 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | {---------------------------------------------------------------------------} 319 | -- Milner's coincidence (2) 320 | 321 | 322 | 323 | 324 | 325 | 326 | -- terms versus types 327 | -- written versus inferred 328 | 329 | 330 | 331 | 332 | 333 | -- but sometimes you write types (e.g. to resolve ambiguity) 334 | -- and sometimes the compiler infers terms (instance dictionaries) 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | 344 | 345 | 346 | 347 | 348 | {---------------------------------------------------------------------------} 349 | -- Milner's coincidence (3) 350 | 351 | 352 | 353 | 354 | 355 | 356 | -- terms versus types 357 | -- written versus inferred 358 | -- explicit versus invisible 359 | 360 | 361 | 362 | 363 | -- are the things you read in the program text always written by you? 364 | -- what if you could have mechanical help? 365 | 366 | 367 | 368 | 369 | 370 | 371 | 372 | 373 | 374 | 375 | 376 | 377 | 378 | {---------------------------------------------------------------------------} 379 | -- Milner's coincidence (4.0) 380 | 381 | 382 | 383 | 384 | 385 | 386 | -- terms versus types 387 | -- written versus inferred 388 | -- explicit versus invisible 389 | -- runtime versus erasable 390 | 391 | 392 | 393 | 394 | -- datakinds give us term-like stuff in erasable things 395 | -- Data.Typeable gives us type representations you can match on at runtime 396 | 397 | 398 | 399 | 400 | 401 | 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | {---------------------------------------------------------------------------} 412 | -- Milner's coincidence (4.1) 413 | 414 | 415 | 416 | 417 | 418 | 419 | -- terms versus types 420 | -- written versus inferred 421 | -- explicit versus invisible 422 | -- runtime versus erasable 423 | 424 | 425 | 426 | 427 | -- datakinds give us term-like stuff in erasable things 428 | -- Data.Typeable gives us type representations you can match on at runtime 429 | 430 | -- I claim that terms-versus-types and runtime-versus-erasable are 431 | -- orthogonal 432 | 433 | 434 | 435 | 436 | 437 | 438 | 439 | 440 | 441 | 442 | 443 | 444 | {---------------------------------------------------------------------------} 445 | -- Milner's coincidence (4.2) 446 | 447 | 448 | 449 | 450 | 451 | 452 | -- terms versus types 453 | -- written versus inferred 454 | -- explicit versus invisible 455 | -- runtime versus erasable 456 | 457 | 458 | 459 | 460 | -- datakinds give us term-like stuff in erasable things 461 | -- Data.Typeable gives us type representations you can match on at runtime 462 | 463 | -- I claim that terms-versus-types and runtime-versus-erasable are 464 | -- orthogonal 465 | 466 | -- Also, I like to write types and get repaid with invisible runtime code 467 | 468 | 469 | 470 | 471 | 472 | 473 | 474 | 475 | 476 | 477 | {---------------------------------------------------------------------------} 478 | -- Milner's coincidence (5.0) 479 | 480 | 481 | 482 | 483 | 484 | 485 | -- terms versus types 486 | -- written versus inferred 487 | -- explicit versus invisible 488 | -- runtime versus compile time 489 | -- -> versus forall 490 | 491 | 492 | 493 | 494 | -- given what people fake up with "singletons" and "proxies", it's clear that 495 | -- more than one quantifier is convenient 496 | 497 | 498 | 499 | 500 | 501 | 502 | 503 | 504 | 505 | 506 | 507 | {---------------------------------------------------------------------------} 508 | -- Milner's coincidence (5.1) 509 | 510 | 511 | 512 | 513 | 514 | 515 | -- terms versus types 516 | -- written versus inferred 517 | -- explicit versus invisible 518 | -- runtime versus erasable 519 | -- -> versus forall 520 | 521 | 522 | 523 | 524 | -- given what people fake up with "singletons" and "proxies", it's clear that 525 | -- more than one quantifier is convenient 526 | 527 | -- I'm trying to convince the Haskellers to let types depend on runtime values 528 | -- and the dependently typed programmers to let types depend on erasable values 529 | 530 | 531 | 532 | 533 | 534 | 535 | 536 | 537 | 538 | 539 | {---------------------------------------------------------------------------} 540 | -- Milner's coincidence (6) 541 | 542 | 543 | 544 | 545 | 546 | 547 | -- terms versus types 548 | -- written versus inferred 549 | -- explicit versus invisible 550 | -- runtime versus compile time 551 | -- -> versus forall 552 | -- input versus output 553 | 554 | 555 | 556 | 557 | 558 | -- but the biggest questionable assumption is that we're working in batch mode 559 | 560 | 561 | 562 | 563 | 564 | 565 | 566 | 567 | 568 | 569 | 570 | 571 | 572 | 573 | {---------------------------------------------------------------------------} 574 | -- what if...? 575 | 576 | 577 | 578 | 579 | -- what if types were a key *input* to the program construction process? 580 | 581 | -- let me show you what if 582 | 583 | 584 | 585 | 586 | 587 | 588 | 589 | 590 | 591 | 592 | 593 | 594 | 595 | 596 | 597 | 598 | 599 | 600 | 601 | 602 | 603 | {------------------------------------------------------------------------} 604 | -- a stray monoid instance, should it prove useful 605 | 606 | instance Monoid x => Monoid (IO x) where 607 | mempty = (|mempty|) 608 | mappend x y = (|mappend x y|) 609 | -------------------------------------------------------------------------------- /Types4.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF she #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, TypeFamilies, 3 | FlexibleContexts #-} 4 | 5 | {-----------------------------------------------------------------------------} 6 | module 7 | 8 | 9 | 10 | 11 | -- What Are 12 | 13 | Types4 14 | 15 | -- Or Are They Only Against? 16 | 17 | 18 | 19 | -- I am Conor McBride 20 | 21 | -- and the Mathematically Structured Programming group 22 | -- at the University of Strathclyde, Glasgow, Scotland 23 | -- is 24 | 25 | where -- I come from. 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | import Data.Char 37 | import Data.Monoid 38 | import Control.Applicative 39 | import Data.Traversable 40 | 41 | 42 | {-----------------------------------------------------------------------} 43 | -- a parser for things is... (Fritz Ruehr) 44 | 45 | newtype P thing = P {parse :: String -> [(thing, String)]} deriving Monoid 46 | 47 | instance Monad P where 48 | return x = P $ \ s -> [(x, s)] 49 | P af >>= k = P $ \ s -> do 50 | (a, s) <- af s 51 | parse (k a) s 52 | 53 | instance Alternative P where -- (what if P used Maybe?) 54 | empty = mempty 55 | (<|>) = mappend 56 | 57 | eat :: (Char -> Bool) -> P Char 58 | eat p = P $ \ s -> case s of 59 | (c : s) | p c -> [(c, s)] 60 | _ -> [] 61 | 62 | type Cell = Maybe Int 63 | 64 | pcell :: P Cell 65 | pcell = many (eat isSpace) *> 66 | (|Just (|read (|eat isDigit : (|[]|)|)|) 67 | |Nothing (-eat (=='.')-) 68 | |) 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | {---------------------------------------------------------------------} 81 | -- the functor kit 82 | 83 | newtype I x = I x deriving Show 84 | newtype K a x = K a deriving Show 85 | data (f :*: g) x = f x :*: g x deriving Show 86 | data (f :+: g) x = L (f x) | R (g x) deriving Show 87 | newtype (f :.: g) x = C {unC :: f (g x)} deriving Show 88 | 89 | 90 | instance Applicative I where 91 | pure = I 92 | I f <*> I s = I (f s) 93 | 94 | instance (Applicative f, Applicative g) => Applicative (f :*: g) where 95 | hiding instance Functor 96 | pure x = pure x :*: pure x 97 | (ff :*: gf) <*> (fs :*: gs) = (ff <*> fs) :*: (gf <*> gs) 98 | 99 | instance (Applicative f, Applicative g) => Applicative (f :.: g) where 100 | hiding instance Functor 101 | pure x = C (|(|x|)|) 102 | C fgf <*> C fgs = C (|fgf <*> fgs|) 103 | 104 | instance Monoid a => Applicative (K a) where 105 | hiding instance Functor 106 | pure x = K mempty 107 | K f <*> K s = K (mappend f s) 108 | 109 | -- boring Functor and Traversable instances are elsewhere 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | instance Traversable (K a) where 122 | traverse f (K a) = (|(K a)|) 123 | instance Traversable I where 124 | hiding instance Functor 125 | traverse f (I x) = (|I (f x)|) 126 | instance (Functor f, Functor g) => Functor (f :*: g) where 127 | fmap k (fx :*: gx) = fmap k fx :*: fmap k gx 128 | instance (Traversable f, Traversable g) => Traversable (f :*: g) where 129 | hiding instance Functor 130 | traverse k (fx :*: gx) = (|traverse k fx :*: traverse k gx|) 131 | instance (Functor f, Functor g) => Functor (f :+: g) where 132 | fmap k (L fx) = L (fmap k fx) 133 | fmap k (R gx) = R (fmap k gx) 134 | instance (Traversable f, Traversable g) => Traversable (f :+: g) where 135 | hiding instance Functor 136 | traverse k (L fx) = (|L (traverse k fx)|) 137 | traverse k (R gx) = (|R (traverse k gx)|) 138 | instance (Functor f, Functor g) => Functor (f :.: g) where 139 | fmap k (C fgx) = C (fmap (fmap k) fgx) 140 | instance (Traversable f, Traversable g) => Traversable (f :.: g) where 141 | hiding instance Functor 142 | traverse k (C fgx) = (|C (traverse (traverse k) fgx)|) 143 | 144 | {---------------------------------------------------------------------} 145 | -- triples of triples, and their transposes 146 | 147 | type Triple = I :*: I :*: I 148 | 149 | pattern Tr a b c = I a :*: I b :*: I c 150 | 151 | type Zone = Triple :.: Triple 152 | 153 | -- what's for free? 154 | 155 | zone :: Zone Char 156 | zone = C (Tr (Tr 'a' 'b' 'c') (Tr 'd' 'e' 'f') (Tr 'g' 'h' 'i')) 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | {---------------------------------------------------------------------} 174 | -- Newtype piggery-jokery 175 | 176 | class Newtype new where 177 | type Old new 178 | pack :: Old new -> new 179 | unpack :: new -> Old new 180 | 181 | newly :: (Newtype a, Newtype b) => (Old a -> Old b) -> a -> b 182 | newly f = pack . f . unpack 183 | 184 | ala :: (Newtype b, Newtype d) => ((a -> b) -> c -> d) -> (Old b -> b) 185 | -> (a -> Old b) -> c -> Old d 186 | ala hof _ f = unpack . hof (pack . f) 187 | 188 | infixl `ala` 189 | 190 | instance Newtype ((f :.: g) x) where 191 | type Old ((f :.: g) x) = f (g x) 192 | pack = C 193 | unpack = unC 194 | 195 | instance Newtype (K a x) where 196 | type Old (K a x) = a 197 | pack = K 198 | unpack (K a) = a 199 | 200 | instance Newtype (I x) where 201 | type Old (I x) = x 202 | pack = I 203 | unpack (I x) = x 204 | 205 | instance Newtype (Product a) where 206 | type Old (Product a) = a 207 | pack = Product 208 | unpack = getProduct 209 | 210 | instance Newtype (Sum a) where 211 | type Old (Sum a) = a 212 | pack = Sum 213 | unpack = getSum 214 | 215 | instance Newtype Any where 216 | type Old Any = Bool 217 | pack = Any 218 | unpack = getAny 219 | 220 | instance Newtype All where 221 | type Old All = Bool 222 | pack = All 223 | unpack = getAll 224 | 225 | 226 | 227 | {-----------------------------------------------------------------------} 228 | -- sudoku boards 229 | 230 | type Board = Zone :.: Zone 231 | 232 | pboard :: P (Board Cell) 233 | pboard = sequenceA (pure pcell) 234 | 235 | tryThis :: String 236 | tryThis = unlines 237 | ["...23.6.." 238 | ,"1.......7" 239 | ,".4...518." 240 | ,"5.....9.." 241 | ,"..73.68.." 242 | ,"..4.....5" 243 | ,".867...5." 244 | ,"4.......9" 245 | ,"..3.62..." 246 | ] 247 | 248 | xpBoard :: Board Cell -> Board Cell 249 | xpBoard = newly sequenceA 250 | 251 | boxBoard :: Board Cell -> Board Cell 252 | boxBoard = newly (fmap C . newly (fmap sequenceA) . fmap unC) 253 | 254 | -- where is the program? 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | 266 | 267 | 268 | 269 | 270 | 271 | 272 | {---------------------------------------------------------------------------} 273 | -- Milner's coincidence (0) 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 | -- Milner's coincidence (1) 303 | 304 | 305 | 306 | 307 | 308 | 309 | -- terms versus types 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | 319 | 320 | 321 | 322 | 323 | 324 | 325 | 326 | 327 | 328 | 329 | 330 | {---------------------------------------------------------------------------} 331 | -- Milner's coincidence (2) 332 | 333 | 334 | 335 | 336 | 337 | 338 | -- terms versus types 339 | -- written versus inferred 340 | 341 | 342 | 343 | 344 | 345 | -- but sometimes you write types (e.g. to resolve ambiguity) 346 | -- and sometimes the compiler infers terms (instance dictionaries) 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | 359 | 360 | {---------------------------------------------------------------------------} 361 | -- Milner's coincidence (3) 362 | 363 | 364 | 365 | 366 | 367 | 368 | -- terms versus types 369 | -- written versus inferred 370 | -- explicit versus invisible 371 | 372 | 373 | 374 | 375 | -- are the things you read in the program text always written by you? 376 | -- what if you could have mechanical help? 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | 385 | 386 | 387 | 388 | 389 | 390 | {---------------------------------------------------------------------------} 391 | -- Milner's coincidence (4.0) 392 | 393 | 394 | 395 | 396 | 397 | 398 | -- terms versus types 399 | -- written versus inferred 400 | -- explicit versus invisible 401 | -- runtime versus erasable 402 | 403 | 404 | 405 | 406 | -- datakinds give us term-like stuff in erasable things 407 | -- Data.Typeable gives us type representations you can match on at runtime 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | {---------------------------------------------------------------------------} 424 | -- Milner's coincidence (4.1) 425 | 426 | 427 | 428 | 429 | 430 | 431 | -- terms versus types 432 | -- written versus inferred 433 | -- explicit versus invisible 434 | -- runtime versus erasable 435 | 436 | 437 | 438 | 439 | -- datakinds give us term-like stuff in erasable things 440 | -- Data.Typeable gives us type representations you can match on at runtime 441 | 442 | -- I claim that terms-versus-types and runtime-versus-erasable are 443 | -- orthogonal 444 | 445 | 446 | 447 | 448 | 449 | 450 | 451 | 452 | 453 | 454 | 455 | 456 | {---------------------------------------------------------------------------} 457 | -- Milner's coincidence (4.2) 458 | 459 | 460 | 461 | 462 | 463 | 464 | -- terms versus types 465 | -- written versus inferred 466 | -- explicit versus invisible 467 | -- runtime versus erasable 468 | 469 | 470 | 471 | 472 | -- datakinds give us term-like stuff in erasable things 473 | -- Data.Typeable gives us type representations you can match on at runtime 474 | 475 | -- I claim that terms-versus-types and runtime-versus-erasable are 476 | -- orthogonal 477 | 478 | -- Also, I like to write types and get repaid with invisible runtime code 479 | 480 | 481 | 482 | 483 | 484 | 485 | 486 | 487 | 488 | 489 | {---------------------------------------------------------------------------} 490 | -- Milner's coincidence (5.0) 491 | 492 | 493 | 494 | 495 | 496 | 497 | -- terms versus types 498 | -- written versus inferred 499 | -- explicit versus invisible 500 | -- runtime versus compile time 501 | -- -> versus forall 502 | 503 | 504 | 505 | 506 | -- given what people fake up with "singletons" and "proxies", it's clear that 507 | -- more than one quantifier is convenient 508 | 509 | 510 | 511 | 512 | 513 | 514 | 515 | 516 | 517 | 518 | 519 | {---------------------------------------------------------------------------} 520 | -- Milner's coincidence (5.1) 521 | 522 | 523 | 524 | 525 | 526 | 527 | -- terms versus types 528 | -- written versus inferred 529 | -- explicit versus invisible 530 | -- runtime versus erasable 531 | -- -> versus forall 532 | 533 | 534 | 535 | 536 | -- given what people fake up with "singletons" and "proxies", it's clear that 537 | -- more than one quantifier is convenient 538 | 539 | -- I'm trying to convince the Haskellers to let types depend on runtime values 540 | -- and the dependently typed programmers to let types depend on erasable values 541 | 542 | 543 | 544 | 545 | 546 | 547 | 548 | 549 | 550 | 551 | {---------------------------------------------------------------------------} 552 | -- Milner's coincidence (6) 553 | 554 | 555 | 556 | 557 | 558 | 559 | -- terms versus types 560 | -- written versus inferred 561 | -- explicit versus invisible 562 | -- runtime versus compile time 563 | -- -> versus forall 564 | -- input versus output 565 | 566 | 567 | 568 | 569 | 570 | -- but the biggest questionable assumption is that we're working in batch mode 571 | 572 | 573 | 574 | 575 | 576 | 577 | 578 | 579 | 580 | 581 | 582 | 583 | 584 | 585 | {---------------------------------------------------------------------------} 586 | -- what if...? 587 | 588 | 589 | 590 | 591 | -- what if types were a key *input* to the program construction process? 592 | 593 | -- let me show you what if 594 | 595 | 596 | 597 | 598 | 599 | 600 | 601 | 602 | 603 | 604 | 605 | 606 | 607 | 608 | 609 | 610 | 611 | 612 | 613 | 614 | 615 | {------------------------------------------------------------------------} 616 | -- a stray monoid instance, should it prove useful 617 | 618 | instance Monoid x => Monoid (IO x) where 619 | mempty = (|mempty|) 620 | mappend x y = (|mappend x y|) 621 | --------------------------------------------------------------------------------