├── .gitignore ├── Box ├── .gitignore ├── ANSIEscapes.hs ├── Box.hs ├── Boxy.hs ├── CharBox.hs ├── Cursor.hs ├── Edit.hs ├── Makefile ├── ManualNat.hs ├── Nat.hs ├── SingNat.hs ├── Vec.hs └── Wrap.hs ├── Free ├── FreeApplicative.hs ├── FreeApplicative0.hs ├── FreeArrow.hs └── FreeArrow0.hs ├── Hasochism ├── ANSIEscapes.hs ├── BoxPain.lhs ├── BoxPleasure.lhs ├── Editor.lhs ├── Evidence.lhs ├── Existentials.lhs ├── Irr.agda ├── Makefile ├── MergeSort.lhs ├── NATTYInNatty.lhs ├── NatVec.lhs ├── Pics │ ├── hasochism1.jpg │ ├── hasochism2.jpg │ ├── hasochism3.jpg │ └── hasochism4.jpg ├── Pies.lhs ├── hasochism.bib ├── hasochism.lhs ├── sigplanconf.cls └── talks │ └── haskell2013 │ ├── Makefile │ ├── hasochism.lhs │ └── mathpartir.sty ├── OldBox ├── ANSIEscapes.hs ├── Box.hs ├── CharBox.hs ├── Cursor.hs ├── Edit.hs ├── Makefile └── PlainCursor.hs ├── PlainBox ├── ANSIEscapes.hs ├── Box.hs ├── CharBox.hs ├── Cursor.hs ├── Edit.hs └── Makefile └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | -------------------------------------------------------------------------------- /Box/.gitignore: -------------------------------------------------------------------------------- 1 | *.o *.hi edit 2 | 3 | -------------------------------------------------------------------------------- /Box/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module ANSIEscapes 2 | (upLine, 3 | downLine, 4 | up, 5 | down, 6 | forward, 7 | backward, 8 | killLine, 9 | restoreCursor, 10 | saveCursor, 11 | clearScreen, 12 | yellow, 13 | brown, 14 | red, 15 | blue, 16 | purple, 17 | green, 18 | orange, 19 | white, 20 | yellowOnGrey, 21 | brownOnGrey, 22 | redOnGrey, 23 | blueOnGrey, 24 | purpleOnGrey, 25 | greenOnGrey, 26 | whiteOnGrey, 27 | onBlack, 28 | onGrey, 29 | onGreyEsc, 30 | onWhiteEsc, 31 | resetCursor, 32 | initTermSize) where 33 | 34 | data Dir = UpDir | DownDir | RightDir | LeftDir 35 | 36 | instance Show Dir where 37 | show UpDir = "A" 38 | show DownDir = "B" 39 | show RightDir = "C" 40 | show LeftDir = "D" 41 | 42 | upLine = putStr "\ESC[1A" 43 | downLine = putStr "\ESC[1B" 44 | 45 | up = moveCursor UpDir 46 | down = moveCursor DownDir 47 | backward = moveCursor LeftDir 48 | forward = moveCursor RightDir 49 | 50 | moveCursor :: Dir -> Int -> IO () 51 | moveCursor dir 0 = return () 52 | moveCursor dir n = putStr $ "\ESC[" ++ show n ++ show dir 53 | 54 | killLine = escape "K" 55 | restoreCursor = escape "u" 56 | saveCursor = escape "s" 57 | clearScreen = escape "2J" 58 | initTermSize = (escape "[=3h") 59 | 60 | resetCursor = escape "0;0H" 61 | 62 | escape e = putStr $ "\ESC[" ++ e 63 | 64 | yellow str = "\ESC[1;33m" ++ str ++ "\ESC[0m" 65 | brown str = "\ESC[0;33m" ++ str ++ "\ESC[0m" 66 | blue str = "\ESC[1;34m" ++ str ++ "\ESC[0m" 67 | red str = "\ESC[1;31m" ++ str ++ "\ESC[0m" 68 | green str = "\ESC[1;32m" ++ str ++ "\ESC[0m" 69 | purple str = "\ESC[1;35m" ++ str ++ "\ESC[0m" 70 | white str = "\ESC[37m" ++ str ++ "\ESC[0m" 71 | 72 | 73 | 74 | --Be careful, these assume someone else will reset the background colour 75 | yellowOnGrey str = "\ESC[1;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 76 | brownOnGrey str = "\ESC[0;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 77 | blueOnGrey str = "\ESC[1;34m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 78 | redOnGrey str = "\ESC[1;31m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 79 | greenOnGrey str = "\ESC[1;32m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 80 | purpleOnGrey str = "\ESC[1;35m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 81 | whiteOnGrey str = "\ESC[37m" ++ str ++ "\ESC[0m" 82 | 83 | onBlack str = "\ESC[40m" ++ str ++ "\ESC[0m" 84 | onGrey str = onGreyEsc ++ str ++ onWhiteEsc 85 | onGreyEsc = "\ESC[47m" 86 | onWhiteEsc = "\ESC[0m" 87 | orange str = str -------------------------------------------------------------------------------- /Box/Box.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds, PolyKinds, 3 | RankNTypes, GADTs, TypeOperators, FlexibleInstances #-} 4 | 5 | module Box where 6 | 7 | import Data.Monoid 8 | import Control.Applicative 9 | import Data.Foldable 10 | 11 | import Nat 12 | import Vec 13 | 14 | data Box :: ((Nat, Nat) -> *) -> (Nat, Nat) -> * where 15 | Stuff :: p wh -> Box p wh 16 | Clear :: Box p wh 17 | Hor :: Natty w1 -> Box p '(w1, h) -> Natty w2 -> Box p '(w2, h) -> Box p '(w1 :+ w2, h) 18 | Ver :: Natty h1 -> Box p '(w, h1) -> Natty h2 -> Box p '(w, h2) -> Box p '(w, h1 :+ h2) 19 | 20 | type s :-> t = forall i. s i -> t i 21 | 22 | ebox :: (p :-> Box q) -> Box p :-> Box q 23 | ebox f (Stuff c) = f c 24 | ebox f Clear = Clear 25 | ebox f (Hor w1 b1 w2 b2) = Hor w1 (ebox f b1) w2 (ebox f b2) 26 | ebox f (Ver h1 b1 h2 b2) = Ver h1 (ebox f b1) h2 (ebox f b2) 27 | 28 | class Cut (p :: (Nat, Nat) -> *) where 29 | horCut :: Natty m -> Natty n -> 30 | p '(m :+ n, h) -> (p '(m, h), p '(n, h)) 31 | verCut :: Natty m -> Natty n -> 32 | p '(w, m :+ n) -> (p '(w, m), p '(w, n)) 33 | 34 | instance Cut p => Cut (Box p) where 35 | horCut m n (Stuff p) = (Stuff p1, Stuff p2) 36 | where (p1, p2) = horCut m n p 37 | horCut m n Clear = (Clear, Clear) 38 | horCut m n (Hor w1 b1 w2 b2) = 39 | case cmpCuts m n w1 w2 of 40 | LTCuts z -> let (b11, b12) = horCut m (SS z) b1 41 | in (b11, Hor (SS z) b12 w2 b2) 42 | EQCuts -> (b1, b2) 43 | GTCuts z -> let (b21, b22) = horCut (SS z) n b2 44 | in (Hor w1 b1 (SS z) b21, b22) 45 | horCut m n (Ver h1 b1 h2 b2) = 46 | (Ver h1 b11 h2 b21, Ver h1 b12 h2 b22) 47 | where (b11, b12) = horCut m n b1 48 | (b21, b22) = horCut m n b2 49 | 50 | verCut m n (Stuff p) = (Stuff p1, Stuff p2) 51 | where (p1, p2) = verCut m n p 52 | verCut m n Clear = (Clear, Clear) 53 | verCut m n (Ver h1 b1 h2 b2) = 54 | case cmpCuts m n h1 h2 of 55 | LTCuts z -> let (b11, b12) = verCut m (SS z) b1 56 | in (b11, Ver (SS z) b12 h2 b2) 57 | EQCuts -> (b1, b2) 58 | GTCuts z -> let (b21, b22) = verCut (SS z) n b2 59 | in (Ver h1 b1 (SS z) b21, b22) 60 | verCut m n (Hor w1 b1 w2 b2) = 61 | (Hor w1 b11 w2 b21, Hor w1 b12 w2 b22) 62 | where (b11, b12) = verCut m n b1 63 | (b21, b22) = verCut m n b2 64 | 65 | instance Cut p => Monoid (Box p wh) where 66 | mempty = Clear 67 | mappend b Clear = b 68 | mappend Clear b' = b' 69 | mappend b@(Stuff _) _ = b 70 | mappend (Hor w1 b1 w2 b2) b' = Hor w1 (mappend b1 b1') w2 (mappend b2 b2') 71 | where (b1', b2') = horCut w1 w2 b' 72 | mappend (Ver h1 b1 h2 b2) b' = Ver h1 (mappend b1 b1') h2 (mappend b2 b2') 73 | where (b1', b2') = verCut h1 h2 b' 74 | 75 | data Matrix :: * -> (Nat, Nat) -> * where 76 | Mat :: Vec y (Vec x a) -> Matrix a '(x, y) 77 | 78 | instance Show a => Show (Matrix a '(x, y)) where 79 | show = show . (foldMap ((:[]) . foldMap (:[]))) . unMat 80 | 81 | unMat :: Matrix a '(x,y) -> Vec y (Vec x a) 82 | unMat (Mat m) = m 83 | 84 | instance Cut (Matrix e) where 85 | horCut m n (Mat ess) = 86 | (Mat (fst <$> ps), Mat (snd <$> ps)) where 87 | ps = vchop m <$> ess 88 | verCut m n (Mat ess) = (Mat tess, Mat bess) where 89 | (tess, bess) = vchop m ess 90 | 91 | {- smart constructors for clear boxes -} 92 | clear :: (Natty w, Natty h) -> Box p '(w, h) 93 | clear (x, y) = Clear 94 | 95 | emptyBox :: Box p '(Z, Z) 96 | emptyBox = Clear 97 | 98 | hGap :: Natty w -> Box p '(w, Z) 99 | hGap _ = Clear 100 | 101 | vGap :: Natty h -> Box p '(Z, h) 102 | vGap _ = Clear 103 | 104 | {- placing boxes -} 105 | 106 | {- 107 | --- lemmas about max --- 108 | 109 | -- we wire this knowledge into the Cmp datatype 110 | 111 | maxAddR :: forall x y z t.Natty x -> Natty y -> ((Max x (x :+ S y) ~ (x :+ S y)) => t) -> t 112 | maxAddR SZ y t = t 113 | maxAddR (SS x) y t = maxAddR x y t 114 | 115 | maxAddL :: forall x y z t.Natty x -> Natty y -> ((Max (x :+ S y) x ~ (x :+ S y)) => t) -> t 116 | maxAddL x y t = maxAddR x y (maxSym x (x /+/ SS y) t) 117 | 118 | maxRefl :: forall x y t.Natty x -> ((Max x x ~ x) => t) -> t 119 | maxRefl SZ t = t 120 | maxRefl (SS x) t = maxRefl x t 121 | 122 | maxSym :: forall x y t.Natty x -> Natty y -> ((Max x y ~ Max y x) => t) -> t 123 | maxSym SZ SZ t = t 124 | maxSym SZ (SS y) t = t 125 | maxSym (SS x) SZ t = t 126 | maxSym (SS x) (SS y) t = maxSym x y t 127 | ------------------------ 128 | -} 129 | 130 | -- place boxes horizontally 131 | joinH :: (Natty w1, Natty h1) -> (Natty w2, Natty h2) -> 132 | Box p '(w1, h1) -> Box p '(w2, h2) -> Box p '(w1 :+ w2, Max h1 h2) 133 | joinH (w1, h1) (w2, h2) b1 b2 = 134 | case cmp h1 h2 of 135 | LTNat n -> Hor w1 (Ver h1 b1 (SS n) (clear (w1, SS n))) w2 b2 136 | EQNat -> Hor w1 b1 w2 b2 137 | GTNat n -> Hor w1 b1 w2 (Ver h2 b2 (SS n) (clear (w2, SS n))) 138 | 139 | -- place boxes vertically 140 | joinV :: (Natty w1, Natty h1) -> (Natty w2, Natty h2) -> 141 | Box p '(w1, h1) -> Box p '(w2, h2) -> Box p '(Max w1 w2, h1 :+ h2) 142 | joinV (w1, h1) (w2, h2) b1 b2 = 143 | case cmp w1 w2 of 144 | LTNat n -> Ver h1 (Hor w1 b1 (SS n) (clear (SS n, h1))) h2 b2 145 | EQNat -> Ver h1 b1 h2 b2 146 | GTNat n -> Ver h1 b1 h2 (Hor w2 b2 (SS n) (clear (SS n, h2))) 147 | 148 | {- cropping -} 149 | type Size w h = (Natty w, Natty h) 150 | type Point x y = (Natty x, Natty y) 151 | 152 | type Region x y w h = (Point x y, Size w h) 153 | 154 | crop :: Cut p => Region x y w h -> Size s t -> Box p '(s, t) -> Box p '(w, h) 155 | crop ((x, y), (w, h)) (s, t) b = 156 | fit (s /-/ x, t /-/ y) (w, h) (clip (s, t) (x, y) b) 157 | 158 | clip :: Cut p => Size w h -> Point x y -> Box p '(w, h) -> Box p '(w :- x, h :- y) 159 | clip (w, h) (x, y) b = clipV (w /-/ x, h) y (clipH (w, h) x b) 160 | 161 | clipH :: Cut p => Size w h -> Natty x -> Box p '(w, h) -> Box p '(w :- x, h) 162 | clipH (w, h) x b = 163 | case cmp w x of 164 | GTNat d -> snd (horCut x (SS d) b) 165 | _ -> Clear 166 | 167 | clipV :: Cut p => Size w h -> Natty y -> Box p '(w, h) -> Box p '(w, h :- y) 168 | clipV (w, h) y b = 169 | case cmp h y of 170 | GTNat d -> snd (verCut y (SS d) b) 171 | _ -> Clear 172 | 173 | fit :: Cut p => Size w1 h1 -> Size w2 h2 -> Box p '(w1, h1) -> Box p '(w2, h2) 174 | fit (w1, h1) (w2, h2) b = fitV h1 h2 (fitH w1 w2 b) 175 | 176 | fitH :: Cut p => Natty w1 -> Natty w2 -> Box p '(w1, h) -> Box p '(w2, h) 177 | fitH w1 w2 b = 178 | case cmp w1 w2 of 179 | LTNat d -> Hor w1 b (SS d) Clear 180 | EQNat -> b 181 | GTNat d -> fst (horCut w2 (SS d) b) 182 | 183 | fitV :: Cut p => Natty h1 -> Natty h2 -> Box p '(w, h1) -> Box p '(w, h2) 184 | fitV h1 h2 b = 185 | case cmp h1 h2 of 186 | LTNat d -> Ver h1 b (SS d) Clear 187 | EQNat -> b 188 | GTNat d -> fst (verCut h2 (SS d) b) 189 | -------------------------------------------------------------------------------- /Box/Boxy.hs: -------------------------------------------------------------------------------- 1 | -- experimenting with replacing Hor and Ver with a single Jux constructor 2 | 3 | {-# LANGUAGE 4 | DataKinds, PolyKinds, TypeFamilies, 5 | RankNTypes, GADTs, TypeOperators, FlexibleInstances #-} 6 | 7 | module Boxy where 8 | 9 | import Data.Monoid 10 | import Control.Applicative 11 | import Data.Foldable 12 | 13 | import Nat 14 | import Vec 15 | 16 | {- dimensions -} 17 | data Dimension = Hor | Ver 18 | deriving (Show, Eq) 19 | 20 | data SDimension :: Dimension -> * where 21 | SHor :: SDimension Hor 22 | SVer :: SDimension Ver 23 | 24 | type family Perp (d :: Dimension) :: Dimension 25 | type instance Perp Hor = Ver 26 | type instance Perp Ver = Hor 27 | 28 | perp :: SDimension d -> SDimension (Perp d) 29 | perp SHor = SVer 30 | perp SVer = SHor 31 | 32 | {- composition -} 33 | -- Comp r d m 34 | -- describes how to compose in dimension d with 35 | -- r in dimension perp(d) fixed; and 36 | -- m in dimension d 37 | type family Comp (r :: Nat) (d :: Dimension) (m :: Nat) :: (Nat, Nat) 38 | type instance Comp r Hor m = '(m, r) 39 | type instance Comp r Ver m = '(r, m) 40 | 41 | {- projection -} 42 | type family Proj (d :: Dimension) (s :: (Nat, Nat)) :: Nat 43 | type instance Proj Hor '(w, h) = w 44 | type instance Proj Ver '(w, h) = h 45 | 46 | proj :: SDimension d -> Size w h -> Natty (Proj d '(w, h)) 47 | proj SHor (w, h) = w 48 | proj SVer (w, h) = h 49 | 50 | data Box :: ((Nat, Nat) -> *) -> (Nat, Nat) -> * where 51 | Stuff :: p wh -> Box p wh 52 | Clear :: Box p wh 53 | Jux :: Natty r -> SDimension d -> 54 | Natty m -> Box p (Comp r d m) -> 55 | Natty n -> Box p (Comp r d n) -> 56 | Box p (Comp r d (m :+ n)) 57 | -- Hor :: Natty w1 -> Box p '(w1, h) -> Natty w2 -> Box p '(w2, h) -> Box p '(w1 :+ w2, h) 58 | -- Ver :: Natty h1 -> Box p '(w, h1) -> Natty h2 -> Box p '(w, h2) -> Box p '(w, h1 :+ h2) 59 | 60 | type s :-> t = forall i. s i -> t i 61 | 62 | ebox :: (p :-> Box q) -> Box p :-> Box q 63 | ebox f (Stuff c) = f c 64 | ebox f Clear = Clear 65 | ebox f (Jux r d m1 b1 m2 b2) = Jux r d m1 (ebox f b1) m2 (ebox f b2) 66 | 67 | class Cut (p :: (Nat, Nat) -> *) where 68 | cut :: Natty r -> SDimension d -> 69 | Natty m -> Natty n -> 70 | p (Comp r d (m :+ n)) -> 71 | (p (Comp r d m), p (Comp r d n)) 72 | 73 | -- equal dimensions 74 | cutEq :: (Cut p, (m :+ n) ~ (w1 :+ w2)) => 75 | Natty r -> SDimension d -> 76 | Natty m -> Natty n -> 77 | Natty w1 -> Box p (Comp r d w1) -> 78 | Natty w2 -> Box p (Comp r d w2) -> 79 | (Box p (Comp r d m), Box p (Comp r d n)) 80 | cutEq r d m n w1 b1 w2 b2 = 81 | case cmpCuts m n w1 w2 of 82 | LTCuts z -> let (b11, b12) = cut r d m (SS z) b1 83 | in (b11, Jux r d (SS z) b12 w2 b2) 84 | EQCuts -> (b1, b2) 85 | GTCuts z -> let (b21, b22) = cut r d (SS z) n b2 86 | in (Jux r d w1 b1 (SS z) b21, b22) 87 | 88 | -- unequal dimensions 89 | cutNeq d m n h1 b1 h2 b2 = 90 | (Jux m (perp d) h1 b11 h2 b21, Jux n (perp d) h1 b12 h2 b22) 91 | where (b11, b12) = cut h1 d m n b1 92 | (b21, b22) = cut h2 d m n b2 93 | 94 | instance Cut p => Cut (Box p) where 95 | cut r d m n (Stuff p) = (Stuff p1, Stuff p2) 96 | where (p1, p2) = cut r d m n p 97 | cut r d m n Clear = (Clear, Clear) 98 | cut r d m n (Jux _ d' w1 b1 w2 b2) = 99 | case (d, d') of 100 | (SHor, SHor) -> cutEq r SHor m n w1 b1 w2 b2 101 | (SHor, SVer) -> cutNeq SHor m n w1 b1 w2 b2 102 | (SVer, SHor) -> cutNeq SVer m n w1 b1 w2 b2 103 | (SVer, SVer) -> cutEq r SVer m n w1 b1 w2 b2 104 | 105 | {- placing boxes -} 106 | join' :: 107 | (Comp h1 d w1 ~ Comp w1 (Perp d) h1, 108 | Comp h1 d w2 ~ Comp w2 (Perp d) h1, 109 | Comp h2 d w1 ~ Comp w1 (Perp d) h2, 110 | Comp h2 d w2 ~ Comp w2 (Perp d) h2) => 111 | SDimension d -> 112 | Natty w1 -> Natty h1 -> 113 | Natty w2 -> Natty h2 -> 114 | Box p (Comp h1 d w1) -> Box p (Comp h2 d w2) -> 115 | Box p (Comp (Max h1 h2) d (w1 :+ w2)) 116 | join' d w1 h1 w2 h2 b1 b2 = 117 | case cmp h1 h2 of 118 | LTNat n -> Jux (maxn h1 h2) d w1 (Jux w1 (perp d) h1 b1 (SS n) Clear) w2 b2 119 | EQNat -> Jux (maxn h1 h2) d w1 b1 w2 b2 120 | GTNat n -> Jux (maxn h1 h2) d w1 b1 w2 (Jux w2 (perp d) h2 b2 (SS n) Clear) 121 | 122 | 123 | -- place boxes next to each other 124 | joinD :: SDimension d -> 125 | (Natty w1, Natty h1) -> 126 | (Natty w2, Natty h2) -> 127 | Box p (Comp h1 d w1) -> Box p (Comp h2 d w2) -> 128 | Box p (Comp (Max h1 h2) d (w1 :+ w2)) 129 | joinD d (w1, h1) (w2, h2) b1 b2 = 130 | case d of 131 | SHor -> join' SHor w1 h1 w2 h2 b1 b2 132 | SVer -> join' SVer w1 h1 w2 h2 b1 b2 133 | 134 | {- cropping -} 135 | type Size w h = (Natty w, Natty h) 136 | type Point x y = (Natty x, Natty y) 137 | type Region x y w h = (Point x y, Size w h) 138 | 139 | clipD :: Cut p => 140 | SDimension d -> 141 | Size w h -> Natty x -> 142 | Box p (Comp (Proj (Perp d) '(w, h)) d (Proj d '(w, h))) -> 143 | Box p (Comp (Proj (Perp d) '(w, h)) d (Proj d '(w, h) :- x)) 144 | clipD d s x b = 145 | case cmp (proj d s) x of 146 | GTNat z -> snd (cut (proj (perp d) s) d x (SS z) b) 147 | _ -> Clear 148 | 149 | clip :: Cut p => Size w h -> Point x y -> Box p '(w, h) -> Box p '(w :- x, h :- y) 150 | clip (w, h) (x, y) b = clipD SVer (w /-/ x, h) y (clipD SHor (w, h) x b) 151 | 152 | fitD :: Cut p => 153 | Natty h -> 154 | SDimension d -> 155 | Natty w1 -> Natty w2 -> 156 | Box p (Comp h d w1) -> Box p (Comp h d w2) 157 | fitD h d w1 w2 b = 158 | case cmp w1 w2 of 159 | LTNat z -> Jux h d w1 b (SS z) Clear 160 | EQNat -> b 161 | GTNat z -> fst (cut h d w2 (SS z) b) 162 | 163 | fit :: Cut p => Size w1 h1 -> Size w2 h2 -> Box p '(w1, h1) -> Box p '(w2, h2) 164 | fit (w1, h1) (w2, h2) b = fitD w2 SVer h1 h2 (fitD h1 SHor w1 w2 b) 165 | 166 | crop :: Cut p => Region x y w h -> Size s t -> Box p '(s, t) -> Box p '(w, h) 167 | crop ((x, y), (w, h)) (s, t) b = 168 | fit (s /-/ x, t /-/ y) (w, h) (clip (s, t) (x, y) b) 169 | 170 | 171 | instance Cut p => Monoid (Box p wh) where 172 | mempty = Clear 173 | mappend b Clear = b 174 | mappend Clear b' = b' 175 | mappend b@(Stuff _) _ = b 176 | mappend (Jux h d w1 b1 w2 b2) b' = Jux h d w1 (mappend b1 b1') w2 (mappend b2 b2') 177 | where (b1', b2') = cut h d w1 w2 b' 178 | 179 | data Matrix :: * -> (Nat, Nat) -> * where 180 | Mat :: Vec y (Vec x a) -> Matrix a '(x, y) 181 | 182 | instance Show a => Show (Matrix a '(x, y)) where 183 | show = show . (foldMap ((:[]) . foldMap (:[]))) . unMat 184 | 185 | unMat :: Matrix a '(x,y) -> Vec y (Vec x a) 186 | unMat (Mat m) = m 187 | 188 | instance Cut (Matrix e) where 189 | cut _ SHor m n (Mat ess) = 190 | (Mat (fst <$> ps), Mat (snd <$> ps)) where 191 | ps = vchop m n <$> ess 192 | cut _ SVer m n (Mat ess) = (Mat tess, Mat bess) where 193 | (tess, bess) = vchop m n ess 194 | 195 | {- smart constructors for clear boxes -} 196 | clear :: (Natty w, Natty h) -> Box p '(w, h) 197 | clear (x, y) = Clear 198 | 199 | emptyBox :: Box p '(Z, Z) 200 | emptyBox = Clear 201 | 202 | hGap :: Natty w -> Box p '(w, Z) 203 | hGap _ = Clear 204 | 205 | vGap :: Natty h -> Box p '(Z, h) 206 | vGap _ = Clear 207 | 208 | 209 | -------------------------------------------------------------------------------- /Box/CharBox.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, 2 | RankNTypes, GADTs #-} 3 | 4 | module CharBox where 5 | 6 | import Control.Applicative 7 | import Data.Foldable 8 | 9 | import Nat 10 | import Vec 11 | import Box 12 | 13 | type CharMatrix = Matrix Char 14 | type CharBox wh = Box CharMatrix wh 15 | 16 | -- The call to |natter| here is necessary if Natty does not include a 17 | -- |NATTY| constraint, but can be ommitted if it does. 18 | idMatrix :: Natty n -> Matrix Int '(n, n) 19 | idMatrix (SS n) = natter n (Mat ((1 :> pure 0) :> ((0 :>) <$> (unMat (idMatrix n))))) 20 | idMatrix SZ = Mat V0 21 | 22 | matrixChar :: Char -> (Natty w, Natty h) -> CharMatrix '(w, h) 23 | matrixChar c (w, h) = Mat (vcopies h (vcopies w c)) 24 | -- alternatively we could do the presumably less efficient: 25 | -- natter w (natter h (Mat (pure (pure c)))) 26 | 27 | renderCharBox :: Size w h -> CharBox '(w, h) -> CharMatrix '(w, h) 28 | renderCharBox _ (Stuff css) = css 29 | renderCharBox (w, h) Clear = matrixChar ' ' (w, h) 30 | renderCharBox (w, _) (Ver h1 b1 h2 b2) = 31 | Mat (unMat (renderCharBox (w, h1) b1) `vappend` unMat (renderCharBox (w, h2) b2)) 32 | renderCharBox (_, h) (Hor w1 b1 w2 b2) = 33 | Mat (vcopies h vappend `vapp` unMat (renderCharBox (w1, h) b1) `vapp` unMat (renderCharBox (w2, h) b2)) 34 | 35 | renderBox :: (NATTY w, NATTY h) => (forall wh.p wh -> CharMatrix wh) -> Box p '(w, h) -> CharMatrix '(w, h) 36 | renderBox f b = renderCharBox (natty, natty) (ebox (Stuff . f) b) 37 | 38 | stringsOfCharMatrix :: CharMatrix wh -> [String] 39 | stringsOfCharMatrix (Mat vs) = foldMap ((:[]) . foldMap (:[])) vs 40 | 41 | boxChar :: Char -> Size w h -> CharBox '(w, h) 42 | boxChar c s = Stuff (matrixChar c s) 43 | 44 | boxZ :: CharBox '(Z, Z) 45 | boxZ = emptyBox 46 | 47 | boxS :: Vec m Char -> CharBox '(m, S Z) 48 | boxS s = Stuff (Mat (pure s)) 49 | 50 | one = SS SZ 51 | type One = S Z 52 | 53 | -------------------------------------------------------------------------------- /Box/Cursor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators, 2 | RankNTypes, PolyKinds #-} 3 | 4 | module Cursor where 5 | 6 | import Nat 7 | import Vec 8 | import Box 9 | import CharBox 10 | import Wrap 11 | 12 | type Cursor a m = ([a], m, [a]) 13 | type StringCursor = Cursor Char () 14 | 15 | type TextCursor = Cursor String StringCursor 16 | 17 | deactivate :: Cursor a () -> (Int, [a]) 18 | deactivate c = outward 0 c where 19 | outward i ([], (), xs) = (i, xs) 20 | outward i (x : xz, (), xs) = outward (i + 1) (xz, (), x : xs) 21 | 22 | 23 | activate :: (Int, [a]) -> Cursor a () 24 | activate (i, xs) = inward i ([], (), xs) where 25 | inward _ c@(_, (), []) = c 26 | inward 0 c = c 27 | inward i (xz, (), x : xs) = inward (i - 1) (x : xz, (), xs) 28 | 29 | whatAndWhere :: TextCursor -> (WCharBox, (Int, Int)) 30 | whatAndWhere (czz, cur, css) = (charBoxOfStrings strs, (x, y)) 31 | where 32 | (x, cs) = deactivate cur 33 | (y, strs) = deactivate (czz, (), cs : css) 34 | 35 | data ArrowDir = UpArrow | DownArrow | LeftArrow | RightArrow 36 | data Modifier = Normal | Shift | Control 37 | 38 | data Key 39 | = CharKey Char -- an ordinary printable character 40 | | ArrowKey Modifier ArrowDir -- an arrow key 41 | | Return 42 | | Backspace 43 | | Delete 44 | | Quit 45 | 46 | directions :: [(Char, ArrowDir)] 47 | directions = [('A', UpArrow), ('B', DownArrow), 48 | ('C', RightArrow), ('D', LeftArrow)] 49 | 50 | escapeKeys :: [(String, Key)] 51 | escapeKeys = 52 | [([c], ArrowKey Normal d) | (c, d) <- directions] ++ 53 | [("1;2" ++ [c], ArrowKey Shift d) | (c, d) <- directions] ++ 54 | [("1;5" ++ [c], ArrowKey Control d) | (c, d) <- directions] ++ 55 | [("3~", Delete)] 56 | 57 | data Damage 58 | = NoChange -- use this if nothing at all happened 59 | | PointChanged -- use this if we moved the cursor but kept the text 60 | | LineChanged -- use this if we changed text only on the current line 61 | | LotsChanged -- use this if we changed text off the current line 62 | deriving (Show, Eq, Ord) 63 | 64 | {--------------------------------------------------------------------------} 65 | {- Given a Key and an initial TextCursor, either reject the keystroke or -} 66 | {- return a modified cursor, with an overestimate of the damage we've -} 67 | {- done. -} 68 | {--------------------------------------------------------------------------} 69 | 70 | handleKey :: Key -> TextCursor -> Maybe (Damage, TextCursor) 71 | handleKey (CharKey c) (sz, (cz, (), cs), ss) = 72 | Just (LineChanged, (sz, (c : cz, (), cs), ss)) 73 | handleKey (ArrowKey Normal LeftArrow) (sz, (c : cz, (), cs), ss) = 74 | Just (PointChanged, (sz, (cz, (), c : cs), ss)) 75 | handleKey (ArrowKey Normal RightArrow) (sz, (cz, (), c : cs), ss) = 76 | Just (PointChanged, (sz, (c : cz, (), cs), ss)) 77 | handleKey (ArrowKey Normal UpArrow) (sUp : sz, pos, ss) = 78 | Just (PointChanged, (sz, activate (i, sUp), s : ss)) 79 | where 80 | (i, s) = deactivate pos 81 | handleKey (ArrowKey Normal DownArrow) (sz, pos, sDown : ss) = 82 | Just (PointChanged, (s : sz, activate (i, sDown), ss)) 83 | where 84 | (i, s) = deactivate pos 85 | handleKey Return (sz, (cz, (), cs), ss) = 86 | Just (LotsChanged, (prefix : sz, ([], (), cs), ss)) 87 | where 88 | (_, prefix) = deactivate (cz, (), []) 89 | handleKey Delete (sz, (cz, (), c : cs), ss) = 90 | Just (LineChanged, (sz, (cz, (), cs), ss)) 91 | handleKey Backspace (sz, (c : cz, (), cs), ss) = 92 | Just (LineChanged, (sz, (cz, (), cs), ss)) 93 | handleKey Delete (sz, (cz, (), []), s : ss) = 94 | Just (LotsChanged, (sz, (cz, (), s), ss)) 95 | handleKey Backspace (s : sz, ([], (), cs), ss) = 96 | Just (LotsChanged, (sz, (cz, (), cs), ss)) 97 | where 98 | (cz, _, _) = activate (length s, s) 99 | handleKey _ _ = Nothing 100 | -------------------------------------------------------------------------------- /Box/Edit.hs: -------------------------------------------------------------------------------- 1 | {- deprecated {-# INCLUDE #-} -} 2 | {-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators, 3 | RankNTypes, PolyKinds, ForeignFunctionInterface #-} 4 | 5 | -- use flag -lncurses to compile 6 | 7 | import Foreign 8 | import Foreign.C (CInt(..)) 9 | import ANSIEscapes 10 | import System.IO 11 | import System.Environment 12 | 13 | import Box 14 | import CharBox 15 | import Wrap 16 | import Cursor 17 | 18 | foreign import ccall 19 | initscr :: IO () 20 | 21 | foreign import ccall "endwin" 22 | endwin :: IO CInt 23 | 24 | foreign import ccall "refresh" 25 | refresh :: IO CInt 26 | 27 | foreign import ccall "&LINES" 28 | linesPtr :: Ptr CInt 29 | 30 | foreign import ccall "&COLS" 31 | colsPtr :: Ptr CInt 32 | 33 | scrSize :: IO (Int, Int) 34 | scrSize = do 35 | lnes <- peek linesPtr 36 | cols <- peek colsPtr 37 | return (fromIntegral cols, fromIntegral lnes) 38 | 39 | copies :: Int -> a -> [a] 40 | copies n a = take n (repeat a) 41 | 42 | crlf :: IO () 43 | crlf = putStr "\r\n" 44 | 45 | putLn :: String -> IO () 46 | putLn x = putStr x >> crlf 47 | 48 | type UPoint = (Int, Int) 49 | type USize = (Int, Int) 50 | type URegion = (UPoint, USize) 51 | 52 | -- onScreen c r 53 | -- c is where the cursor currently is 54 | -- r is where the viewport currently is 55 | -- the return value is an updated viewport 56 | -- containing c 57 | onScreen :: UPoint -> URegion -> URegion 58 | onScreen (cx, cy) ((px, py), s@(sw, sh)) 59 | = (( intoRange px cx sw, intoRange py cy sh), s) 60 | where 61 | intoRange i j x 62 | | i <= j && j <= i + x = i -- in range, no change 63 | | otherwise = max 0 (j - div x 2) 64 | 65 | -- if we did the following, and defined appropriate wrappers over the 66 | -- curses API then we could remove the calls to wrapPoint in the main 67 | -- loop and use type indexed nats everywhere 68 | {- 69 | type WRegion = (WPoint, WPoint) 70 | 71 | onScreen' :: WPoint -> WRegion -> WRegion 72 | onScreen' (WPoint cx cy) (WPoint px py, WPoint sw sh) = 73 | case (intoRange px cx sw, intoRange py cy sh) of 74 | (WNat px', WNat py') -> (WPoint px' py', WPoint sw sh) 75 | where 76 | intoRange :: Natty i -> Natty j -> Natty x -> WNat 77 | intoRange i j x = 78 | case (cmp i j, cmp j (i /+/ x)) of 79 | (GTNat _, _) -> case div2 x of WNat d -> WNat (j /-/ d) 80 | (_, GTNat _) -> case div2 x of WNat d -> WNat (j /-/ d) 81 | _ -> WNat i 82 | 83 | div2 :: Natty n -> WNat 84 | div2 SZ = WNat SZ 85 | div2 (SS SZ) = WNat SZ 86 | div2 (SS (SS n)) = case div2 n of WNat m -> WNat (SS m) 87 | -} 88 | 89 | getEscapeKey :: [(String, Key)] -> IO (Maybe Key) 90 | getEscapeKey [] = return Nothing 91 | getEscapeKey sks = case lookup "" sks of 92 | Just k -> return (Just k) 93 | _ -> do 94 | c <- getChar 95 | getEscapeKey [(cs, k) | (d : cs, k) <- sks, d == c] 96 | 97 | keyReady :: IO (Maybe Key) 98 | keyReady = do 99 | b <- hReady stdin 100 | if not b then return Nothing else do 101 | c <- getChar 102 | case c of 103 | '\n' -> return $ Just Return 104 | '\r' -> return $ Just Return 105 | '\b' -> return $ Just Backspace 106 | '\DEL' -> return $ Just Backspace 107 | _ | c >= ' ' -> return $ Just (CharKey c) 108 | '\ESC' -> do 109 | b <- hReady stdin 110 | if not b then return $ Just Quit else do 111 | c <- getChar 112 | case c of 113 | '[' -> getEscapeKey escapeKeys 114 | _ -> return $ Just Quit 115 | _ -> return $ Nothing 116 | 117 | layout :: Size w h -> CharBox '(w, h) -> [String] 118 | layout s l = stringsOfCharMatrix (renderCharBox s l) 119 | 120 | outer :: URegion -> TextCursor -> IO () 121 | outer ps tc = inner ps tc (whatAndWhere tc) LotsChanged 122 | where 123 | inner ps@(p, _) tc lc@(WCharBox (lw, lh) l, c@(cx, cy)) d = do 124 | refresh 125 | s' <- scrSize 126 | let ps'@((px, py), (sw, sh)) = onScreen c (p, s') 127 | if px < 0 || py < 0 || fst s' < 0 || snd s' < 0 then error "oops" else return () 128 | let d' = if ps /= ps' then LotsChanged else d 129 | case d' of 130 | LotsChanged -> do 131 | clearScreen 132 | resetCursor 133 | case (wrapPoint (px, py), wrapPoint (sw, sh)) of 134 | (WPoint x y, WPoint w h) -> do 135 | let cropped = crop ((x, y), (w, h)) (lw, lh) l 136 | mapM_ putStr (layout (w, h) cropped) 137 | LineChanged -> do 138 | resetCursor 139 | down (cy - py) 140 | case (wrapPoint (px, cy), wrapPoint (sw, 1)) of 141 | (WPoint x y, WPoint w h) -> do 142 | let cropped = crop ((x, y), (w, h)) (lw, lh) l 143 | mapM_ putStr (layout (w, h) cropped) 144 | _ -> return () 145 | if d' > NoChange then do 146 | resetCursor 147 | forward (cx - px) 148 | down (cy - py) 149 | else return () 150 | mc <- keyReady 151 | case mc of 152 | Nothing -> inner ps' tc lc NoChange 153 | Just Quit -> return () 154 | Just k -> case handleKey k tc of 155 | Nothing -> inner ps' tc lc NoChange 156 | Just (d, tc') -> inner ps' tc' (whatAndWhere tc') d 157 | 158 | main = do 159 | hSetBuffering stdout NoBuffering 160 | hSetBuffering stdin NoBuffering 161 | xs <- getArgs 162 | s <- case xs of 163 | [] -> return "" 164 | (x : _) -> readFile x 165 | let (l, ls) = case lines s of 166 | [] -> ("", []) 167 | (l : ls) -> (l, ls) 168 | initscr 169 | outer ((0, 0), (-1, -1)) ([], ([], (), l), ls) 170 | endwin 171 | -------------------------------------------------------------------------------- /Box/Makefile: -------------------------------------------------------------------------------- 1 | edit: Box.hs CharBox.hs Cursor.hs Edit.hs ANSIEscapes.hs 2 | ghc -lncurses --make Edit -o edit 3 | 4 | clean: 5 | rm -f *.o *.hi edit 6 | -------------------------------------------------------------------------------- /Box/ManualNat.hs: -------------------------------------------------------------------------------- 1 | {- Nats using manually encoded singletons and type families -} 2 | 3 | {-# LANGUAGE 4 | DataKinds, PolyKinds, 5 | RankNTypes, GADTs, TypeFamilies, TypeOperators 6 | #-} 7 | 8 | module Nat where 9 | 10 | data Nat = Z | S Nat 11 | 12 | data Natty :: Nat -> * where 13 | SZ :: Natty Z 14 | SS :: Natty n -> Natty (S n) 15 | 16 | class NATTY (n :: Nat) where 17 | natty :: Natty n 18 | 19 | instance NATTY Z where 20 | natty = SZ 21 | 22 | instance NATTY n => NATTY (S n) where 23 | natty = SS natty 24 | 25 | -- natter effectively converts an explicit Natty to an implicit NATTY 26 | natter :: Natty n -> (NATTY n => t) -> t 27 | natter SZ t = t 28 | natter (SS n) t = natter n t 29 | 30 | {- plus -} 31 | type family (m :: Nat) :+ (n :: Nat) :: Nat 32 | type instance Z :+ n = n 33 | type instance S m :+ n = S (m :+ n) 34 | 35 | (/+/) :: Natty m -> Natty n -> Natty (m :+ n) 36 | SZ /+/ n = n 37 | SS m /+/ n = SS (m /+/ n) 38 | 39 | {- minus -} 40 | type family (m :: Nat) :- (n :: Nat) :: Nat 41 | type instance Z :- n = Z 42 | type instance S m :- Z = S m 43 | type instance S m :- S n = (m :- n) 44 | 45 | (/-/) :: Natty m -> Natty n -> Natty (m :- n) 46 | SZ /-/ n = SZ 47 | SS m /-/ SZ = SS m 48 | SS m /-/ SS n = m /-/ n 49 | 50 | {- max -} 51 | type family Max (m :: Nat) (n :: Nat) :: Nat 52 | type instance Max Z n = n 53 | type instance Max (S m) Z = S m 54 | type instance Max (S m) (S n) = S (Max m n) 55 | 56 | maxn :: Natty m -> Natty n -> Natty (Max m n) 57 | maxn SZ n = n 58 | maxn (SS m) SZ = SS m 59 | maxn (SS m) (SS n) = SS (maxn m n) 60 | 61 | 62 | data Cmp :: Nat -> Nat -> * where 63 | LTNat :: ((x :+ S z) ~ y, Max x y ~ y, (x :- y) ~ Z) => Natty z -> Cmp x y 64 | EQNat :: (x ~ y, Max x y ~ x, (x :- y) ~ Z) => Cmp x y 65 | GTNat :: (x ~ (y :+ S z), Max x y ~ x, (x :- y) ~ S z) => Natty z -> Cmp x y 66 | 67 | cmp :: Natty x -> Natty y -> Cmp x y 68 | cmp SZ SZ = EQNat 69 | cmp SZ (SS y) = LTNat y 70 | cmp (SS x) SZ = GTNat x 71 | cmp (SS x) (SS y) = case cmp x y of 72 | LTNat z -> LTNat z 73 | EQNat -> EQNat 74 | GTNat z -> GTNat z 75 | 76 | data CmpCuts :: Nat -> Nat -> Nat -> Nat -> * where 77 | LTCuts :: Natty b -> CmpCuts a (S b :+ c) (a :+ S b) c 78 | EQCuts :: CmpCuts a b a b 79 | GTCuts :: Natty b -> CmpCuts (a :+ S b) c a (S b :+ c) 80 | 81 | cmpCuts :: ((a :+ b) ~ (c :+ d)) => Natty a -> Natty b -> Natty c -> Natty d -> CmpCuts a b c d 82 | cmpCuts SZ b SZ d = EQCuts 83 | cmpCuts SZ b (SS c) d = LTCuts c 84 | cmpCuts (SS a) b SZ d = GTCuts a 85 | cmpCuts (SS a) b (SS c) d = case cmpCuts a b c d of 86 | LTCuts z -> LTCuts z 87 | EQCuts -> EQCuts 88 | GTCuts z -> GTCuts z 89 | 90 | {- 91 | leftCan :: forall a b c t. ((a :+ b) ~ (a :+ c)) => Natty a -> Natty b -> Natty c -> ((b ~ c) => t) -> t 92 | leftCan SZ b c t = t 93 | leftCan (SS a) b c t = leftCan a b c t 94 | 95 | assocLR :: forall l a b c t. (l ~ ((a :+ b) :+ c)) => Natty a -> Natty b -> Natty c -> ((l ~ (a :+ (b :+ c))) => t) -> t 96 | assocLR SZ b c t = t 97 | assocLR (SS a) b c t = assocLR a b c t 98 | -} 99 | 100 | {- Min -} 101 | type family Min (m :: Nat) (n :: Nat) :: Nat 102 | type instance Min Z Z = Z 103 | type instance Min Z (S n) = Z 104 | type instance Min (S m) Z = Z 105 | type instance Min (S m) (S n) = S (Min m n) 106 | 107 | minn :: Natty m -> Natty n -> Natty (Min m n) 108 | minn SZ SZ = SZ 109 | minn SZ (SS n) = SZ 110 | minn (SS m) SZ = SZ 111 | minn (SS m) (SS n) = SS (minn m n) 112 | -------------------------------------------------------------------------------- /Box/Nat.hs: -------------------------------------------------------------------------------- 1 | {- Nats using the singletons library 2 | 3 | http://hackage.haskell.org/package/singletons 4 | -} 5 | 6 | {-# LANGUAGE 7 | DataKinds, PolyKinds, 8 | RankNTypes, GADTs, TypeFamilies, TypeOperators, 9 | ConstraintKinds, 10 | TemplateHaskell #-} 11 | 12 | module Nat where 13 | 14 | import Data.Singletons 15 | 16 | data Nat = Z | S Nat 17 | 18 | $(genSingletons [''Nat]) 19 | 20 | type Natty n = SNat n 21 | type NATTY = SingRep 22 | 23 | natty :: NATTY n => Sing n 24 | natty = sing 25 | 26 | -- natter effectively converts an explicit Natty to an implicit NATTY 27 | natter :: Natty n -> (NATTY n => t) -> t 28 | natter n b = case singInstance n of SingInstance -> b 29 | 30 | {- plus -} 31 | $(singletons [d| 32 | plus :: Nat -> Nat -> Nat 33 | Z `plus` n = n 34 | (S m) `plus` n = S (m `plus` n)|]) 35 | 36 | type m :+ n = m `Plus` n 37 | (/+/) = sPlus 38 | 39 | {- minus -} 40 | $(singletons [d| 41 | minus :: Nat -> Nat -> Nat 42 | Z `minus` n = Z 43 | (S m) `minus` Z = S m 44 | (S m) `minus` (S n) = m `minus` n|]) 45 | 46 | type m :- n = m `Minus` n 47 | (/-/) = sMinus 48 | 49 | {- max -} 50 | $(singletons [d| 51 | maxNat :: Nat -> Nat -> Nat 52 | maxNat Z n = n 53 | maxNat (S m) Z = S m 54 | maxNat (S m) (S n) = S (maxNat m n)|]) 55 | 56 | type Max m n = MaxNat m n 57 | maxn = sMaxNat 58 | 59 | {- min -} 60 | $(singletons [d| 61 | minNat :: Nat -> Nat -> Nat 62 | minNat Z Z = Z 63 | minNat Z (S n) = Z 64 | minNat (S m) Z = Z 65 | minNat (S m) (S n) = S (minNat m n)|]) 66 | 67 | type Min m n = MinNat m n 68 | minn = sMinNat 69 | 70 | data Cmp'' = LTNat'' | EQNat'' | GTNat'' 71 | cmp'' :: Natty x -> Natty y -> Cmp'' 72 | cmp'' SZ SZ = EQNat'' 73 | cmp'' SZ (SS y) = LTNat'' 74 | cmp'' (SS x) SZ = GTNat'' 75 | cmp'' (SS x) (SS y) = cmp'' x y 76 | 77 | data Cmp' :: Nat -> Nat -> * where 78 | LTNat' :: Natty z -> Cmp' x (x :+ S z) 79 | EQNat' :: Cmp' x x 80 | GTNat' :: Natty z -> Cmp' (y :+ S z) y 81 | 82 | 83 | data Cmp :: Nat -> Nat -> * where 84 | LTNat :: (NATTY z, (x :+ S z) ~ y, Max x y ~ y, (x :- y) ~ Z) => Natty z -> Cmp x y 85 | EQNat :: ( x ~ y, Max x y ~ x, (x :- y) ~ Z) => Cmp x y 86 | GTNat :: (NATTY z, x ~ (y :+ S z), Max x y ~ x, (x :- y) ~ S z) => Natty z -> Cmp x y 87 | 88 | cmp :: Natty x -> Natty y -> Cmp x y 89 | cmp SZ SZ = EQNat 90 | cmp SZ (SS y) = LTNat y 91 | cmp (SS x) SZ = GTNat x 92 | cmp (SS x) (SS y) = case cmp x y of 93 | LTNat z -> LTNat z 94 | EQNat -> EQNat 95 | GTNat z -> GTNat z 96 | 97 | data CmpCuts :: Nat -> Nat -> Nat -> Nat -> * where 98 | LTCuts :: NATTY b => Natty b -> CmpCuts a (S b :+ c) (a :+ S b) c 99 | EQCuts :: CmpCuts a b a b 100 | GTCuts :: NATTY b => Natty b -> CmpCuts (a :+ S b) c a (S b :+ c) 101 | 102 | data CmpCuts' :: Nat -> Nat -> Nat -> Nat -> * where 103 | LTCuts' :: (b ~ (S z :+ d), c ~ (a :+ S z), NATTY z) => Natty z -> CmpCuts' a b c d 104 | EQCuts' :: (a ~ c, b ~ d) => CmpCuts' a b c d 105 | GTCuts' :: (a ~ (c :+ S z), d ~ (S z :+ b), NATTY z) => Natty z -> CmpCuts' a b c d 106 | 107 | 108 | cmpCuts :: ((a :+ b) ~ (c :+ d)) => Natty a -> Natty b -> Natty c -> Natty d -> CmpCuts a b c d 109 | cmpCuts SZ b SZ d = EQCuts 110 | cmpCuts SZ b (SS c) d = LTCuts c 111 | cmpCuts (SS a) b SZ d = GTCuts a 112 | cmpCuts (SS a) b (SS c) d = case cmpCuts a b c d of 113 | LTCuts z -> LTCuts z 114 | EQCuts -> EQCuts 115 | GTCuts z -> GTCuts z 116 | 117 | {- 118 | leftCan :: forall a b c t. ((a :+ b) ~ (a :+ c)) => Natty a -> Natty b -> Natty c -> ((b ~ c) => t) -> t 119 | leftCan SZ b c t = t 120 | leftCan (SS a) b c t = leftCan a b c t 121 | 122 | assocLR :: forall l a b c t. (l ~ ((a :+ b) :+ c)) => Natty a -> Natty b -> Natty c -> ((l ~ (a :+ (b :+ c))) => t) -> t 123 | assocLR SZ b c t = t 124 | assocLR (SS a) b c t = assocLR a b c t 125 | -} 126 | 127 | -------------------------------------------------------------------------------- /Box/SingNat.hs: -------------------------------------------------------------------------------- 1 | {- Nats using the singletons library 2 | 3 | http://hackage.haskell.org/package/singletons 4 | -} 5 | 6 | {-# LANGUAGE 7 | DataKinds, PolyKinds, 8 | RankNTypes, GADTs, TypeFamilies, TypeOperators, 9 | ConstraintKinds, 10 | TemplateHaskell #-} 11 | 12 | module Nat where 13 | 14 | import Data.Singletons 15 | 16 | data Nat = Z | S Nat 17 | 18 | $(genSingletons [''Nat]) 19 | 20 | type Natty n = SNat n 21 | type NATTY = SingRep 22 | 23 | natty :: NATTY n => Natty n 24 | natty = sing 25 | 26 | -- natter effectively converts an explicit Natty to an implicit NATTY 27 | natter :: Natty n -> (NATTY n => t) -> t 28 | natter n b = case singInstance n of SingInstance -> b 29 | 30 | {- plus -} 31 | $(singletons [d| 32 | plus :: Nat -> Nat -> Nat 33 | Z `plus` n = n 34 | (S m) `plus` n = S (m `plus` n)|]) 35 | 36 | type m :+ n = m `Plus` n 37 | (/+/) = sPlus 38 | 39 | {- minus -} 40 | $(singletons [d| 41 | minus :: Nat -> Nat -> Nat 42 | Z `minus` n = Z 43 | (S m) `minus` Z = S m 44 | (S m) `minus` (S n) = m `minus` n|]) 45 | 46 | type m :- n = m `Minus` n 47 | (/-/) = sMinus 48 | 49 | {- max -} 50 | $(singletons [d| 51 | maxNat :: Nat -> Nat -> Nat 52 | maxNat Z n = n 53 | maxNat (S m) Z = S m 54 | maxNat (S m) (S n) = S (maxNat m n)|]) 55 | 56 | type Max m n = MaxNat m n 57 | maxn = sMaxNat 58 | 59 | {- min -} 60 | $(singletons [d| 61 | minNat :: Nat -> Nat -> Nat 62 | minNat Z Z = Z 63 | minNat Z (S n) = Z 64 | minNat (S m) Z = Z 65 | minNat (S m) (S n) = S (minNat m n)|]) 66 | 67 | type Min m n = MinNat m n 68 | minn = sMinNat 69 | 70 | data Cmp :: Nat -> Nat -> * where 71 | LTNat :: (NATTY z, (x :+ S z) ~ y, Max x y ~ y, (x :- y) ~ Z) => Natty z -> Cmp x y 72 | EQNat :: ( x ~ y, Max x y ~ x, (x :- y) ~ Z) => Cmp x y 73 | GTNat :: (NATTY z, x ~ (y :+ S z), Max x y ~ x, (x :- y) ~ S z) => Natty z -> Cmp x y 74 | 75 | cmp :: Natty x -> Natty y -> Cmp x y 76 | cmp SZ SZ = EQNat 77 | cmp SZ (SS y) = LTNat y 78 | cmp (SS x) SZ = GTNat x 79 | cmp (SS x) (SS y) = case cmp x y of 80 | LTNat z -> LTNat z 81 | EQNat -> EQNat 82 | GTNat z -> GTNat z 83 | 84 | data CmpCuts :: Nat -> Nat -> Nat -> Nat -> * where 85 | LTCuts :: NATTY b => Natty b -> CmpCuts a (S b :+ c) (a :+ S b) c 86 | EQCuts :: CmpCuts a b a b 87 | GTCuts :: NATTY b => Natty b -> CmpCuts (a :+ S b) c a (S b :+ c) 88 | 89 | cmpCuts :: ((a :+ b) ~ (c :+ d)) => Natty a -> Natty b -> Natty c -> Natty d -> CmpCuts a b c d 90 | cmpCuts SZ b SZ d = EQCuts 91 | cmpCuts SZ b (SS c) d = LTCuts c 92 | cmpCuts (SS a) b SZ d = GTCuts a 93 | cmpCuts (SS a) b (SS c) d = case cmpCuts a b c d of 94 | LTCuts z -> LTCuts z 95 | EQCuts -> EQCuts 96 | GTCuts z -> GTCuts z 97 | 98 | {- 99 | leftCan :: forall a b c t. ((a :+ b) ~ (a :+ c)) => Natty a -> Natty b -> Natty c -> ((b ~ c) => t) -> t 100 | leftCan SZ b c t = t 101 | leftCan (SS a) b c t = leftCan a b c t 102 | 103 | assocLR :: forall l a b c t. (l ~ ((a :+ b) :+ c)) => Natty a -> Natty b -> Natty c -> ((l ~ (a :+ (b :+ c))) => t) -> t 104 | assocLR SZ b c t = t 105 | assocLR (SS a) b c t = assocLR a b c t 106 | -} 107 | 108 | -------------------------------------------------------------------------------- /Box/Vec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds, PolyKinds, KindSignatures, 3 | RankNTypes, GADTs, TypeOperators #-} 4 | 5 | module Vec where 6 | 7 | import Data.Monoid 8 | import Control.Applicative 9 | import Data.Foldable 10 | import Data.Traversable 11 | 12 | import Nat 13 | 14 | data Vec :: Nat -> * -> * where 15 | V0 :: Vec Z x 16 | (:>) :: x -> Vec n x -> Vec (S n) x 17 | 18 | vlength :: Vec n x -> Natty n 19 | vlength V0 = SZ 20 | vlength (x :> xs) = natter n (SS n) where n = vlength xs 21 | -- The extra constraints on singletons introduced by the singletons 22 | -- library require us to call natter to introduce the NATTY n type 23 | -- class constraint. Without these constraints we can write simply: 24 | -- 25 | -- vlength (x :> xs) = SS (vlength xs) 26 | 27 | instance Show x => Show (Vec n x) where 28 | show = show . foldMap (:[]) 29 | 30 | vcopies :: forall n x.Natty n -> x -> Vec n x 31 | vcopies SZ x = V0 32 | vcopies (SS n) x = x :> vcopies n x 33 | 34 | vapp :: forall n s t.Vec n (s -> t) -> Vec n s -> Vec n t 35 | vapp V0 V0 = V0 36 | vapp (f :> fs) (s :> ss) = f s :> vapp fs ss 37 | 38 | instance NATTY n => Applicative (Vec n) where 39 | pure = vcopies natty where 40 | (<*>) = vapp where 41 | 42 | instance Traversable (Vec n) where 43 | traverse f V0 = pure V0 44 | traverse f (x :> xs) = (:>) <$> f x <*> traverse f xs 45 | 46 | instance Functor (Vec n) where 47 | fmap = fmapDefault 48 | 49 | instance Foldable (Vec n) where 50 | foldMap = foldMapDefault 51 | 52 | vappend :: Vec m x -> Vec n x -> Vec (m :+ n) x 53 | vappend V0 ys = ys 54 | vappend (x :> xs) ys = x :> vappend xs ys 55 | 56 | vchop :: Natty m -> Vec (m :+ n) x -> (Vec m x, Vec n x) 57 | vchop SZ xs = (V0, xs) 58 | vchop (SS m) (x :> xs) = (x :> ys, zs) where (ys, zs) = vchop m xs 59 | 60 | {- Recent versions of GHC (>= 7.6.2) don't require an 61 | extra argument to vchop for n. 62 | 63 | However, for the vprefix function (below) we do need to provide an 64 | argument for n. -} 65 | 66 | data Proxy (a :: k) = Proxy 67 | 68 | vprefix :: Natty m -> Proxy n -> Vec (m :+ n) x -> Vec m x 69 | vprefix SZ _ xs = V0 70 | vprefix (SS m) n (x :> xs) = x :> vprefix m n xs 71 | 72 | -------------------------------------------------------------------------------- /Box/Wrap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds, KindSignatures #-} 2 | 3 | module Wrap where 4 | 5 | import Nat 6 | import Vec 7 | import Box 8 | import CharBox 9 | 10 | data WNat :: * where 11 | WNat :: NATTY n => Natty n -> WNat 12 | 13 | wrapNat :: Int -> WNat 14 | wrapNat 0 = WNat SZ 15 | wrapNat n = case wrapNat (n-1) of 16 | WNat wn -> WNat (SS wn) 17 | 18 | intOfNat :: Natty n -> Int 19 | intOfNat SZ = 0 20 | intOfNat (SS n) = 1 + intOfNat n 21 | 22 | data WPoint :: * where 23 | WPoint :: Natty x -> Natty y -> WPoint 24 | 25 | wrapPoint :: (Int, Int) -> WPoint 26 | wrapPoint (x, y) = 27 | case (wrapNat x, wrapNat y) of 28 | (WNat x, WNat y) -> WPoint x y 29 | 30 | data WCharBox :: * where 31 | WCharBox :: Size w h -> CharBox '(w, h) -> WCharBox 32 | 33 | data WrappedVec a :: * where 34 | WVec :: Vec n a -> WrappedVec a 35 | 36 | vecOfList :: [a] -> WrappedVec a 37 | vecOfList [] = WVec V0 38 | vecOfList (x:xs) = case vecOfList xs of 39 | WVec v -> WVec (x :> v) 40 | 41 | charBoxOfString :: String -> WCharBox 42 | charBoxOfString s = case vecOfList s of 43 | WVec v -> WCharBox (vlength v, one) (boxS v) 44 | 45 | charBoxOfStrings :: [String] -> WCharBox 46 | charBoxOfStrings [] = WCharBox (SZ, SZ) boxZ 47 | charBoxOfStrings (s:ss) = case (charBoxOfString s, charBoxOfStrings ss) of 48 | (WCharBox (w1, h1) b1, WCharBox (w2, h2) b2) -> 49 | WCharBox 50 | (w1 `maxn` w2, h1 /+/ h2) 51 | (joinV (w1, h1) (w2, h2) b1 b2) 52 | -------------------------------------------------------------------------------- /Free/FreeApplicative.hs: -------------------------------------------------------------------------------- 1 | {- Free applicative functor over a functor -} 2 | 3 | {-# LANGUAGE 4 | DataKinds, 5 | GADTs, TypeOperators, TypeFamilies #-} 6 | 7 | import Control.Applicative 8 | 9 | {- 10 | heterogeneous lists wrt a functor f: 11 | 12 | FList f [a1,...,an] == [f a1, ..., f ak] 13 | -} 14 | data FList (f :: * -> *) (ts :: [*]) where 15 | FNil :: FList f '[] 16 | (:>) :: f a -> FList f ts -> FList f (a ': ts) 17 | 18 | {- identity functor -} 19 | newtype Id a = Id a 20 | type IdFList = FList Id 21 | 22 | {- type list concatenation -} 23 | type family (ts :: [*]) :++: (ts' :: [*]) :: [*] 24 | type instance '[] :++: ts' = ts' 25 | type instance (t ': ts) :++: ts' = t ': (ts :++: ts') 26 | 27 | {- FList concatenation -} 28 | (/++/) :: FList f ts -> FList f ts' -> FList f (ts :++: ts') 29 | FNil /++/ cs' = cs' 30 | (c :> cs) /++/ cs' = c :> (cs /++/ cs') 31 | 32 | {- the free applicative functor -} 33 | data FreeApp f a where 34 | FreeApp :: FList f ts -> (IdFList ts -> a) -> FreeApp f a 35 | 36 | instance Functor f => Functor (FreeApp f) where 37 | fmap g (FreeApp cs f) = FreeApp cs (g . f) 38 | 39 | instance Functor f => Applicative (FreeApp f) where 40 | pure v = FreeApp FNil (\FNil -> v) 41 | FreeApp cs f <*> FreeApp cs' g = 42 | FreeApp (cs /++/ cs') 43 | (\xs -> let (ys, zs) = split (shape cs) xs in f ys (g zs)) 44 | 45 | {- split an FList into two parts. 46 | The first argument directs where to split the list. 47 | -} 48 | split :: TList ts -> 49 | FList g (ts :++: ts') -> (FList g ts, FList g ts') 50 | split TNil xs = (FNil, xs) 51 | split (TCons _ ts) (x :> xs) = (x :> ys, zs) where 52 | (ys, zs) = split ts xs 53 | 54 | {- In older versions of GHC (< 7.6.2, I think), it was necessary to 55 | add an additional argument to split in order to aid type inference. 56 | 57 | split :: FList f ts -> FList f ts' -> 58 | FList g (ts :++: ts') -> (FList g ts, FList g ts') 59 | split FNil _ xs = (FNil, xs) 60 | split (c :> cs) cs' (x :> xs) = (x :> ys, zs) where 61 | (ys, zs) = split cs cs' xs 62 | -} 63 | 64 | {- The free alternative applicative functor -} 65 | newtype FreeAlt f a = FreeAlt [FreeApp f a] 66 | 67 | instance Functor f => Functor (FreeAlt f) where 68 | fmap g (FreeAlt ps) = FreeAlt (map (fmap g) ps) 69 | 70 | instance Functor f => Applicative (FreeAlt f) where 71 | pure v = FreeAlt [pure v] 72 | FreeAlt ps <*> FreeAlt ps' = FreeAlt [p <*> p' | p <- ps, p' <- ps'] 73 | 74 | instance Functor f => Alternative (FreeAlt f) where 75 | empty = FreeAlt [] 76 | FreeAlt ps <|> FreeAlt ps' = FreeAlt (ps ++ ps') 77 | 78 | 79 | {-- proxy stuff --} 80 | 81 | data Proxy (t :: *) = Proxy 82 | 83 | -- list of type proxies 84 | data TList (ts :: [*]) where 85 | TNil :: TList '[] 86 | TCons :: Proxy t -> TList ts -> TList (t ': ts) 87 | 88 | {- shape of an FList -} 89 | shape :: FList f ts -> TList ts 90 | shape FNil = TNil 91 | shape (c :> cs) = TCons Proxy (shape cs) 92 | -------------------------------------------------------------------------------- /Free/FreeApplicative0.hs: -------------------------------------------------------------------------------- 1 | {- Free applicative functor over a functor -} 2 | 3 | {- (plain version - no type-level computation) -} 4 | 5 | {-# LANGUAGE GADTs, KindSignatures #-} 6 | 7 | import Control.Applicative 8 | 9 | {- 10 | heterogeneous lists wrt a functor f: 11 | 12 | FList f [a1,...,an] == [f a1, ..., f ak] 13 | -} 14 | data FList (f :: * -> *) (ts :: *) where 15 | FNil :: FList f () 16 | (:>) :: f a -> FList f ts -> FList f (a , ts) 17 | 18 | {- the free applicative functor -} 19 | data FreeApp f a where 20 | FreeApp :: (FList f ts) -> (ts -> a) -> FreeApp f a 21 | 22 | instance Functor f => Functor (FreeApp f) where 23 | fmap g (FreeApp cs f) = FreeApp cs (g . f) 24 | 25 | instance Functor f => Applicative (FreeApp f) where 26 | pure v = FreeApp FNil (\() -> v) 27 | FreeApp FNil f <*> FreeApp cs g = 28 | FreeApp cs (\xs -> (f ()) (g xs)) 29 | FreeApp (c :> cs) f <*> p = 30 | case FreeApp cs (\xs v x -> f (x, xs) v) <*> p of 31 | FreeApp cs' f' -> 32 | FreeApp (c :> cs') (\(x, xs) -> f' xs x) 33 | 34 | {- the free alternative applicative functor -} 35 | newtype FreeAlt f a = FreeAlt [FreeApp f a] 36 | 37 | instance Functor f => Functor (FreeAlt f) where 38 | fmap g (FreeAlt ps) = FreeAlt (map (fmap g) ps) 39 | 40 | instance Functor f => Applicative (FreeAlt f) where 41 | pure v = FreeAlt [pure v] 42 | FreeAlt ps <*> FreeAlt ps' = FreeAlt [p <*> p' | p <- ps, p' <- ps'] 43 | 44 | instance Functor f => Alternative (FreeAlt f) where 45 | empty = FreeAlt [] 46 | FreeAlt ps <|> FreeAlt ps' = FreeAlt (ps ++ ps') 47 | -------------------------------------------------------------------------------- /Free/FreeArrow.hs: -------------------------------------------------------------------------------- 1 | {- Free arrow over a bifunctor -} 2 | 3 | {- An arrow computation is a sequence of effectful steps, each of 4 | which generates an output value, followed by a pure function that 5 | processes the generated values to output a final return value. 6 | 7 | An effectful step comprises a pure function and an effectful body. The 8 | environment is provided as input to the pure function. The 9 | intermediate value returned by the pure function is fed into the 10 | effectful body, which generates the output value. 11 | 12 | Each effectful step has access to all of the previously generated 13 | values in the form of the environment. -} 14 | 15 | {-# LANGUAGE 16 | DataKinds, 17 | GADTs, TypeOperators, TypeFamilies, 18 | UndecidableInstances 19 | #-} 20 | 21 | import Prelude hiding (id, (.)) 22 | 23 | import Control.Category 24 | import Control.Arrow 25 | 26 | {- type list concatenation -} 27 | type family (ts :: [*]) :++: (ts' :: [*]) :: [*] 28 | type instance '[] :++: ts' = ts' 29 | type instance (t ': ts) :++: ts' = t ': (ts :++: ts') 30 | 31 | {- reverse type list concatenation -} 32 | type family (ts :: [*]) :>++<: (ts' :: [*]) :: [*] 33 | type instance '[] :>++<: ts' = ts' 34 | type instance (t ': ts) :>++<: ts' = ts :>++<: (t ': ts') 35 | 36 | {- type lists as right-nested products -} 37 | type family RProd (ts :: [*]) :: * 38 | type instance RProd '[] = () 39 | type instance RProd (t ': ts) = (t, RProd ts) 40 | 41 | {- type lists as left-nested products -} 42 | type family LProd (ts :: [*]) :: * 43 | type instance LProd '[] = () 44 | type instance LProd (t ': ts) = (LProd ts, t) 45 | 46 | {- an effectful step of an arrow computation -} 47 | data Step f (ts :: [*]) b where 48 | Step :: (RProd ts -> a) -> f a b -> Step f ts b 49 | 50 | {- 51 | a list of effectful steps inputting ts and outputting ts' 52 | 53 | AList f ts [b1,...,bn] == 54 | [ (ts -> a1, f a1 b1), 55 | ((b1, ts) -> a2, f a2 b2), 56 | ... , 57 | ((bn, ..., b1, ts) -> an, f an bn)] 58 | -} 59 | data AList (f :: * -> * -> *) (ts :: [*]) (ts' :: [*]) where 60 | ANil :: AList f ts '[] 61 | (:>) :: Step f ts t -> AList f (t ': ts) ts' -> AList f ts (t ': ts') 62 | 63 | {- arrow list concatenation -} 64 | (/++/) :: AList f ts0 ts' -> 65 | AList f (ts' :>++<: ts0) ts'' -> 66 | AList f ts0 (ts' :++: ts'') 67 | ANil /++/ ds = ds 68 | (c :> cs) /++/ ds = c :> (cs /++/ ds) 69 | 70 | {- transform the inputs of an arrow list -} 71 | mapA :: (RProd ts2 -> RProd ts1) -> AList f ts1 ts' -> AList f ts2 ts' 72 | mapA g ANil = ANil 73 | mapA g (Step f b :> cs) = Step (f . g) b :> mapA (second g) cs 74 | 75 | {- the free arrow over a bifunctor -} 76 | data Free (f :: * -> * -> *) (a :: *) (b :: *) :: * where 77 | Free :: AList f (a ': '[]) ts -> (RProd ts -> a -> b) -> Free f a b 78 | 79 | {- bifunctors -} 80 | class Bifunctor p where 81 | bimap :: (b -> a) -> (c -> d) -> p a c -> p b d 82 | 83 | newtype BiId a b = BiId (a -> b) 84 | instance Bifunctor BiId where 85 | bimap f g (BiId h) = BiId (g . h . f) 86 | 87 | instance Bifunctor f => Bifunctor (Free f) where 88 | bimap f g (Free ANil p) = Free ANil (\() -> g . p () . f) 89 | 90 | instance Bifunctor f => Category (Free f) where 91 | id = Free ANil (\() -> id) 92 | (.) = flip fcomp 93 | 94 | {- left to right composition of free arrows -} 95 | fcomp :: Free f a b -> Free f b c -> Free f a c 96 | fcomp (Free cs1 p1) (Free cs2 p2) = 97 | let (ts1, ts2) = (shape cs1, shape cs2) in 98 | let a = freeIn (Free cs1 p1) in 99 | Free (cs1 /++/ mapA (\xs -> (p1 (fstRev ts1 (TCons a TNil) xs) 100 | (fst (sndRev ts1 (TCons a TNil) xs)), ())) 101 | cs2) 102 | (\ xs -> let (xs1, xs2) = split ts1 ts2 xs in 103 | p2 xs2 . p1 xs1) 104 | 105 | {- chopping up tuples 106 | 107 | The second argument is computationally redundant, but required in 108 | order to satisfy the type-checker. It wouldn't be necessary if we used 109 | a suitable GADT in place of the type class RProd. -} 110 | split :: TList ts -> TList ts' -> 111 | RProd (ts :++: ts') -> (RProd ts, RProd ts') 112 | split TNil _ xs = ((), xs) 113 | split (TCons t ts) ts' (x, xs) = ((x, ys), zs) where 114 | (ys, zs) = split ts ts' xs 115 | 116 | sndRev :: TList ts -> TList ts' -> RProd (ts :>++<: ts') -> RProd ts' 117 | sndRev TNil _ l = l 118 | sndRev (TCons t ts) ts' l = snd (sndRev ts (TCons t ts') l) 119 | 120 | fstRev' :: TList ts -> TList ts' -> RProd (ts :>++<: ts') -> LProd ts 121 | fstRev' TNil _ l = () 122 | fstRev' (TCons t ts) ts' l = 123 | (fstRev' ts (TCons t ts') l, fst (sndRev ts (TCons t ts') l)) 124 | 125 | revrev :: TList ts -> LProd ts -> RProd ts 126 | revrev TNil l = () 127 | revrev (TCons t ts) l = (snd l, revrev ts (fst l)) 128 | 129 | fstRev :: TList ts -> TList ts' -> RProd (ts :>++<: ts') -> RProd ts 130 | fstRev ts ts' l = revrev ts (fstRev' ts ts' l) 131 | 132 | {-- proxy stuff --} 133 | 134 | data Proxy (t :: *) = Proxy 135 | {- list of type proxies -} 136 | data TList (ts :: [*]) where 137 | TNil :: TList '[] 138 | TCons :: Proxy t -> TList ts -> TList (t ': ts) 139 | 140 | {- shape of an AList -} 141 | shape :: AList f ts ts' -> TList ts' 142 | shape ANil = TNil 143 | shape (c :> cs) = TCons Proxy (shape cs) 144 | 145 | {- input type for an arrow -} 146 | freeIn :: Free f a b -> Proxy a 147 | freeIn _ = Proxy 148 | 149 | {- output type for an arrow -} 150 | freeOut :: Free f a b -> Proxy b 151 | freeOut _ = Proxy 152 | -------------------------------------------------------------------------------- /Free/FreeArrow0.hs: -------------------------------------------------------------------------------- 1 | {- Free arrow over a bifunctor -} 2 | 3 | {- (plain version - no type-level computation) -} 4 | 5 | {- An arrow computation is a sequence of effectful steps, each of 6 | which generates an output value, followed by a pure function that 7 | processes the generated values to output a final return value. 8 | 9 | An effectful step comprises a pure function and an effectful body. The 10 | environment is provided as input to the pure function. The 11 | intermediate value returned by the pure function is fed into the 12 | effectful body, which generates the output value. 13 | 14 | Each effectful step has access to all of the previously generated 15 | values in the form of the environment. -} 16 | 17 | {-# LANGUAGE GADTs, KindSignatures #-} 18 | 19 | import Prelude hiding (id, (.)) 20 | 21 | import Control.Category 22 | import Control.Arrow 23 | 24 | {- an effectful step of an arrow computation -} 25 | data Step f (ts :: *) b where 26 | Step :: (ts -> a) -> f a b -> Step f ts b 27 | 28 | {- a list of effectful steps inputting ts and outputting ts' -} 29 | data AList (f :: * -> * -> *) (ts :: *) (ts' :: *) where 30 | ANil :: AList f ts () 31 | (:>) :: Step f ts t -> AList f (t , ts) ts' -> AList f ts (t , ts') 32 | 33 | {- transform the inputs of an arrow list -} 34 | mapA :: (ts2 -> ts1) -> AList f ts1 ts' -> AList f ts2 ts' 35 | mapA g ANil = ANil 36 | mapA g (Step f b :> cs) = Step (f . g) b :> mapA (second g) cs 37 | 38 | {- the free arrow over a bifunctor -} 39 | data Free (f :: * -> * -> *) (a :: *) (b :: *) :: * where 40 | Free :: AList f (a , ()) ts -> (ts -> a -> b) -> Free f a b 41 | 42 | class Bifunctor p where 43 | bimap :: (b -> a) -> (c -> d) -> p a c -> p b d 44 | 45 | newtype BiId a b = BiId (a -> b) 46 | instance Bifunctor BiId where 47 | bimap f g (BiId h) = BiId (g . h . f) 48 | 49 | instance Bifunctor f => Bifunctor (Free f) where 50 | bimap f g (Free ANil p) = Free ANil (\() -> g . p () . f) 51 | 52 | instance Bifunctor f => Category (Free f) where 53 | id = Free ANil (\() -> id) 54 | (.) = flip fcomp 55 | 56 | {- left to right composition of free arrows -} 57 | fcomp :: Free f a b -> Free f b c -> Free f a c 58 | fcomp (Free ANil p1) (Free ANil p2) = Free ANil (\() -> (p2 () . p1 ())) 59 | fcomp (Free ANil p1) (Free cs p2) = 60 | Free (mapA (first (p1 ())) cs) (\xs -> p2 xs . p1 ()) 61 | fcomp (Free (c :> cs) p) r = 62 | fcons c (fcomp (Free (squish cs) (\xs (x, y) -> p (x, xs) y)) r) 63 | 64 | {- squish the first two inputs of an arrow list into a single pair -} 65 | squish :: AList f (t , (t' , ts)) ts' -> AList f ((t, t') , ts) ts' 66 | squish = mapA (\((x, y), xs) -> (x, (y, xs))) 67 | 68 | {- cons a step onto a suitably squished free arrow -} 69 | fcons :: Step f (a , ()) t -> Free f (t, a) b -> Free f a b 70 | fcons c (Free cs p) = 71 | Free (c :> mapA (\(x, (y, ())) -> ((x, y), ())) cs) 72 | (\(x, xs) a -> p xs (x, a)) 73 | 74 | instance Bifunctor f => Arrow (Free f) where 75 | arr f = Free ANil (\() -> f) 76 | first (Free cs p) = 77 | Free (mapA (\((x, _), ()) -> (x, ())) cs) (\ts -> first (p ts)) 78 | 79 | -------------------------------------------------------------------------------- /Hasochism/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module ANSIEscapes 2 | (upLine, 3 | downLine, 4 | up, 5 | down, 6 | forward, 7 | backward, 8 | killLine, 9 | restoreCursor, 10 | saveCursor, 11 | clearScreen, 12 | yellow, 13 | brown, 14 | red, 15 | blue, 16 | purple, 17 | green, 18 | orange, 19 | white, 20 | yellowOnGrey, 21 | brownOnGrey, 22 | redOnGrey, 23 | blueOnGrey, 24 | purpleOnGrey, 25 | greenOnGrey, 26 | whiteOnGrey, 27 | onBlack, 28 | onGrey, 29 | onGreyEsc, 30 | onWhiteEsc, 31 | resetCursor, 32 | initTermSize) where 33 | 34 | data Dir = UpDir | DownDir | RightDir | LeftDir 35 | 36 | instance Show Dir where 37 | show UpDir = "A" 38 | show DownDir = "B" 39 | show RightDir = "C" 40 | show LeftDir = "D" 41 | 42 | upLine = putStr "\ESC[1A" 43 | downLine = putStr "\ESC[1B" 44 | 45 | up = moveCursor UpDir 46 | down = moveCursor DownDir 47 | backward = moveCursor LeftDir 48 | forward = moveCursor RightDir 49 | 50 | moveCursor :: Dir -> Int -> IO () 51 | moveCursor dir 0 = return () 52 | moveCursor dir n = putStr $ "\ESC[" ++ show n ++ show dir 53 | 54 | killLine = escape "K" 55 | restoreCursor = escape "u" 56 | saveCursor = escape "s" 57 | clearScreen = escape "2J" 58 | initTermSize = (escape "[=3h") 59 | 60 | resetCursor = escape "0;0H" 61 | 62 | escape e = putStr $ "\ESC[" ++ e 63 | 64 | yellow str = "\ESC[1;33m" ++ str ++ "\ESC[0m" 65 | brown str = "\ESC[0;33m" ++ str ++ "\ESC[0m" 66 | blue str = "\ESC[1;34m" ++ str ++ "\ESC[0m" 67 | red str = "\ESC[1;31m" ++ str ++ "\ESC[0m" 68 | green str = "\ESC[1;32m" ++ str ++ "\ESC[0m" 69 | purple str = "\ESC[1;35m" ++ str ++ "\ESC[0m" 70 | white str = "\ESC[37m" ++ str ++ "\ESC[0m" 71 | 72 | 73 | 74 | --Be careful, these assume someone else will reset the background colour 75 | yellowOnGrey str = "\ESC[1;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 76 | brownOnGrey str = "\ESC[0;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 77 | blueOnGrey str = "\ESC[1;34m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 78 | redOnGrey str = "\ESC[1;31m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 79 | greenOnGrey str = "\ESC[1;32m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 80 | purpleOnGrey str = "\ESC[1;35m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 81 | whiteOnGrey str = "\ESC[37m" ++ str ++ "\ESC[0m" 82 | 83 | onBlack str = "\ESC[40m" ++ str ++ "\ESC[0m" 84 | onGrey str = onGreyEsc ++ str ++ onWhiteEsc 85 | onGreyEsc = "\ESC[47m" 86 | onWhiteEsc = "\ESC[0m" 87 | orange str = str -------------------------------------------------------------------------------- /Hasochism/BoxPain.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts, 5 | > TypeOperators, TypeFamilies #-} 6 | 7 | > module BoxPain where 8 | > 9 | > import NatVec 10 | > import Evidence 11 | 12 | %endif 13 | 14 | %format cmp = "\F{cmp}" 15 | 16 | %format juxH = "\F{juxH}" 17 | %format juxV = "\F{juxV}" 18 | 19 | %format maxLT = "\F{maxLT}" 20 | %format maxEQ = "\F{maxEQ}" 21 | %format maxGT = "\F{maxGT}" 22 | 23 | 24 | Here we introduce our main example, an algebra for building 25 | size-indexed rectangular tilings, which we call simply \emph{boxes}. 26 | 27 | \subsection{Two Flavours of Conjunction} 28 | \label{subsec:conjunction} 29 | 30 | In order to define size indexes we introduce some kit which turns out 31 | to be more generally useful. The type of sizes is given by the 32 | \emph{separated conjunction}~\cite{Reynolds02} of |Natty| with 33 | |Natty|. 34 | 35 | > type Size = Natty :**: Natty 36 | > 37 | > data (p :: iota -> *) :**: (q :: kappa -> *) :: (iota, kappa) -> * where 38 | > (:&&:) :: p iota -> q kappa -> (p :**: q) (Pair iota kappa) 39 | 40 | In general, the separating conjunction \mbox{|(:**:)|} of two indexed 41 | type constructors is an indexed product whose index is also a product, 42 | in which each component of the indexed product is indexed by the 43 | corresponding component of the index. 44 | 45 | We also define a \emph{non-separating conjunction}. 46 | 47 | > data (p :: kappa -> *) :*: (q :: kappa -> *) :: kappa -> * where 48 | > (:&:) :: p kappa -> q kappa -> (p :*: q) k 49 | 50 | The non-separating conjunction \mbox{|(:*:)|} is an indexed product in 51 | which the index is shared across both components of the product. 52 | 53 | We will use both separating and non-separating conjunction extensively 54 | in Section~\ref{subsec:more-existentials}. 55 | 56 | \subsection{The Box Data Type} 57 | 58 | We now introduce the type of boxes. 59 | 60 | > data Box :: ((Nat, Nat) -> *) -> (Nat, Nat) -> * where 61 | > Stuff :: p wh -> Box p wh 62 | > Clear :: Box p wh 63 | > Hor :: Natty w1 -> Box p (Pair w1 h) -> 64 | > Natty w2 -> Box p (Pair w2 h) -> Box p (Pair (w1 :+ w2) h) 65 | > Ver :: Natty h1 -> Box p (Pair w h1) -> 66 | > Natty h2 -> Box p (Pair w h2) -> Box p (Pair w (h1 :+ h2)) 67 | 68 | A box |b| with content of size-indexed type |p| and size |wh| has type 69 | |Box p wh|. Boxes are constructed from content (|Stuff|), clear boxes 70 | (|Clear|), and horizontal (|Hor|) and vertical (|Ver|) composition. 71 | % 72 | Given suitable instantiations for the content, boxes can be used as 73 | the building blocks for arbitrary graphical user interfaces. In 74 | Section~\ref{sec:editor} we instantiate content to the type of 75 | character matrices, which we use to implement a text editor. 76 | 77 | Though |Box| clearly does not have the right type to be an instance of 78 | the |Monad| type class, it is worth noting that it is a perfectly 79 | ordinary monad over a slightly richer base category than the category 80 | of Haskell types used by the |Monad| type class. The objects in this 81 | category are indexed. The morphisms are inhabitants of the following 82 | |:->| type. 83 | 84 | > type s :-> t = forall i. s i -> t i 85 | 86 | Let us define a type class of monads over indexed types. 87 | 88 | %format returnIx = "\F{returnIx}" 89 | %format extendIx = "\F{extendIx}" 90 | 91 | > class MonadIx (m :: (kappa -> *) -> (kappa -> *)) where 92 | > returnIx :: a :-> m a 93 | > extendIx :: (a :-> m b) -> (m a :-> m b) 94 | 95 | The |returnIx| method is the unit, and |extendIx| is the Kleisli 96 | extension of a monad over indexed types. It is straightforward to 97 | provide an instance for boxes. 98 | 99 | > instance MonadIx Box where 100 | > returnIx = Stuff 101 | > extendIx f (Stuff c) = f c 102 | > extendIx f Clear = Clear 103 | > extendIx f (Hor w1 b1 w2 b2) = 104 | > Hor w1 (extendIx f b1) w2 (extendIx f b2) 105 | > extendIx f (Ver h1 b1 h2 b2) = 106 | > Ver h1 (extendIx f b1) h2 (extendIx f b2) 107 | 108 | The |extendIx| operation performs substitution at |Stuff| 109 | constructors, by applying its first argument to the content. 110 | 111 | Monads over indexed sets, in general, are explored in depth in the 112 | second author's previous work~\cite{McBride11}. 113 | 114 | \subsection{Juxtaposition} 115 | 116 | A natural operation to define is the one that juxtaposes two boxes 117 | together, horizontally or vertically, adding appropriate padding if 118 | the sizes do not match up. Let us consider the horizontal version 119 | |juxH|. Its type signature is: 120 | 121 | > juxH :: Size (Pair w1 h1) -> Size (Pair w2 h2) -> 122 | > Box p (Pair w1 h1) -> Box p (Pair w2 h2) -> 123 | > Box p (Pair (w1 :+ w2) (Max h1 h2)) 124 | 125 | where |Max| computes the maximum of two promoted |Nat|s: 126 | 127 | > type family Max (m :: Nat) (n :: Nat) :: Nat 128 | > type instance Max Z n = n 129 | > type instance Max (S m) Z = S m 130 | > type instance Max (S m) (S n) = S (Max m n) 131 | 132 | As well as the two boxes it takes singleton representations of their 133 | sizes, as it must compute on these. 134 | 135 | We might try to write a definition for |juxH| as follows: 136 | 137 | < juxH (w1 :&&: h1) (w2 :&&: h2) b1 b2 = 138 | < case cmp h1 h2 of 139 | < LTNat n -> 140 | < Hor w1 (Ver h1 b1 (Sy n) Clear) w2 b2 -- |BAD| 141 | < EQNat -> 142 | < Hor w1 b1 w2 b2 -- |BAD| 143 | < GTNat n -> 144 | < Hor w1 b1 w2 (Ver h2 b2 (Sy n) Clear) -- |BAD| 145 | 146 | Unfortunately, this code does not type check, because GHC has no way 147 | of knowing that the height of the resulting box is the maximum of the 148 | heights of the component boxes. 149 | 150 | \subsection{Pain} 151 | 152 | One approach to resolving this issue is to encode lemmas, given by 153 | parameterised equations, as Haskell functions. 154 | % 155 | In general, such lemmas may be encoded as functions of type: 156 | 157 | < forall x1 ... xn.Natty x1 -> ... -> Natty xn -> ((l ~ r) => t) -> t 158 | 159 | where |l| and |r| are the left- and right-hand-side of the equation, 160 | and |x1|, \dots, |xn| are natural number variables that may appear 161 | free in the equation. The first |n| arguments are singleton natural 162 | numbers. The last argument represents a context that expects the 163 | equation to hold. 164 | 165 | For |juxH|, we need one lemma for each case of the comparison: 166 | 167 | > juxH (w1 :&&: h1) (w2 :&&: h2) b1 b2 = 168 | > case cmp h1 h2 of 169 | > LTNat z -> maxLT h1 z $ 170 | > Hor w1 (Ver h1 b1 (Sy z) Clear) w2 b2 171 | > EQNat -> maxEQ h1 $ 172 | > Hor w1 b1 w2 b2 173 | > GTNat z -> maxGT h2 z $ 174 | > Hor w1 b1 w2 (Ver h2 b2 (Sy z) Clear) 175 | 176 | %$ 177 | 178 | Each lemma is defined by a straightforward induction: 179 | 180 | > maxLT :: forall m z t.Natty m -> Natty z -> 181 | > ((Max m (m :+ S z) ~ (m :+ S z)) => t) -> t 182 | > maxLT Zy z t = t 183 | > maxLT (Sy m) z t = maxLT m z t 184 | 185 | > maxEQ :: forall m t.Natty m -> ((Max m m ~ m) => t) -> t 186 | > maxEQ Zy t = t 187 | > maxEQ (Sy m) t = maxEQ m t 188 | 189 | > maxGT :: forall n z t.Natty n -> Natty z -> 190 | > ((Max (n :+ S z) n ~ (n :+ S z)) => t) -> t 191 | > maxGT Zy z t = t 192 | > maxGT (Sy n) z t = maxGT n z t 193 | 194 | Using this pattern, it is now possible to use GHC as a theorem 195 | prover. As GHC does not provide anything in the way of direct support 196 | for theorem proving (along the lines of tactics in Coq, say), we would 197 | like to avoid the pain of explicit theorem proving as much as 198 | possible, so we now change tack. 199 | 200 | %% LocalWords: GADTs PolyKinds KindSignatures MultiParamTypeClasses 201 | %% LocalWords: DataKinds FlexibleInstances RankNTypes TypeOperators 202 | %% LocalWords: FlexibleContexts TypeFamilies BoxPain NatVec tilings 203 | %% LocalWords: wh Hor Ver instantiations Monad monad Haskell forall 204 | %% LocalWords: morphisms monads MonadIx returnIx extendIx Kleisli 205 | %% LocalWords: juxH cmp LTNat Sy EQNat GTNat GHC parameterised xn 206 | %% LocalWords: maxLT maxEQ maxGT Zy prover Coq 207 | -------------------------------------------------------------------------------- /Hasochism/BoxPleasure.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts, 5 | > TypeOperators, TypeFamilies #-} 6 | 7 | > module BoxPleasure where 8 | > 9 | > import Data.Monoid 10 | > import NatVec 11 | > 12 | 13 | > data (p :: iota -> *) :**: (q :: kappa -> *) :: (iota, kappa) -> * where 14 | > (:&&:) :: p iota -> q kappa -> (p :**: q) (Pair iota kappa) 15 | > 16 | > data (p :: kappa -> *) :*: (q :: kappa -> *) :: kappa -> * where 17 | > (:&:) :: p kappa -> q kappa -> (p :*: q) kappa 18 | 19 | > type Size = Natty :**: Natty 20 | > 21 | > type family Max (m :: Nat) (n :: Nat) :: Nat 22 | > type instance Max Z n = n 23 | > type instance Max (S m) Z = S m 24 | > type instance Max (S m) (S n) = S (Max m n) 25 | 26 | > cmp :: Natty m -> Natty n -> Cmp m n 27 | > cmp Zy Zy = EQNat 28 | > cmp Zy (Sy n) = LTNat n 29 | > cmp (Sy m) Zy = GTNat m 30 | > cmp (Sy m) (Sy n) = case cmp m n of 31 | > LTNat z -> LTNat z 32 | > EQNat -> EQNat 33 | > GTNat z -> GTNat z 34 | 35 | > data Box :: ((Nat, Nat) -> *) -> (Nat, Nat) -> * where 36 | > Stuff :: p wh -> Box p wh 37 | > Clear :: Box p wh 38 | > Hor :: Natty w1 -> Box p (Pair w1 h) -> 39 | > Natty w2 -> Box p (Pair w2 h) -> Box p (Pair (w1 :+ w2) h) 40 | > Ver :: Natty h1 -> Box p (Pair w h1) -> 41 | > Natty h2 -> Box p (Pair w h2) -> Box p (Pair w (h1 :+ h2)) 42 | 43 | %endif 44 | 45 | %format maxn = "\F{maxn}" 46 | 47 | %format juxH = "\F{juxH}" 48 | %format juxV = "\F{juxV}" 49 | %format crop = "\F{crop}" 50 | %format fit = "\F{fit}" 51 | %format fitH = "\F{fitH}" 52 | %format fitV = "\F{fitV}" 53 | %format clip = "\F{clip}" 54 | %format clipH = "\F{clipH}" 55 | %format clipV = "\F{clipV}" 56 | %format crop = "\F{crop}" 57 | 58 | %format horCut = "\F{horCut}" 59 | %format verCut = "\F{verCut}" 60 | %format cmpCuts = "\F{cmpCuts}" 61 | %format cmp = "\F{cmp}" 62 | 63 | %format mempty = "\F{mempty}" 64 | %format mappend = "\F{mappend}" 65 | 66 | 67 | %% duplicates 68 | 69 | %format CmpEx = Cmp 70 | %format LTNatEx = LTNat 71 | %format EQNatEx = EQNat 72 | %format GTNatEx = GTNat 73 | 74 | %format CmpMax = Cmp 75 | %format LTNatMax = LTNat 76 | %format EQNatMax = EQNat 77 | %format GTNatMax = GTNat 78 | 79 | 80 | %% > data Cmp :: Nat -> Nat -> * where 81 | %% > LTNat :: (Max m (m :+ S z) ~ (m :+ S z)) => Natty z -> Cmp m (m :+ S z) 82 | %% > EQNat :: (Max m m ~ m) => Cmp m m 83 | %% > GTNat :: (Max (n :+ S z) n ~ (n :+ S z)) => Natty z -> Cmp (n :+ S z) n 84 | 85 | \subsection{Pleasure} 86 | 87 | In order to avoid explicit calls to lemmas we would like to obtain the 88 | type equations we need for free as part of the proof object. As a 89 | first step, we observe that this is essentially what we are already 90 | doing in the proof object to encode the necessary equations concerning 91 | addition. One can always rephrase a GADT as an existential algebraic 92 | data type with suitable type equalities. For our basic |Cmp| data 93 | type, this yields: 94 | 95 | > data CmpEx :: Nat -> Nat -> * where 96 | > LTNatEx :: ((m :+ S z) ~ n) => Natty z -> CmpEx m n 97 | > EQNatEx :: (m ~ n) => CmpEx m n 98 | > GTNatEx :: (m ~ (n :+ S z)) => Natty z -> CmpEx m n 99 | 100 | Now the fun starts. As well as the equations that define the proof 101 | object, we can incorporate other equations that encapsulate further 102 | knowledge implied by the result of the comparison. For now, we add 103 | equations for computing the maximum of |m| and |n| in each case. 104 | 105 | > data CmpMax :: Nat -> Nat -> * where 106 | > LTNatMax :: ((m :+ S z) ~ n, Max m n ~ n) => 107 | > Natty z -> CmpMax m n 108 | > EQNatMax :: (m ~ n, Max m n ~ m) => 109 | > CmpMax m n 110 | > GTNatMax :: (m ~ (n :+ S z), Max m n ~ m) => 111 | > Natty z -> CmpMax m n 112 | 113 | Having added these straightforward equalities, our definition of 114 | |juxH| now type checks without the need to explicitly invoke any lemmas. 115 | 116 | > juxH :: Size (Pair w1 h1) -> Size (Pair w2 h2) -> 117 | > Box p (Pair w1 h1) -> Box p (Pair w2 h2) -> 118 | > Box p (Pair (w1 :+ w2) (Max h1 h2)) 119 | > juxH (w1 :&&: h1) (w2 :&&: h2) b1 b2 = 120 | > case cmp h1 h2 of 121 | > LTNat z -> 122 | > Hor w1 (Ver h1 b1 (Sy z) Clear) w2 b2 123 | > EQNat -> 124 | > Hor w1 b1 w2 b2 125 | > GTNat z -> 126 | > Hor w1 b1 w2 (Ver h2 b2 (Sy z) Clear) 127 | 128 | The |juxV| function is defined similarly. 129 | 130 | %if False 131 | 132 | > juxV :: Size (Pair w1 h1) -> Size (Pair w2 h2) -> 133 | > Box p (Pair w1 h1) -> Box p (Pair w2 h2) -> 134 | > Box p (Pair (Max w1 w2) (h1 :+ h2)) 135 | > juxV (w1 :&&: h1) (w2 :&&: h2) b1 b2 = 136 | > case cmp w1 w2 of 137 | > LTNat n -> 138 | > Ver h1 (Hor w1 b1 (Sy n) Clear) h2 b2 139 | > EQNat -> 140 | > Ver h1 b1 h2 b2 141 | > GTNat n -> 142 | > Ver h1 b1 h2 (Hor w2 b2 (Sy n) Clear) 143 | 144 | %endif 145 | 146 | As we shall see in Section~\ref{subsec:cutting}, it can be useful to 147 | attach further equational constraints to the |Cmp| constructors. A 148 | limitation of our current formulation is that we have to go back and 149 | modify the |Cmp| data type each time we wish to extract new evidence 150 | from the |cmp| function. The code of |cmp| remains the same, and 151 | typechecks without explicit proof provided the induction 152 | which establishes the evidence fits with the recursion pattern. 153 | Ideally we would have some way to abstract |Cmp| and |cmp| over 154 | properties, but it seems hard to deliver the same implicit checking of 155 | `fitting the pattern' without higher-order constraints, which are 156 | currently unsupported in Haskell. We leave a proper investigation to 157 | future work. 158 | 159 | \subsection{Cutting} 160 | \label{subsec:cutting} 161 | 162 | 163 | For cutting up boxes, and two-dimensional entities in general, we 164 | introduce a type class |Cut|. 165 | 166 | > class Cut (p :: (Nat, Nat) -> *) where 167 | > horCut :: Natty m -> Natty n -> 168 | > p (Pair (m :+ n) h) -> (p (Pair m h), p (Pair n h)) 169 | > verCut :: Natty m -> Natty n -> 170 | > p (Pair w (m :+ n)) -> (p (Pair w m), p (Pair w n)) 171 | 172 | We can cut horizontally or vertically by supplying the width or height 173 | of the two smaller boxes we wish to cut a box into. Thus |horCut| 174 | takes natural numbers |m| and |n|, an indexed thing of width $m + n$ 175 | and height $h$, and cuts it into two indexed things of height |h|, one 176 | of width |m|, and the other of width |n|. The |verCut| function is 177 | similar. 178 | 179 | In order to handle the case in which we horizontally cut the 180 | horizontal composition of two boxes, we need to perform a special kind 181 | of comparison. In general, we wish to compare natural numbers $a$ and 182 | $c$ given the equation $a + b = c + d$, and capture the constraints on 183 | $a$, $b$, $c$, and $d$ implied by the result of the comparison. For 184 | instance, if $a < c$ then there must exist some number $z$, such 185 | that $b = (z + 1) + d$ and $c = a + (z + 1)$. 186 | 187 | We encode proof objects for cut comparisons using the following data 188 | type. 189 | 190 | > data CmpCuts :: Nat -> Nat -> Nat -> Nat -> * where 191 | > LTCuts :: (b ~ (S z :+ d), c ~ (a :+ S z)) => 192 | > Natty z -> CmpCuts a b c d 193 | > EQCuts :: (a ~ c, b ~ d) => 194 | > CmpCuts a b c d 195 | > GTCuts :: (a ~ (c :+ S z), d ~ (S z :+ b)) => 196 | > Natty z -> CmpCuts a b c d 197 | 198 | We can straightforwardly define a cut comparison function. 199 | 200 | > cmpCuts :: ((a :+ b) ~ (c :+ d)) => 201 | > Natty a -> Natty b -> 202 | > Natty c -> Natty d -> 203 | > CmpCuts a b c d 204 | > cmpCuts Zy b Zy d = EQCuts 205 | > cmpCuts Zy b (Sy c) d = LTCuts c 206 | > cmpCuts (Sy a) b Zy d = GTCuts a 207 | > cmpCuts (Sy a) b (Sy c) d = case cmpCuts a b c d of 208 | > LTCuts z -> LTCuts z 209 | > EQCuts -> EQCuts 210 | > GTCuts z -> GTCuts z 211 | > 212 | 213 | Now we define cuts for boxes. 214 | 215 | > instance Cut p => Cut (Box p) where 216 | > horCut m n (Stuff p) = (Stuff p1, Stuff p2) 217 | > where (p1, p2) = horCut m n p 218 | > horCut m n Clear = (Clear, Clear) 219 | > horCut m n (Hor w1 b1 w2 b2) = 220 | > case cmpCuts m n w1 w2 of 221 | > LTCuts z -> let (b11, b12) = horCut m (Sy z) b1 222 | > in (b11, Hor (Sy z) b12 w2 b2) 223 | > EQCuts -> (b1, b2) 224 | > GTCuts z -> let (b21, b22) = horCut (Sy z) n b2 225 | > in (Hor w1 b1 (Sy z) b21, b22) 226 | > horCut m n (Ver h1 b1 h2 b2) = 227 | > (Ver h1 b11 h2 b21, Ver h1 b12 h2 b22) 228 | > where (b11, b12) = horCut m n b1 229 | > (b21, b22) = horCut m n b2 230 | 231 | < verCut m n b = ... 232 | 233 | %if False 234 | 235 | > verCut m n (Stuff p) = (Stuff p1, Stuff p2) 236 | > where (p1, p2) = verCut m n p 237 | > verCut m n Clear = (Clear, Clear) 238 | > verCut m n (Ver h1 b1 h2 b2) = 239 | > case cmpCuts m n h1 h2 of 240 | > LTCuts z -> let (b11, b12) = verCut m (Sy z) b1 241 | > in (b11, Ver (Sy z) b12 h2 b2) 242 | > EQCuts -> (b1, b2) 243 | > GTCuts z -> let (b21, b22) = verCut (Sy z) n b2 244 | > in (Ver h1 b1 (Sy z) b21, b22) 245 | > verCut m n (Hor w1 b1 w2 b2) = 246 | > (Hor w1 b11 w2 b21, Hor w1 b12 w2 b22) 247 | > where (b11, b12) = verCut m n b1 248 | > (b21, b22) = verCut m n b2 249 | 250 | %endif 251 | 252 | The interesting case occurs when horizontally cutting the horizontal 253 | composition of two sub-boxes. We must identify which sub-box the cut 254 | occurs in, and recurse appropriately. Note that we rely on being able 255 | to cut content. The definition of vertical box cutting is similar. 256 | 257 | \subsection{Boxes as Monoids} 258 | 259 | As well as monadic structure, boxes also have monoidal structure. 260 | 261 | > instance Cut p => Monoid (Box p wh) where 262 | > mempty = Clear 263 | > mappend b Clear = b 264 | > mappend Clear b' = b' 265 | > mappend b@(Stuff _) _ = b 266 | > mappend (Hor w1 b1 w2 b2) b' = 267 | > Hor w1 (mappend b1 b1') w2 (mappend b2 b2') 268 | > where (b1', b2') = horCut w1 w2 b' 269 | > mappend (Ver h1 b1 h2 b2) b' = 270 | > Ver h1 (mappend b1 b1') h2 (mappend b2 b2') 271 | > where (b1', b2') = verCut h1 h2 b' 272 | 273 | The multiplication operation |b `mappend` b'| overlays |b| on top of 274 | |b'|. It makes essential use of cutting to handle the |Hor| and |Ver| 275 | cases. 276 | 277 | \subsection{Cropping = Clipping + Fitting} 278 | 279 | We can \emph{crop} a box to a region. First we need to specify a 280 | suitably indexed type of regions. 281 | % 282 | A point identifies a position inside a box, where |(Zy, Zy)| 283 | represents the top-left corner, counting top-to-bottom, left-to-right. 284 | 285 | > type Point = Natty :**: Natty 286 | 287 | A region identifies a rectangular area inside a box by a pair of the 288 | point representing the top-left corner of the region, and the size of 289 | the region. 290 | 291 | > type Region = Point :**: Size 292 | 293 | We decompose cropping into two parts, \emph{clipping} and 294 | \emph{fitting}. 295 | 296 | Clipping discards everything to the left and above the specified 297 | point. The type signature of |clip| is: 298 | 299 | > clip :: Cut p => Size (Pair w h) -> Point (Pair x y) -> 300 | > Box p (Pair w h) -> Box p (Pair (w :- x) (h :- y)) 301 | 302 | where |:-| is type level subtraction: 303 | 304 | > type family (m :: Nat) :- (n :: Nat) :: Nat 305 | > type instance Z :- n = Z 306 | > type instance S m :- Z = S m 307 | > type instance S m :- S n = (m :- n) 308 | 309 | In order to account for the subtraction in the result, we need to 310 | augment the |Cmp| data type to include the necessary equations. 311 | 312 | > data Cmp :: Nat -> Nat -> * where 313 | > LTNat :: ((m :+ S z) ~ n, Max m n ~ n, (m :- n) ~ Z) => 314 | > Natty z -> Cmp m n 315 | > EQNat :: (m ~ n, Max m n ~ m, (m :- n) ~ Z) => 316 | > Cmp m n 317 | > GTNat :: (m ~ (n :+ S z), Max m n ~ m, (m :- n) ~ S z) => 318 | > Natty z -> Cmp m n 319 | 320 | To clip in both dimensions, we first clip horizontally, and then clip 321 | vertically. 322 | % 323 | 324 | In order to define clipping we first lift subtraction on types |:-| to 325 | subtract on singleton naturals |/-/|. 326 | 327 | > (/-/) :: Natty m -> Natty n -> Natty (m :- n) 328 | > Zy /-/ n = Zy 329 | > Sy m /-/ Zy = Sy m 330 | > Sy m /-/ Sy n = m /-/ n 331 | 332 | In general one needs to define each operation on naturals three times: 333 | once for |Nat| values, once for |Nat| types, and once for |Natty| 334 | values. The pain can be somewhat alleviated using the \singletons 335 | library~\cite{EisenbergW12}, which provides a Template Haskell 336 | extension to automatically generate all three versions from a single 337 | definition. 338 | 339 | Let us now define clipping. 340 | 341 | > clip (w :&&: h) (x :&&: y) b = 342 | > clipV (w /-/ x :&&: h) y (clipH (w :&&: h) x b) 343 | > 344 | > clipH :: Cut p => Size (Pair w h) -> Natty x -> 345 | > Box p (Pair w h) -> Box p (Pair (w :- x) h) 346 | > clipH (w :&&: h) x b = case cmp w x of 347 | > GTNat d -> snd (horCut x (Sy d) b) 348 | > _ -> Clear 349 | > 350 | > clipV :: Cut p => Size (Pair w h) -> Natty y -> 351 | > Box p (Pair w h) -> Box p (Pair w (h :- y)) 352 | > clipV (w :&&: h) y b = case cmp h y of 353 | > GTNat d -> snd (verCut y (Sy d) b) 354 | > _ -> Clear 355 | 356 | Fitting pads or cuts a box to the given size. To fit in both 357 | dimensions, we first fit horizontally, and then fit veritcally. 358 | 359 | > fit :: Cut p => Size (Pair w1 h1) -> Size (Pair w2 h2) -> 360 | > Box p (Pair w1 h1) -> Box p (Pair w2 h2) 361 | > fit (w1 :&&: h1) (w2 :&&: h2) b = fitV h1 h2 (fitH w1 w2 b) 362 | > 363 | > fitH :: Cut p => Natty w1 -> Natty w2 -> 364 | > Box p (Pair w1 h) -> Box p (Pair w2 h) 365 | > fitH w1 w2 b = case cmp w1 w2 of 366 | > LTNat d -> Hor w1 b (Sy d) Clear 367 | > EQNat -> b 368 | > GTNat d -> fst (horCut w2 (Sy d) b) 369 | > 370 | > fitV :: Cut p => Natty h1 -> Natty h2 -> 371 | > Box p (Pair w h1) -> Box p (Pair w h2) 372 | > fitV h1 h2 b = case cmp h1 h2 of 373 | > LTNat d -> Ver h1 b (Sy d) Clear 374 | > EQNat -> b 375 | > GTNat d -> fst (verCut h2 (Sy d) b) 376 | 377 | Observe that |fitH| and |fitV| do essentially the same thing as the 378 | |procrustes| function, but on boxes rather than vectors, and always 379 | using |Clear| boxes for padding. 380 | 381 | To crop a box to a region, we simply clip then fit. 382 | 383 | > crop :: Cut p => Region (Pair (Pair x y) (Pair w h)) -> Size (Pair s t) -> 384 | > Box p (Pair s t) -> Box p (Pair w h) 385 | > crop ((x :&&: y) :&&: (w :&&: h)) (s :&&: t) b = 386 | > fit ((s /-/ x) :&&: (t /-/ y)) (w :&&: h) 387 | > (clip (s :&&: t) (x :&&: y) b) 388 | 389 | 390 | A convenient feature of our cropping code is that type-level 391 | subtraction is confined to the |clip| function. This works because in 392 | the type of |fit| the output box is independent of the size of the 393 | input box. 394 | 395 | In an earlier version of the code we experimented with a more refined 396 | cropping function of type: 397 | 398 | < Cut p => Region (Pair (Pair x y) (Pair w h)) -> Size (Pair s t) -> 399 | < Box p (Pair s t) -> Box p (Pair (Min w (s :- x)) (Min h (t :- y))) 400 | 401 | where |Min| is minimum on promoted |Nat|s. 402 | % 403 | This proved considerably more difficult to use as we had to reason 404 | about interactions between subtraction, addition, and 405 | minimum. Moreover, the less-refined version is often what we want in 406 | practice. 407 | 408 | 409 | 410 | %% LocalWords: PolyKinds KindSignatures MultiParamTypeClasses cmp 411 | %% LocalWords: DataKinds FlexibleInstances RankNTypes TypeOperators 412 | %% LocalWords: FlexibleContexts TypeFamilies BoxPleasure Monoid Cmp 413 | %% LocalWords: NatVec Zy EQNat Sy LTNat GTNat wh Hor Ver GADT CmpEx 414 | %% LocalWords: datatype equalities LTNatEx EQNatEx GTNatEx CmpMax 415 | %% LocalWords: LTNatMax EQNatMax GTNatMax juxH juxV equational snd 416 | %% LocalWords: Haskell horCut verCut CmpCuts LTCuts EQCuts GTCuts 417 | %% LocalWords: cmpCuts recurse Monoids monadic monoidal mempty fitV 418 | %% LocalWords: mappend verically clipV clipH veritcally fitH fst 419 | %% LocalWords: procrustes GADTs typechecks 420 | -------------------------------------------------------------------------------- /Hasochism/Editor.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts, 5 | > TypeOperators, TypeFamilies #-} 6 | 7 | > module Main where 8 | > 9 | > import Prelude hiding (mapM_) 10 | > 11 | > import Control.Applicative 12 | > import Data.Traversable 13 | > import Data.Foldable 14 | > 15 | > import Foreign 16 | > import Foreign.C (CInt(..)) 17 | > import ANSIEscapes 18 | > import System.IO 19 | > import System.Environment 20 | > 21 | > import NatVec 22 | > import Pies 23 | > import BoxPleasure 24 | 25 | %endif 26 | 27 | We outline the design of a basic text editor, which represents the 28 | text buffer as a size-indexed box. Using this representation 29 | guarantees that manipulations such as cropping the buffer to generate 30 | screen output only generate well-formed boxes of a given size. We will 31 | also need to handle dynamic values coming from the outside world. We 32 | convert these to equivalent size-indexed values using existentials, 33 | building on the |Ex| data type of Section~\ref{sec:merge-sort} and the 34 | separating and non-separating conjunction operators of 35 | Section~\ref{subsec:conjunction}. 36 | 37 | \subsection{Character Boxes} 38 | 39 | %format matrixChar = "\F{matrixChar}" 40 | %format matrixCharI = "\F{matrixChar}" 41 | %format renderCharBox = "\F{renderCharBox}" 42 | %format stringsOfCharMatrix = "\F{stringsOfCharMatrix}" 43 | 44 | A character box is a box whose content is given by character 45 | matrices. 46 | 47 | > type CharMatrix = Matrix Char 48 | > type CharBox = Box CharMatrix 49 | 50 | Concretely, we will use a character box to represent a text buffer. We 51 | can fill an entire matrix with the same character. 52 | 53 | > matrixChar :: Char -> Size wh -> CharMatrix wh 54 | > matrixChar c (w :&&: h) = Mat (vcopies h (vcopies w c)) 55 | 56 | %% It is possible to define |matrixChar| in terms of |pure| rather than |vcopies|: 57 | %% 58 | %% > matrixCharI c (w :&&: h) = 59 | %% > natter w (natter h (Mat (pure (pure c)))) 60 | %% 61 | %% This is clearly less efficient than the previous definition as the 62 | %% |natter| invocations synthesise |NATTY| dictionaries from the |Natty| 63 | %% values we already have to hand, before |pure| converts back to the 64 | %% original |Natty| values (recall that |pure = vcopies natty|). 65 | %% 66 | We can render a character box as a character matrix. 67 | 68 | > renderCharBox :: 69 | > Size wh -> CharBox wh -> CharMatrix wh 70 | > renderCharBox _ (Stuff css) = css 71 | > renderCharBox wh Clear = 72 | > matrixChar ' ' wh 73 | > renderCharBox (w :&&: _) (Ver h1 b1 h2 b2) = 74 | > Mat (unMat (renderCharBox (w :&&: h1) b1) 75 | > `vappend` unMat (renderCharBox (w :&&: h2) b2)) 76 | > renderCharBox (_ :&&: h) (Hor w1 b1 w2 b2) = 77 | > Mat ( vcopies h vappend 78 | > `vapp` unMat (renderCharBox (w1 :&&: h) b1) 79 | > `vapp` unMat (renderCharBox (w2 :&&: h) b2)) 80 | 81 | Ideally, we would prefer to use the standard |Applicative| interface, 82 | but here we use |vcopies h| for |pure| and |vapp| for |(<*>)| to avoid 83 | the overhead of appealing to |natter h|. 84 | 85 | We can display a character matrix as a list of strings. 86 | 87 | > stringsOfCharMatrix :: CharMatrix wh -> [String] 88 | > stringsOfCharMatrix (Mat vs) = 89 | > foldMap ((:[]) . foldMap (:[])) vs 90 | 91 | In order to be able to cut (and hence crop) boxes with matrix content 92 | we instantiate the |Cut| type class for matrices. 93 | 94 | > instance Cut (Matrix e) where 95 | > horCut m _ (Mat ess) = 96 | > (Mat (fst <$> ps), Mat (snd <$> ps)) where 97 | > ps = vchop m <$> ess 98 | > verCut m _ (Mat ess) = (Mat tess, Mat bess) where 99 | > (tess, bess) = vchop m ess 100 | 101 | %$ 102 | 103 | \subsection{Existentials} 104 | \label{subsec:more-existentials} 105 | 106 | %format wrapNat = "\F{wrapNat}" 107 | %format wrapPair = "\F{wrapPair}" 108 | %format wrapInt = "\F{wrapInt}" 109 | %format wrapSize = "\F{wrapSize}" 110 | %format wrapPoint = "\F{wrapPoint}" 111 | %format wrapRegion = "\F{wrapRegion}" 112 | %format wrapVec = "\F{wrapVec}" 113 | %format wrapLenVec = "\F{wrapLenVec}" 114 | %format wrapString = "\F{wrapString}" 115 | %format wrapStrings = "\F{wrapStrings}" 116 | 117 | %format intToNat = "\F{intToNat}" 118 | %format unFlip = "\F{unFlip}" 119 | %format unLenVec = "\F{unLenVec}" 120 | %format unSizeCharBox = "\F{unSizeCharBox}" 121 | 122 | %if False 123 | 124 | > data Ex (p :: kappa -> *) where 125 | > Ex :: p i -> Ex p 126 | 127 | > type WNat = Ex Natty 128 | 129 | > wrapNat :: Nat -> WNat 130 | > wrapNat Z = Ex Zy 131 | > wrapNat (S m) = case wrapNat m of 132 | > Ex n -> Ex (Sy n) 133 | 134 | %endif 135 | 136 | In Section~\ref{sec:merge-sort} we introduced existentially quantified 137 | singletons as a means for taking dynamic values and converting them 138 | into equivalent singletons. 139 | 140 | We now present combinators for constructing existentials over 141 | composite indexes. For the editor, we will need to generate a region, 142 | that is, a pair of pairs of singleton naturals from a pair of pairs of 143 | natural numbers. 144 | 145 | > wrapPair :: (a -> Ex p) -> (b -> Ex q) -> (a, b) -> Ex (p :**: q) 146 | > wrapPair w1 w2 (x1, x2) = 147 | > case (w1 x1, w2 x2) of 148 | > (Ex v1, Ex v2) -> Ex (v1 :&&: v2) 149 | 150 | The |wrapPair| function wraps a pair of dynamic objects in a suitable 151 | existential package using a separating conjunction. 152 | 153 | > type WPoint = Ex Point 154 | > type WSize = Ex Size 155 | > type WRegion = Ex Region 156 | 157 | > intToNat :: Int -> Nat 158 | > intToNat 0 = Z 159 | > intToNat n = S (intToNat (n-1)) 160 | 161 | > wrapInt = wrapNat . intToNat 162 | > wrapPoint = wrapPair wrapInt wrapInt 163 | > wrapSize = wrapPair wrapInt wrapInt 164 | > wrapRegion = wrapPair wrapPoint wrapSize 165 | 166 | We might wish to wrap vectors, but the |Vec| type takes the length 167 | index first, so we cannot use it as is with |Ex|. Thus we can define 168 | and use a |Flip| combinator, which reverses the arguments of a two 169 | argument type-operator. 170 | 171 | > newtype Flip f a b = Flip {unFlip :: f b a} 172 | 173 | > type WVec a = Ex (Flip Vec a) 174 | 175 | > wrapVec :: [a] -> WVec a 176 | > wrapVec [] = Ex (Flip V0) 177 | > wrapVec (x:xs) = case wrapVec xs of 178 | > Ex (Flip v) -> Ex (Flip (x :> v)) 179 | 180 | In fact, we wish to wrap a vector up together with its length. This is 181 | where the non-separating conjunction comes into play. The |Natty| 182 | representing the length of the vector and the |Flip Vec a| 183 | representing the vector itself should share the same index. 184 | 185 | > type WLenVec a = Ex (Natty :*: Flip Vec a) 186 | 187 | > wrapLenVec :: [a] -> WLenVec a 188 | > wrapLenVec [] = Ex (Zy :&: Flip V0) 189 | > wrapLenVec (x:xs) = case wrapLenVec xs of 190 | > Ex (n :&: Flip v) -> Ex (Sy n :&: Flip (x :> v)) 191 | 192 | Similarly, we use non-separating conjunction to wrap a box with its 193 | size. 194 | 195 | > type WSizeCharBox = Ex (Size :*: CharBox) 196 | 197 | Given a string of length |w|, we can wrap it as a character box of 198 | size |(w, 1)|. 199 | 200 | > wrapString :: String -> WSizeCharBox 201 | > wrapString s = case wrapLenVec s of 202 | > Ex (n :&: Flip v) -> 203 | > Ex ((n :&&: Sy Zy) :&: Stuff (Mat (pure v))) 204 | 205 | Given a list of |h| strings of maximum length |w|, we can wrap it as a 206 | character box of size |(w, h)| 207 | 208 | > wrapStrings :: [String] -> WSizeCharBox 209 | > wrapStrings [] = Ex ((Zy :&&: Zy) :&: Clear) 210 | > wrapStrings (s:ss) = 211 | > case (wrapString s, wrapStrings ss) of 212 | > ( Ex ((w1 :&&: h1) :&: b1), 213 | > Ex ((w2 :&&: h2) :&: b2)) -> 214 | > Ex ( ((w1 `maxn` w2) :&&: (h1 /+/ h2)) :&: 215 | > juxV (w1 :&&: h1) (w2 :&&: h2) b1 b2) 216 | 217 | where |maxn| is maximum and \mbox{|(/+/)|} is addition on singleton 218 | natural numbers: 219 | 220 | > maxn :: Natty m -> Natty n -> Natty (Max m n) 221 | > maxn Zy n = n 222 | > maxn (Sy m) Zy = Sy m 223 | > maxn (Sy m) (Sy n) = Sy (maxn m n) 224 | > 225 | > (/+/) :: Natty m -> Natty n -> Natty (m :+ n) 226 | > Zy /+/ n = n 227 | > Sy m /+/ n = Sy (m /+/ n) 228 | 229 | Curiously, the \singletons library does not appear to provide any 230 | special support for existential quantification over singletons. It 231 | should be possible to automatically generate the code for wrapping 232 | dynamic objects in existentials. 233 | 234 | We note also that the tendency to use stock data type components, 235 | e.g., |Ex|, |Flip|, |:*:| and |:**:|, causes extra layering of 236 | wrapping constructors in \emph{patterns} and expressions. We could use 237 | a bespoke GADT for each type we build in this way, but that would make 238 | it harder to develop library functionality. Ordinary `let' allows us 239 | to hide the extra layers in expressions, but is no help for patterns, 240 | which are currently peculiar in that they admit no form of 241 | definitional abstraction~\cite{aitken.reppy}. This basic oversight 242 | would be readily remedied by \emph{pattern synonyms}---linear, 243 | constructor-form definitions which expand like macros either side of 244 | the = sign. 245 | 246 | 247 | 248 | 249 | \subsection{Cursors} 250 | 251 | %format deactivate = "\F{deactivate}" 252 | %format outward = "\F{outward}" 253 | %format activate = "\F{activate}" 254 | %format inward = "\F{inward}" 255 | %format whatAndWhere = "\F{whatAndWhere}" 256 | 257 | We use a zipper structure~\cite{Huet97} to represent a cursor into a 258 | text buffer. We make no attempt to statically track the size of the 259 | buffer as a cursor, but do so when we wish to manipulate the whole 260 | buffer. 261 | 262 | A cursor is a triple consisting of: a backwards list of elements 263 | before the current position, the object at the current position, and a 264 | forward list of elements after the current position. 265 | 266 | > type Cursor a m = ([a], m, [a]) 267 | 268 | The elements of a |StringCursor| are characters. 269 | 270 | > type StringCursor = Cursor Char () 271 | 272 | The elements of a |TextCursor| are strings. The object at the current 273 | position is a |StringCursor|. 274 | 275 | > type TextCursor = Cursor String StringCursor 276 | 277 | The |deactivate| and |activate| functions convert between a unit cursor and a pair of a list and its length. 278 | 279 | > deactivate :: Cursor a () -> (Int, [a]) 280 | > deactivate c = outward 0 c where 281 | > outward i ([], (), xs) = (i, xs) 282 | > outward i (x : xz, (), xs) = outward (i + 1) (xz, (), x : xs) 283 | > 284 | > activate :: (Int, [a]) -> Cursor a () 285 | > activate (i, xs) = inward i ([], (), xs) where 286 | > inward _ c@(_, (), []) = c 287 | > inward 0 c = c 288 | > inward i (xz, (), x : xs) = inward (i - 1) (x : xz, (), xs) 289 | 290 | The |whatAndWhere| function uses |deactivate| and |wrapStrings| to 291 | generate a well-formed existentially quantified box from a 292 | |TextCursor|. 293 | 294 | > whatAndWhere :: TextCursor -> (WSizeCharBox, (Int, Int)) 295 | > whatAndWhere (czz, cur, css) = (wrapStrings strs, (x, y)) 296 | > where 297 | > (x, cs) = deactivate cur 298 | > (y, strs) = deactivate (czz, (), cs : css) 299 | 300 | %if False 301 | 302 | > data ArrowDir = UpArrow | DownArrow | LeftArrow | RightArrow 303 | > data Modifier = Normal | Shift | Control 304 | > 305 | > data Key 306 | > = CharKey Char -- an ordinary printable character 307 | > | ArrowKey Modifier ArrowDir -- an arrow key 308 | > | Return 309 | > | Backspace 310 | > | Delete 311 | > | Quit 312 | > 313 | > directions :: [(Char, ArrowDir)] 314 | > directions = [('A', UpArrow), ('B', DownArrow), 315 | > ('C', RightArrow), ('D', LeftArrow)] 316 | > 317 | > escapeKeys :: [(String, Key)] 318 | > escapeKeys = 319 | > [([c], ArrowKey Normal d) | (c, d) <- directions] ++ 320 | > [("1;2" ++ [c], ArrowKey Shift d) | (c, d) <- directions] ++ 321 | > [("1;5" ++ [c], ArrowKey Control d) | (c, d) <- directions] ++ 322 | > [("3~", Delete)] 323 | > 324 | > data Damage 325 | > = NoChange -- nothing at all happened 326 | > | PointChanged -- we moved the cursor but kept the text 327 | > | LineChanged -- we changed text only on the current line 328 | > | LotsChanged -- we changed text off the current line 329 | > deriving (Show, Eq, Ord) 330 | 331 | %% > {--------------------------------------------------------------------------} 332 | %% > {- Given a Key and an initial TextCursor, either reject the keystroke or -} 333 | %% > {- return a modified cursor, with an overestimate of the damage we've -} 334 | %% > {- done. -} 335 | %% > {--------------------------------------------------------------------------} 336 | %% > 337 | 338 | > handleKey :: Key -> TextCursor -> Maybe (Damage, TextCursor) 339 | > handleKey (CharKey c) (sz, (cz, (), cs), ss) = 340 | > Just (LineChanged, (sz, (c : cz, (), cs), ss)) 341 | > handleKey (ArrowKey Normal LeftArrow) (sz, (c : cz, (), cs), ss) = 342 | > Just (PointChanged, (sz, (cz, (), c : cs), ss)) 343 | > handleKey (ArrowKey Normal RightArrow) (sz, (cz, (), c : cs), ss) = 344 | > Just (PointChanged, (sz, (c : cz, (), cs), ss)) 345 | > handleKey (ArrowKey Normal UpArrow) (sUp : sz, pos, ss) = 346 | > Just (PointChanged, (sz, activate (i, sUp), s : ss)) 347 | > where 348 | > (i, s) = deactivate pos 349 | > handleKey (ArrowKey Normal DownArrow) (sz, pos, sDown : ss) = 350 | > Just (PointChanged, (s : sz, activate (i, sDown), ss)) 351 | > where 352 | > (i, s) = deactivate pos 353 | > handleKey Return (sz, (cz, (), cs), ss) = 354 | > Just (LotsChanged, (prefix : sz, ([], (), cs), ss)) 355 | > where 356 | > (_, prefix) = deactivate (cz, (), []) 357 | > handleKey Delete (sz, (cz, (), c : cs), ss) = 358 | > Just (LineChanged, (sz, (cz, (), cs), ss)) 359 | > handleKey Backspace (sz, (c : cz, (), cs), ss) = 360 | > Just (LineChanged, (sz, (cz, (), cs), ss)) 361 | > handleKey Delete (sz, (cz, (), []), s : ss) = 362 | > Just (LotsChanged, (sz, (cz, (), s), ss)) 363 | > handleKey Backspace (s : sz, ([], (), cs), ss) = 364 | > Just (LotsChanged, (sz, (cz, (), cs), ss)) 365 | > where 366 | > (cz, _, _) = activate (length s, s) 367 | > handleKey _ _ = Nothing 368 | 369 | %endif 370 | 371 | \subsection{The Inner Loop} 372 | 373 | We give a brief overview of the editor's inner loop. The full code is 374 | available as literate Haskell at 375 | \url{https://github.com/slindley/dependent-haskell/tree/master/Hasochism/Editor.lhs} 376 | 377 | The current position in the text buffer is represented using a zipper 378 | structure over an unindexed list of strings. The current position and 379 | size of the screen is represented as two pairs of integers. On a 380 | change to the buffer, the inner loop proceeds as follows. 381 | \begin{itemize} 382 | \item Wrap the current screen position and size as a singleton region 383 | using |wrapRegion|. 384 | \item Unravel the zipper structure using |whatAndWhere| to reveal the 385 | underlying structure of the buffer as a list of strings. 386 | \item This invokes |wrapStrings| to wrap the list of strings as an 387 | existential over a suitably indexed |CharBox|. 388 | \item Crop the wrapped |CharBox| according to the wrapped singleton 389 | region. 390 | \item Render the result as a list of strings using 391 | |stringsOfCharMatrix . renderCharBox|. 392 | \end{itemize} 393 | 394 | We take advantage of dependent types to ensure that cropping yields 395 | boxes of the correct size. The rest of the editor does not use 396 | dependent types. The wrapping functions convert non-dependent data 397 | into equivalent dependent data. Rendering does the opposite. 398 | 399 | We expect that converting back and forth between raw and indexed data 400 | every time something changes is expensive. We leave a full performance 401 | evaluation to future work. One might hope to use indexed data 402 | everywhere. This is infeasible in practice, because of the need to 403 | interact with the outside world, and in particular foreign APIs 404 | (including the curses library we use for our text editor). 405 | 406 | %if False 407 | 408 | > foreign import ccall 409 | > initscr :: IO () 410 | > 411 | > foreign import ccall "endwin" 412 | > endwin :: IO CInt 413 | > 414 | > foreign import ccall "refresh" 415 | > refresh :: IO CInt 416 | > 417 | > foreign import ccall "&LINES" 418 | > linesPtr :: Ptr CInt 419 | > 420 | > foreign import ccall "&COLS" 421 | > colsPtr :: Ptr CInt 422 | 423 | > scrSize :: IO (Int, Int) 424 | > scrSize = do 425 | > lnes <- peek linesPtr 426 | > cols <- peek colsPtr 427 | > return (fromIntegral cols, fromIntegral lnes) 428 | > 429 | > copies :: Int -> a -> [a] 430 | > copies n a = take n (repeat a) 431 | > 432 | > crlf :: IO () 433 | > crlf = putStr "\r\n" 434 | > 435 | > putLn :: String -> IO () 436 | > putLn x = putStr x >> crlf 437 | 438 | %% > -- onScreen c r 439 | %% > -- c is where the cursor currently is 440 | %% > -- r is where the viewport currently is 441 | %% > -- the return value is an updated viewport 442 | %% > -- containing c 443 | 444 | > type UPoint = (Int, Int) 445 | > type USize = (Int, Int) 446 | > type URegion = (UPoint, USize) 447 | > 448 | > onScreen :: UPoint -> URegion -> URegion 449 | > onScreen (cx, cy) ((px, py), s@(sw, sh)) 450 | > = (( intoRange px cx sw, intoRange py cy sh), s) 451 | > where 452 | > intoRange i j x 453 | > | i <= j && j <= i + x = i -- in range, no change 454 | > | otherwise = max 0 (j - div x 2) 455 | 456 | > getEscapeKey :: [(String, Key)] -> IO (Maybe Key) 457 | > getEscapeKey [] = return Nothing 458 | > getEscapeKey sks = case lookup "" sks of 459 | > Just k -> return (Just k) 460 | > _ -> do 461 | > c <- getChar 462 | > getEscapeKey [(cs, k) | (d : cs, k) <- sks, d == c] 463 | > 464 | > keyReady :: IO (Maybe Key) 465 | > keyReady = do 466 | > b <- hReady stdin 467 | > if not b then return Nothing else do 468 | > c <- getChar 469 | > case c of 470 | > '\n' -> return $ Just Return 471 | > '\r' -> return $ Just Return 472 | > '\b' -> return $ Just Backspace 473 | > '\DEL' -> return $ Just Backspace 474 | > _ | c >= ' ' -> return $ Just (CharKey c) 475 | > '\ESC' -> do 476 | > b <- hReady stdin 477 | > if not b then return $ Just Quit else do 478 | > c <- getChar 479 | > case c of 480 | > '[' -> getEscapeKey escapeKeys 481 | > _ -> return $ Just Quit 482 | > _ -> return $ Nothing 483 | 484 | > layout :: Size wh -> CharBox wh -> [String] 485 | > layout s l = stringsOfCharMatrix (renderCharBox s l) 486 | > 487 | > outer :: URegion -> TextCursor -> IO () 488 | > outer ps tc = inner ps tc (whatAndWhere tc) LotsChanged 489 | > where 490 | > inner ps@(p, _) tc lc@(Ex ((lw :&&: lh) :&: l), c@(cx, cy)) d = do 491 | > refresh 492 | > s' <- scrSize 493 | > let ps'@((px, py), (sw, sh)) = onScreen c (p, s') 494 | > let d' = if ps /= ps' then LotsChanged else d 495 | > case d' of 496 | > LotsChanged -> do 497 | > clearScreen 498 | > resetCursor 499 | > case wrapRegion ps' of 500 | > Ex ((x :&&: y) :&&: (w :&&: h)) -> do 501 | > let cropped = crop ((x :&&: y) :&&: (w :&&: h)) (lw :&&: lh) l 502 | > mapM_ putStr (layout (w :&&: h) cropped) 503 | > LineChanged -> do 504 | > resetCursor 505 | > down (cy - py) 506 | > case wrapRegion ((px, cy), (sw, 1)) of 507 | > Ex ((x :&&: y) :&&: (w :&&: h)) -> do 508 | > let cropped = crop ((x :&&: y) :&&: (w :&&: h)) (lw :&&: lh) l 509 | > mapM_ putStr (layout (w :&&: h) cropped) 510 | > _ -> return () 511 | > if d' > NoChange then do 512 | > resetCursor 513 | > forward (cx - px) 514 | > down (cy - py) 515 | > else return () 516 | > mc <- keyReady 517 | > case mc of 518 | > Nothing -> inner ps' tc lc NoChange 519 | > Just Quit -> return () 520 | > Just k -> case handleKey k tc of 521 | > Nothing -> inner ps' tc lc NoChange 522 | > Just (d, tc') -> inner ps' tc' (whatAndWhere tc') d 523 | 524 | > main = do 525 | > hSetBuffering stdout NoBuffering 526 | > hSetBuffering stdin NoBuffering 527 | > xs <- getArgs 528 | > s <- case xs of 529 | > [] -> return "" 530 | > (x : _) -> readFile x 531 | > let (l, ls) = case lines s of 532 | > [] -> ("", []) 533 | > (l : ls) -> (l, ls) 534 | > initscr 535 | > outer ((0, 0), (-1, -1)) ([], ([], (), l), ls) 536 | > endwin 537 | 538 | %endif 539 | 540 | %% LocalWords: GADTs PolyKinds KindSignatures MultiParamTypeClasses 541 | %% LocalWords: DataKinds FlexibleInstances RankNTypes TypeOperators 542 | %% LocalWords: FlexibleContexts TypeFamilies mapM Applicative CInt 543 | %% LocalWords: Traversable Foldable ANSIEscapes NatVec BoxPleasure 544 | %% LocalWords: existentials CharMatrix CharBox matrixChar wh css ps 545 | %% LocalWords: vcopies renderCharBox Ver unMat vappend Hor vapp ess 546 | %% LocalWords: stringsOfCharMatrix foldMap horCut fst snd vchop Zy 547 | %% LocalWords: verCut tess bess WNat wrapNat Sy combinators WPoint 548 | %% LocalWords: wrapPair WSize WRegion intToNat wrapInt wrapPoint xs 549 | %% LocalWords: wrapSize wrapRegion Vec combinator newtype unFlip ss 550 | %% LocalWords: WVec wrapVec WLenVec wrapLenVec WSizeCharBox maxn xz 551 | %% LocalWords: wrapString wrapStrings juxV StringCursor TextCursor 552 | %% LocalWords: whatAndWhere czz strs ArrowDir UpArrow DownArrow Eq 553 | %% LocalWords: LeftArrow RightArrow CharKey ArrowKey escapeKeys Ord 554 | %% LocalWords: NoChange PointChanged LineChanged LotsChanged sz cz 555 | %% LocalWords: handleKey sUp pos sDown Haskell unindexed infeasible 556 | %% LocalWords: APIs ccall initscr endwin linesPtr Ptr colsPtr lnes 557 | %% LocalWords: scrSize fromIntegral crlf putStr putLn UPoint USize 558 | %% LocalWords: URegion onScreen cx cy px py intoRange sw sks lookup 559 | %% LocalWords: getEscapeKey getChar keyReady hReady stdin tc lw lh 560 | %% LocalWords: clearScreen resetCursor mc lc hSetBuffering stdout 561 | %% LocalWords: NoBuffering getArgs readFile GADT definitional 562 | -------------------------------------------------------------------------------- /Hasochism/Evidence.lhs: -------------------------------------------------------------------------------- 1 | %% duplicated thingies 2 | 3 | %format CmpN = Cmp 4 | %format LTNatN = LTNat 5 | %format EQNatN = EQNat 6 | %format GTNatN = GTNat 7 | 8 | %format vcopies = "\F{vcopies}" 9 | %format procrustes = "\F{procrustes}" 10 | %format cmp = "\F{cmp}" 11 | 12 | %if False 13 | 14 | > {-# LANGUAGE GADTs, 15 | > PolyKinds, DataKinds, RankNTypes, FlexibleContexts, 16 | > TypeOperators, TypeFamilies #-} 17 | 18 | > module Evidence where 19 | > 20 | > import NatVec 21 | > import Pies 22 | 23 | %endif 24 | 25 | In the previous section we gave ordering proofs as instances of the 26 | |OWOTO| data type. In this section, and even more so in the next, we 27 | will be concerned not only with the fact of ordering, but also the 28 | degree of it. 29 | 30 | Let us consider the operation of comparing two singleton natural 31 | numbers. We refine the standard Haskell |Ordering| type to be indexed 32 | by the natural numbers under comparison. 33 | 34 | As a na{\"\i}ve first attempt, we might copy the following definition from 35 | McBride and McKinna~\cite{McBrideM04}: 36 | 37 | > data CmpN :: Nat -> Nat -> * where 38 | > LTNatN :: CmpN m (m :+ S z) 39 | > EQNatN :: CmpN m m 40 | > GTNatN :: CmpN (n :+ S z) n 41 | 42 | If |m < n|, then there exists some |z| such that $n = m + (z + 43 | 1)$. Similarly if |m > n| then there exists some |z| such that $m = n 44 | + (z + 1)$. 45 | 46 | Following a comparison, it can be useful to be able to inspect the 47 | difference between two numbers. In the |EQNat| case, this is simply 48 | |0|. In the other two cases it is |z + 1|, thus in each case we store 49 | a singleton representation of |z| as a witness. 50 | 51 | > data Cmp :: Nat -> Nat -> * where 52 | > LTNat :: Natty z -> Cmp m (m :+ S z) 53 | > EQNat :: Cmp m m 54 | > GTNat :: Natty z -> Cmp (n :+ S z) n 55 | 56 | Note that in more conventional dependently typed programming 57 | languages, such as Agda, it is not possible to write an equivalent of 58 | our naive definition of |Cmp|---the value of |z| must be provided as 59 | an argument to the |LTNat| and |GTNat| constructors. 60 | 61 | We can now write a comparison function that constructs a suitable 62 | proof object: 63 | 64 | > cmp :: Natty m -> Natty n -> Cmp m n 65 | > cmp Zy Zy = EQNat 66 | > cmp Zy (Sy n) = LTNat n 67 | > cmp (Sy m) Zy = GTNat m 68 | > cmp (Sy m) (Sy n) = case cmp m n of 69 | > LTNat z -> LTNat z 70 | > EQNat -> EQNat 71 | > GTNat z -> GTNat z 72 | 73 | The |procrustes| function fits a vector of length |m| into a vector of 74 | length |n|, by padding or trimming as necessary. (Procrustes was a 75 | mythical Greek brigand who would make his unfortunate guests fit into 76 | an iron bed either by stretching their limbs or by chopping them 77 | off.) 78 | 79 | > procrustes :: a -> Natty m -> Natty n -> Vec m a -> Vec n a 80 | > procrustes p m n xs = case cmp m n of 81 | > LTNat z -> vappend xs (vcopies (Sy z) p) 82 | > EQNat -> xs 83 | > GTNat z -> vtake n (proxy (Sy z)) xs 84 | 85 | In both the less-than and greater-than cases, we need the evidence |z| 86 | provided by the |Cmp| data type; in the former, we even compute with 87 | it. 88 | 89 | Dependently typed programming often combines testing with the 90 | acquisition of new data that is justified by the test---the 91 | difference, in this case---and the refinement of the data being 92 | tested---the discovery that one number is the other plus the 93 | difference. We make sure that every computation which analyses data 94 | has a type which characterizes what we expect to learn. 95 | 96 | 97 | 98 | %% LocalWords: GADTs PolyKinds DataKinds RankNTypes TypeOperators 99 | %% LocalWords: FlexibleContexts TypeFamilies NatVec Haskell na ve 100 | %% LocalWords: McKinna LTNatN EQNatN GTNatN EQNat Cmp LTNat GTNat 101 | %% LocalWords: Agda cmp Zy Sy procrustes Vec xs vappend vcopies 102 | %% LocalWords: vtake characterizes OWOTO CmpN 103 | -------------------------------------------------------------------------------- /Hasochism/Existentials.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts, 5 | > TypeOperators, TypeFamilies #-} 6 | 7 | > module Pies where 8 | > 9 | > import NatVec 10 | 11 | %endif 12 | 13 | %format :**: = ":\!\!*\!*\!\!:" 14 | %format :&&: = ":\!\!\&\!\&\!\!:" 15 | 16 | > data Ex (p :: kappa -> *) where 17 | > Ex :: p i -> Ex p 18 | 19 | > type WNat = Ex Natty 20 | 21 | > wrapNat :: Int -> WNat 22 | > wrapNat 0 = Ex Zy 23 | > wrapNat n = case wrapNat (n-1) of 24 | > Ex wn -> Ex (Sy wn) 25 | 26 | > data (p :: iota -> *) :**: (q :: kappa -> *) :: (iota, kappa) -> * where 27 | > (:&&:) :: p iota -> q kappa -> (p :**: q) (Pair iota kappa) 28 | 29 | > wrapPair :: (a -> Ex p) -> 30 | > (b -> Ex q) -> 31 | > (a, b) -> Ex (p :**: q) 32 | > wrapPair w1 w2 (x1, x2) = 33 | > case (w1 x1, w2 x2) of 34 | > (Ex v1, Ex v2) -> Ex (v1 :&&: v2) 35 | 36 | > type WPoint = Ex (Natty :**: Natty) 37 | > type WSize = Ex (Natty :**: Natty) 38 | > type WRegion = Ex ((Natty :**: Natty) :**: (Natty :**: Natty)) 39 | 40 | > wrapPoint = wrapPair wrapNat wrapNat 41 | > wrapSize = wrapPair wrapNat wrapNat 42 | > wrapRegion = wrapPair wrapPoint wrapSize 43 | 44 | > newtype Flip f a b = Flip {unFlip :: f b a} 45 | 46 | > type WVec a = Ex (Flip Vec a) 47 | 48 | > wrapVec :: [a] -> WVec a 49 | > wrapVec [] = Ex (Flip V0) 50 | > wrapVec (x:xs) = case wrapVec xs of 51 | > Ex (Flip v) -> Ex (Flip (x :> v)) 52 | 53 | -------------------------------------------------------------------------------- /Hasochism/Irr.agda: -------------------------------------------------------------------------------- 1 | module Irr where 2 | 3 | data Nat : Set where 4 | ze : Nat 5 | su : Nat -> Nat 6 | 7 | Ar : Nat -> Set 8 | Ar ze = Nat 9 | Ar (su n) = Nat -> Ar n 10 | 11 | data Vec (X : Set) : Nat -> Set where 12 | [] : Vec X ze 13 | _::_ : forall {n} -> X -> Vec X n -> Vec X (su n) 14 | 15 | _+_ : Nat -> Nat -> Nat 16 | ze + y = y 17 | su x + y = su (x + y) 18 | 19 | vtake : {X : Set}(m : Nat).(n : Nat) -> 20 | Vec X (m + n) -> Vec X m 21 | vtake ze n _ = [] 22 | vtake (su m) n (x :: xs) = x :: vtake m n xs 23 | 24 | {- 25 | foo : .(n : Nat) -> Vec Nat n -> Ar n 26 | foo n xs = ? 27 | -} -------------------------------------------------------------------------------- /Hasochism/Makefile: -------------------------------------------------------------------------------- 1 | all: hasochism.pdf 2 | 3 | hasochism.tex: hasochism.lhs \ 4 | NatVec.lhs Existentials.lhs Pies.lhs NATTYInNatty.lhs \ 5 | MergeSort.lhs \ 6 | Evidence.lhs BoxPain.lhs BoxPleasure.lhs Editor.lhs 7 | if [ -f "hasochism.tex" ]; then chmod +w hasochism.tex; fi 8 | lhs2TeX -o hasochism.tex hasochism.lhs 9 | chmod -w hasochism.tex 10 | 11 | hasochism.aux: hasochism.tex 12 | pdflatex hasochism 13 | 14 | hasochism.bbl: hasochism.aux hasochism.bib 15 | bibtex hasochism 16 | 17 | hasochism.pdf: hasochism.aux hasochism.bbl 18 | pdflatex hasochism 19 | pdflatex hasochism 20 | 21 | edit: NatVec.lhs Pies.lhs BoxPleasure.lhs Editor.lhs ANSIEscapes.hs 22 | ghc -lncurses --make Editor -o edit 23 | 24 | clean: 25 | rm -f *.aux *.log *.bbl *.blg *.ptb *~ \ 26 | *.o *.hi \ 27 | hasochism.tex 28 | 29 | clean-all: clean 30 | rm -f edit hasochism.pdf 31 | -------------------------------------------------------------------------------- /Hasochism/MergeSort.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts #-} 5 | 6 | > module MergeSort where 7 | > import NatVec 8 | 9 | %endif 10 | 11 | %format owoto = "\F{owoto}" 12 | %format merge = "\F{merge}" 13 | %format deal = "\F{deal}" 14 | %format sort = "\F{sort}" 15 | 16 | %format wrapNat = "\F{wrapNat}" 17 | 18 | %format ni = "\F{ni}" 19 | 20 | 21 | %The following is a stunt, but quite a safe stunt so do try it at 22 | %home. It uses some of the entertaining new toys to bake order 23 | %invariants into merge sort. 24 | 25 | We turn now to a slightly larger example---a development of merge-sort 26 | which guarantees by type alone to produce outputs in order. The significant 27 | thing about this construction is what is missing from it: explicit proofs. 28 | By coding the necessary logic using type classes, we harness instance 29 | inference as an implicit proof search mechanism and find it quite adequate 30 | to the task. 31 | 32 | Let us start by defining $\leq$ as a `type' class, seen as a relation. 33 | 34 | > class LeN (m :: Nat) (n :: Nat) where 35 | > instance LeN Z n where 36 | > instance LeN m n => LeN (S m) (S n) where 37 | 38 | If we wanted to \emph{close} this class, we could use the module 39 | abstraction method of Kiselyov and 40 | Shan~\cite{Kiselyov07position:lightweight} which uses a non-exported 41 | superclass. We leave this elaboration to the interested reader. The 42 | |LeN| class has no methods, but it might make sense to deliver at 43 | least the explicit evidence of ordering in the corresponding GADT, 44 | just as the |NATTY| class method delivers |Natty| evidence. 45 | 46 | In order to sort numbers, we need to know that any two numbers can be 47 | ordered \emph{one way or the other} (OWOTO). Let us say what it means 48 | for two numbers to be so orderable. 49 | 50 | > data OWOTO :: Nat -> Nat -> * where 51 | > LE :: LeN x y => OWOTO x y 52 | > GE :: LeN y x => OWOTO x y 53 | 54 | Testing which way round the numbers are is quite a lot like the usual 55 | Boolean version, except with evidence. The step case requires 56 | unpacking and repacking because the constructors are used at different 57 | types (|OWOTO m n| versus |OWOTO (S m) (S n)|). However, instance 58 | inference is sufficient to deduce the logical goals from the 59 | information revealed by testing. 60 | 61 | > owoto :: forall m n. Natty m -> Natty n -> OWOTO m n 62 | > owoto Zy n = LE 63 | > owoto (Sy m) Zy = GE 64 | > owoto (Sy m) (Sy n) = case owoto m n of 65 | > LE -> LE 66 | > GE -> GE 67 | 68 | Now we know how to put numbers in order, let us see how to make 69 | ordered lists. The plan is to describe what it is to be in order 70 | between \emph{loose bounds}~\cite{McBride00:case-talk}. Of course, we 71 | do not want to exclude any elements from being sortable, so the type 72 | of bounds extends the element type with bottom and top elements. 73 | 74 | > data Bound x = Bot | Val x | Top deriving (Show, Eq, Ord) 75 | 76 | We extend the notion of $\leq$ accordingly, so that instance inference 77 | can manage bound checking. 78 | 79 | > class LeB (a :: Bound Nat)(b :: Bound Nat) where 80 | > instance LeB Bot b where 81 | > instance LeN x y => LeB (Val x) (Val y) where 82 | > instance LeB (Val x) Top where 83 | > instance LeB Top Top where 84 | 85 | And here are ordered lists of numbers: an |OList l u| is a sequence 86 | |x1 :< x2 :< ... :< xn :< ONil| such that |l <= x1 <= x2 <= ... <= xn 87 | <= u|. The |x :<| checks that |x| is above the lower bound, then 88 | imposes |x| as the lower bound on the tail. 89 | 90 | > data OList :: Bound Nat -> Bound Nat -> * where 91 | > ONil :: LeB l u => OList l u 92 | > (:<) :: forall l x u. LeB l (Val x) => 93 | > Natty x -> OList (Val x) u -> OList l u 94 | 95 | We can write merge for ordered lists just the same way we would if 96 | they were ordinary. The key invariant is that if both lists share the 97 | same bounds, so does their merge. 98 | 99 | > merge :: OList l u -> OList l u -> OList l u 100 | > merge ONil lu = lu 101 | > merge lu ONil = lu 102 | > merge (x :< xu) (y :< yu) = case owoto x y of 103 | > LE -> x :< merge xu (y :< yu) 104 | > GE -> y :< merge (x :< xu) yu 105 | 106 | The branches of the case analysis extend what is already known from 107 | the inputs with just enough ordering information to satisfy the 108 | requirements for the results. Instance inference acts as a basic 109 | theorem prover: fortunately (or rather, with a bit of practice) the 110 | proof obligations are easy enough. 111 | 112 | Now that we can combine ordered lists of singleton numbers, we shall need to 113 | construct singletons for the numbers we intend to sort. We do so via a 114 | general data type for existential quantification. 115 | 116 | > data Ex (p :: kappa -> *) where 117 | > Ex :: p i -> Ex p 118 | 119 | A `wrapped |Nat|' is then a |Natty| singleton for any type-level number. 120 | 121 | > type WNat = Ex Natty 122 | 123 | We can translate a |Nat| to its wrapped version by writing what is, 124 | morally, another obfuscated identity function between our two types 125 | of term level natural numbers. 126 | 127 | > wrapNat :: Nat -> WNat 128 | > wrapNat Z = Ex Zy 129 | > wrapNat (S m) = case wrapNat m of Ex n -> Ex (Sy n) 130 | 131 | You can see that |wrapNat| delivers the |WNat| corresponding to the 132 | |Nat| it receives, but that property is sadly not enforced by 133 | type---an inevitable consequence of separating |Nat| from its 134 | singletons. However, once we have |WNat|s, we can build merge-sort in 135 | the usual divide-and-conquer way. 136 | 137 | > deal :: [x] -> ([x], [x]) 138 | > deal [] = ([], []) 139 | > deal (x : xs) = (x : zs, ys) where (ys, zs) = deal xs 140 | 141 | > sort :: [Nat] -> OList Bot Top 142 | > sort [] = ONil 143 | > sort [n] = case wrapNat n of Ex n -> n :< ONil 144 | > sort xs = merge (sort ys) (sort zs) where (ys, zs) = deal xs 145 | 146 | The need to work with |WNat| is a little clunky compared to what one 147 | might do in Agda where a single |Nat| type serves for |Nat| and its 148 | promotion, |Natty|, |NATTY| and |WNat|, but Agda does not have the 149 | proof search capacity of Haskell's constraint solver, and so requires 150 | the theorem proving to be more explicit. There is certainly room for 151 | improvement in both settings. 152 | 153 | 154 | 155 | %if False 156 | 157 | [Here's some spare kit I built to see what was happening. 158 | 159 | > instance Show (Natty n) where 160 | > show Zy = "Zy" 161 | > show (Sy n) = "(Sy " ++ show n ++ ")" 162 | 163 | > instance Show (OList l u) where 164 | > show ONil = "ONil" 165 | > show (x :< xs) = show x ++ " :< " ++ show xs 166 | 167 | > ni :: Int -> Nat 168 | > ni 0 = Z 169 | > ni x = S (ni (x - 1)) 170 | 171 | And nothing was hidden.] 172 | %endif 173 | 174 | %% LocalWords: GADTs PolyKinds KindSignatures MultiParamTypeClasses 175 | %% LocalWords: DataKinds FlexibleInstances RankNTypes MergeSort LeN 176 | %% LocalWords: FlexibleContexts NatVec Kiselyov Shan superclass Zy 177 | %% LocalWords: GADT orderable OWOTO owoto forall Sy sortable Eq Ord 178 | %% LocalWords: LeB OList xn ONil lu xu yu prover WNat wrapNat xs zs 179 | %% LocalWords: ys Agda Haskell's ni 180 | -------------------------------------------------------------------------------- /Hasochism/NATTYInNatty.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts #-} 5 | 6 | > module NATTYInNatty where 7 | > 8 | > import Control.Applicative 9 | > import Data.Traversable 10 | > import Data.Foldable 11 | > 12 | > import NatVec 13 | > import Pies 14 | 15 | %% natural numbers again 16 | 17 | > class NATTYC (n :: Nat) where 18 | > nattyC :: NattyC n 19 | > 20 | > instance NATTYC Z where 21 | > nattyC = ZyC 22 | > 23 | > instance NATTYC n => NATTYC (S n) where 24 | > nattyC = SyC nattyC 25 | 26 | %% vectors again 27 | 28 | > data VecC :: Nat -> * -> * where 29 | > V0C :: VecC Z x 30 | > (:>>) :: x -> VecC n x -> VecC (S n) x 31 | > 32 | > vcopiesC :: forall n x.NattyC n -> x -> VecC n x 33 | > vcopiesC ZyC x = V0C 34 | > vcopiesC (SyC n) x = x :>> vcopiesC n x 35 | > 36 | > vappC :: forall n s t.VecC n (s -> t) -> VecC n s -> VecC n t 37 | > vappC V0C V0C = V0C 38 | > vappC (f :>> fs) (s :>> ss) = f s :>> vappC fs ss 39 | > 40 | > instance NATTYC n => Applicative (VecC n) where 41 | > pure = vcopiesC nattyC where 42 | > (<*>) = vappC where 43 | > 44 | > instance Traversable (VecC n) where 45 | > traverse f V0C = pure V0C 46 | > traverse f (x :>> xs) = (:>>) <$> f x <*> traverse f xs 47 | 48 | %$ 49 | 50 | > instance Functor (VecC n) where 51 | > fmap = fmapDefault 52 | > 53 | > instance Foldable (VecC n) where 54 | > foldMap = foldMapDefault 55 | 56 | %endif 57 | 58 | %% function definitions 59 | 60 | %format unMat = "\F{unMat}" 61 | 62 | %format vlength = "\F{vlength}" 63 | %format idMatrix = "\F{idMatrix}" 64 | 65 | %% duplicated thingies 66 | 67 | %format NattyD = Natty 68 | %format ZyD = Zy 69 | %format SyD = Sy 70 | 71 | %format NattyC = Natty 72 | %format ZyC = Zy 73 | %format SyC = Sy 74 | 75 | %format NATTYC = NATTY 76 | %format natterC = natter 77 | 78 | %format VecC = Vec 79 | %format V0C = V0 80 | %format :>> = :> 81 | 82 | %format vlengthC = vlength 83 | 84 | %format MatrixC = Matrix 85 | %format MatC = Mat 86 | %format unMatC = unMat 87 | %format idMatrixC = idMatrix 88 | 89 | Recall that we defined the singleton representation of natural numbers 90 | as follows. 91 | 92 | > data NattyD :: Nat -> * where 93 | > ZyD :: NattyD Z 94 | > SyD :: NattyD n -> NattyD (S n) 95 | 96 | Another possible design choice is to insert a |NATTY| constraint in 97 | the successor case, effectively storing two copies of the predecessor. 98 | This is the choice taken by Eisenberg and Weirich in the Singletons 99 | library~\cite{EisenbergW12}. 100 | 101 | > data NattyC :: Nat -> * where 102 | > ZyC :: NattyC Z 103 | > SyC :: NATTYC n => NattyC n -> NattyC (S n) 104 | 105 | Each choice has advantages and disadvantages. The unconstrained version 106 | clearly makes for easier construction of singletons, whilst the constrained 107 | version makes for more powerful elimination. 108 | 109 | Without the |NATTY| constraint on |Sy|, we can write a function to 110 | compute the length of a vector as follows: 111 | 112 | > vlength :: Vec n x -> Natty n 113 | > vlength V0 = Zy 114 | > vlength (x :> xs) = Sy (vlength xs) 115 | 116 | However, with the |NATTY| constraint on |Sy|, the construction 117 | becomes more complex, and we must write: 118 | 119 | > vlengthC :: VecC n x -> NattyC n 120 | > vlengthC V0C = ZyC 121 | > vlengthC (x :>> xs) = natterC n (SyC n) where n = vlengthC xs 122 | 123 | in order to bring the appropriate |NATTY| constraint into scope for 124 | the inductive case. 125 | 126 | %if False 127 | 128 | > data MatrixC :: * -> (Nat, Nat) -> * where 129 | > MatC :: VecC h (VecC w a) -> MatrixC a (Pair w h) 130 | > 131 | > unMatC :: MatrixC a (Pair w h) -> VecC h (VecC w a) 132 | > unMatC (MatC vs) = vs 133 | 134 | %endif 135 | 136 | Let us write a function to construct an identity matrix of size 137 | |n|. Here, we are eliminating a singleton. Without the |NATTY| constraint 138 | on |Sy|, we must use |natter| to 139 | enable the use of the relevant |Applicative| structure. 140 | 141 | > idMatrix :: Natty n -> Matrix Int (Pair n n) 142 | > idMatrix (Sy n) = natter n $ 143 | > Mat ((1 :> pure 0) :> ((0 :>) <$> unMat (idMatrix n))) 144 | > idMatrix Zy = Mat V0 145 | 146 | %$ 147 | 148 | However, with the |NATTY| constraint on |Sy|, we can omit |natter|, 149 | because the required constraint is brought into scope by pattern 150 | matching. 151 | 152 | > idMatrixC :: NattyC n -> MatrixC Int (Pair n n) 153 | > idMatrixC (SyC n) = 154 | > MatC ((1 :>> pure 0) :>> ((0 :>>) <$> unMatC (idMatrixC n))) 155 | > idMatrixC ZyC = MatC V0C 156 | 157 | %$ 158 | 159 | For constructions like |vlength| it is most convenient to omit the 160 | |NATTY| constraint from the successor constructor. For eliminations 161 | like |idMatrix|, it is most convenient to attach the |NATTY| 162 | constraint to the successor constructor. It is hard to predict which 163 | polarity is more likely to dominate, but the issue with elimination 164 | happens only when we have the explicit witness but need the implicit 165 | one. 166 | 167 | There is also a time/space trade-off, as including the constraint 168 | effectively requires storing the same information twice at each node, 169 | but allows for an implementation of |natter| by one step of case analysis, 170 | rather than a full recursion. 171 | 172 | %format natterC = natter 173 | 174 | > natterC :: NattyC n -> (NATTYC n => t) -> t 175 | > natterC ZyC t = t 176 | > natterC (SyC n) t = t 177 | 178 | SHE has vacillated between the two: the first implementation did not 179 | add the constraint; a tricky example provoked us to add it, but it broke 180 | too much code, so we reverted the change. Our experience suggests that 181 | omitting the constraint is more convenient more of the time. We should, 182 | however, prefer to omit the entire construction. 183 | 184 | %% LocalWords: GADTs PolyKinds KindSignatures MultiParamTypeClasses 185 | %% LocalWords: DataKinds FlexibleInstances RankNTypes NATTYInNatty 186 | %% LocalWords: FlexibleContexts Applicative Traversable Foldable fs 187 | %% LocalWords: NatVec NATTYC nattyC NattyC ZyC SyC VecC vcopiesC ss 188 | %% LocalWords: forall vappC xs Functor fmap fmapDefault foldMap ZyD 189 | %% LocalWords: foldMapDefault NattyD SyD Eisenberg Weirich Sy Vec 190 | %% LocalWords: vlength Zy vlengthC natterC MatrixC MatC unMatC 191 | %% LocalWords: idMatrix unMat idMatrixC 192 | -------------------------------------------------------------------------------- /Hasochism/NatVec.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts, 5 | > TypeOperators, TypeFamilies #-} 6 | 7 | > module NatVec where 8 | 9 | > type Pair (x :: j) (y :: k) = '(x, y) 10 | 11 | %endif 12 | 13 | Haskell's |DataKinds| extension~\cite{YorgeyWCJVM12} has the impact of 14 | duplicating an ordinary data type, such as 15 | 16 | > data Nat = Z | S Nat deriving (Show, Eq, Ord) 17 | 18 | at the \emph{kind} level. That is, for the price of the above 19 | \emph{type} declaration, GHC silently generates a new \emph{kind}, 20 | also |Nat|, with inhabitants formed by type level data constructors 21 | ${}^\prime$|Z| and ${}^\prime$|S|, where the prefixed quote may be dropped 22 | for names which do not clash with declared types. It is pleasant to 23 | think that the \emph{same} |Nat| is both a type and a kind, but sadly, 24 | the current conceptual separation of types and kinds requires the 25 | construction of a separate kind-level replica. 26 | 27 | The |Nat| kind is now available as a domain for various forms of 28 | universal quantification, classified on the one hand by whether the 29 | quantified values are available only statically or also dynamically, 30 | and on the other hand by whether the associated abstraction and 31 | application are implicit or explicit in the program text. Picking 32 | apart Milner's alignment of distinctions, we acquire a matrix of four 33 | dependent quantifiers for term-like things. In this section and the 34 | next, we explore the Haskell encodings and the typical usage of these 35 | quantifiers, tabulated here for the 36 | paradigmatic example of natural numbers: 37 | \[ 38 | \begin{array}{r||cc} 39 | & \textbf{implicit} & \textbf{explicit} \\ 40 | \hline 41 | \textbf{static} & |forall ((n :: Nat)).| & |forall ((n :: Nat)). Proxy n ->| \\ 42 | \textbf{dynamic} & |forall n. NATTY n =>| & |forall n. Natty n ->| \\ 43 | \end{array} 44 | \] 45 | 46 | To get to work, we must find types which involve 47 | numbers. Generalized algebraic data types, now bearing an even 48 | stronger resemblance to the inductive families of dependent type 49 | theories, provide one source. The family of \emph{vectors} is the 50 | traditional first example of such a creature, and we shall resist the 51 | contrarian urge to choose another because we shall need vectors later 52 | in the paper. 53 | 54 | > data Vec :: Nat -> * -> * where 55 | > V0 :: Vec Z x 56 | > (:>) :: x -> Vec n x -> Vec (S n) x 57 | 58 | In Haskell, one must choose a type's order of arguments with care, as 59 | partial application is permitted but $\lambda$-abstraction is not. 60 | Here we depart a little from the dependently typed tradition by giving 61 | |Vec| its length \emph{index} to the left of its payload type 62 | \emph{parameter}, |x|, because we plan to develop the functorial 63 | structure of each |Vec n| in the next section. 64 | 65 | We note that the correspondence with the inductive families of Agda, 66 | Coq and Idris is not exact. The |n| in the Haskell type of |(:>)| is 67 | given a \emph{static} implicit quantifier and erased at run time, 68 | whereas its type theoretic counterpart is \emph{dynamic} and implicit. 69 | Idris, at least, is clever enough to erase the run time copy of |n|, 70 | through Brady's `forcing' optimization~\cite{BradyMM03}. 71 | 72 | Meanwhile, type level data are useful for more than just indexing data types. 73 | We may indeed compute with them, making use of Haskell's `type family' extension, 74 | which allows us to define `families' (meaning merely `functions') of `types' 75 | in the sloppy sense of `things at the type level', not just the pedantic sense 76 | of `things of kind |*|'. 77 | 78 | %format :+ = "\mathbin{\mbox{$:\!\!+$}}" 79 | 80 | > type family (m :: Nat) :+ (n :: Nat) :: Nat 81 | > type instance Z :+ n = n 82 | > type instance S m :+ n = S (m :+ n) 83 | 84 | In an intensional dependent type theory, such a definition extends the 85 | normalization algorithm by which the type checker decides type 86 | equality up to the partial evaluation of open terms. If syntactically 87 | distinct types share a normal form, then they share the same 88 | terms. For example, in type theory, terms inhabiting |Vec (S (S Z) :+ 89 | n) x| also inhabit |Vec (S (S n)) x| without further ado. Of course, 90 | functions often satisfy laws, e.g. associativity and commutativity, 91 | which are not directly computational: terms of type |Vec (n :+ S (S 92 | Z)) x| do not inhabit |Vec (S (S n)) x|, even though the two coincide 93 | for all concrete values of |n|. Fortunately, one can formulate 94 | `propositional equality' types, whose inhabitants constitute evidence 95 | for equations. Values can be transported between provably equal types 96 | by explicit appeal to such evidence. 97 | 98 | In Haskell's kernel, type equality is entirely 99 | syntactic~\cite{SulzmannCJD07}, so that kernel terms in |Vec (S (S Z) :+ n) x| 100 | do not also inhabit |Vec (S (S n)) x|. The above `definition' \emph{axiomatizes} |(:+)| 101 | for Haskell's propositional equality, and every program which relies 102 | on computing sums must be elaborated with explicit appeal to 103 | evidence derived from those axioms. The translation from the surface language to the kernel 104 | attempts to generate this evidence by a powerful but inscrutable 105 | constraint solving heuristic. Experience suggests that the solver 106 | computes aggressively, regardless of whether type level programs are 107 | totally recursive, so we may confidently type vector concatenation in 108 | terms of addition. 109 | 110 | %format vappend = "\F{vappend}" 111 | 112 | > vappend :: Vec m x -> Vec n x -> Vec (m :+ n) x 113 | > vappend V0 ys = ys 114 | > vappend (x :> xs) ys = x :> vappend xs ys 115 | 116 | Note that the numbers here play an entirely static role: the flow of 117 | control can be determined entirely from the constructors of the first 118 | vector. Suppose, however, that we wish to invert concatenation, 119 | chopping a vector in two. 120 | 121 | %format vchop = "\F{vchop}" 122 | 123 | < vchop :: Vec (m :+ n) x -> (Vec m x, Vec n x) 124 | 125 | Unlike with |vappend|, we shall certainly need |m| at run time, and we 126 | shall need to refer to it explicitly in order to judge where to 127 | chop. However, Haskell's dependent |forall|quantifier is for implicit 128 | and exclusively static things. The standard solution is to define the 129 | run time replica of some static data as a \emph{singleton} GADT. 130 | 131 | > data Natty :: Nat -> * where 132 | > Zy :: Natty Z 133 | > Sy :: Natty n -> Natty (S n) 134 | 135 | Each type level value |n| in the |Nat| kind has a unique 136 | representative in the type |Natty n|, so analysing the latter will 137 | reveal useful facts about the former. The `$\Pi$-types', often written 138 | $(x\!:\!S)\to T$, of dependent type theory abstract dependently over 139 | explicit dynamic things. In Haskell, we can simulate this behaviour 140 | by abstracting dependently at the type level and non-dependently over 141 | the singleton representative. We translate (from Agda notation to 142 | Haskell): 143 | \[ 144 | (n\!:\!|Nat|)\to T \qquad \leadsto \qquad |forall (n :: Nat). Natty n -> |T 145 | \] 146 | Thus equipped, we may write 147 | 148 | > vchop :: Natty m -> Vec (m :+ n) x -> (Vec m x, Vec n x) 149 | > vchop Zy xs = (V0, xs) 150 | > vchop (Sy m) (x :> xs) = (x :> ys, zs) 151 | > where (ys, zs) = vchop m xs 152 | 153 | There may be an argument from implementation inertia in favour of this 154 | means of dependent quantification, but it proliferates representations 155 | of cognate notions, which is an eccentric way to keep things simple. 156 | 157 | Moreover, we can only construct $\Pi$-types with domains admitting the 158 | singleton construction. Whilst Monnier and 159 | Haguenauer~\cite{MonnierH10} have given a generic treatment of the 160 | singleton construction, their result is not reproducible in current 161 | GHC because GADTs are not promotable as kinds. We cannot form a 162 | Haskell analogue of 163 | \[ 164 | (n\!:\!|Nat|)\to (|xs|\!:\!|Vec n x|)\to T[|xs|] 165 | \] 166 | but we expect this gap to be plugged in the near future. Promoting 167 | |Vec n x| to a kind perforce involves using numbers not only in terms 168 | and types, but in kinds as well. In the new, more flexible world, the 169 | type/kind distinction is increasingly inconvenient, and a clear 170 | candidate for abolition, as Weirich, Hsu, and Eisenberg 171 | propose~\cite{Weirich13}. 172 | 173 | Meanwhile, a further disturbance is in store if we choose to compute 174 | only the first component returned by |vchop|. Cutting out the suffix 175 | gives us 176 | 177 | %format vtake = "\F{vtake}" 178 | 179 | < vtake :: Natty m -> Vec (m :+ n) x -> Vec m x -- |BAD| 180 | < vtake Zy xs = V0 181 | < vtake (Sy m) (x :> xs) = x :> vtake m xs 182 | 183 | but the resulting type error 184 | 185 | {\scriptsize 186 | \begin{verbatim} 187 | NatVec.lhs:120:44: 188 | Could not deduce (n2 ~ (n1 :+ n0)) 189 | from the context (m ~ 'S n1) 190 | bound by a pattern with constructor 191 | Sy :: forall (n :: Nat). Natty n -> Natty ('S n), 192 | in an equation for `vtake' 193 | at NatVec.lhs:120:10-13 194 | or from ((m :+ n) ~ 'S n2) 195 | bound by a pattern with constructor 196 | :> :: forall x (n :: Nat). 197 | x -> Vec n x -> Vec ('S n) x, 198 | in an equation for `vtake' 199 | at NatVec.lhs:120:18-24 200 | `n2' is a rigid type variable bound by 201 | a pattern with constructor 202 | :> :: forall x (n :: Nat). 203 | x -> Vec n x -> Vec ('S n) x, 204 | in an equation for `vtake' 205 | at NatVec.lhs:120:18 206 | Expected type: Vec (n1 :+ n0) x 207 | Actual type: Vec n2 x 208 | In the second argument of `vtake', namely `xs' 209 | In the second argument of `(:>)', namely `vtake m xs' 210 | In the expression: x :> vtake m xs 211 | \end{verbatim} 212 | } 213 | 214 | \noindent 215 | amounts to the fact that it is not clear how to instantiate |n| in the 216 | recursive call. It takes sophisticated reasoning about addition to 217 | realise that |(m :+)| is injective. To GHC, it is just an unknown 218 | axiomatised function. The problem did not arise for |vchop|, because 219 | relaying the suffix, |zs|, from the recursive output to the result 220 | makes clear that the same |n| is needed in both places. This |n| is 221 | not needed at run time, but without it there is no way to see that the 222 | program makes sense. 223 | 224 | The upshot is that there are data which, despite being static, must be 225 | made explicit. One way to manifest them is via `proxy types', e.g., 226 | 227 | %format kappa = "\kappa" 228 | 229 | > data Proxy :: kappa -> * where 230 | > Proxy :: Proxy i 231 | 232 | As you can see, the only dynamic information in \,|Proxy i|\, is 233 | definedness, which there is never the need to check. Kind polymorphism 234 | allows us to declare the proxy type once and for all. The only point 235 | of a proxy is to point out that it has the same type at its binding 236 | and its usage sites. Although it is compulsory to instantiate 237 | quantifiers by inference, proxies let us rig the guessing game so that 238 | GHC can win it. We repair the definition of |vtake| thus: 239 | 240 | > vtake :: Natty m -> Proxy n -> Vec (m :+ n) x -> Vec m x 241 | > vtake Zy n xs = V0 242 | > vtake (Sy m) n (x :> xs) = x :> vtake m n xs 243 | 244 | \begin{sloppypar} 245 | Of course, when calling |vtake|, we need to get a proxy from somewhere. If 246 | we do not already have one, we can write |(Proxy :: Proxy t)| for the 247 | relevant type level expression |t|. The |ScopedTypeVariables| 248 | extension allows us to write open types. If we already have some other 249 | value with the same index, e.g. a singleton value, we can erase it to a 250 | proxy with 251 | \end{sloppypar} 252 | 253 | %format proxy = "\F{proxy}" 254 | 255 | > proxy :: f i -> Proxy i 256 | > proxy _ = Proxy 257 | 258 | The |vtake| example shows that Haskell's |forall|quantifier supports 259 | abstraction over data which play a relevant and computational role in 260 | static types but have no impact on run time execution and are thus 261 | erasable. Most dependently typed languages, with ATS~\cite{CuiDX05} 262 | being a notable exception, do not offer such a quantifier, which seems 263 | to us something of an oversight. Coq's program 264 | extraction~\cite{Paulin89a} and Brady's compilation 265 | method~\cite{brady-thesis} both erase components whose types show that 266 | they cannot be needed in computation, but they do not allow us to make 267 | the promise that ordinary data in types like |Nat| will not be needed 268 | at run time. 269 | 270 | Meanwhile, Agda has an `irrelevant' quantifier~\cite{AbelS12}, 271 | abstracting over data which will even be ignored by the definitional 272 | equality of the type system. In effect, the erasure induced by 273 | `irrelevance' is static as well as dynamic, and is thus more powerful 274 | but less applicable. The Agda translation of |vtake| cannot make |n| 275 | an irrelevant argument, because it is needed to compute the length of 276 | the input, which most certainly is statically relevant. In 277 | contemporary Agda, it seems that this |n| must be present at run time. 278 | 279 | A further example, showing implicit quantification over data used statically 280 | to compute a type but erased at run time, applies an |n|-ary operator to 281 | an |n|-vector of arguments. 282 | 283 | %format varity = "\F{varity}" 284 | 285 | > type family Arity (n :: Nat) (x :: *) :: * 286 | > type instance Arity Z x = x 287 | > type instance Arity (S n) x = x -> Arity n x 288 | 289 | > varity :: Arity n x -> Vec n x -> x 290 | > varity x V0 = x 291 | > varity f (x :> xs) = varity (f x) xs 292 | 293 | Here, pattern matching on the vector delivers sufficient information 294 | about its length to unfold the |Arity| computation. Once again, Agda 295 | would allow |n| to remain implicit in source code, but insist on 296 | retaining |n| at run time. Meanwhile, Brady's `detagging' 297 | optimization~\cite{BradyMM03} would retain |n| but remove the 298 | constructor tag from the representation of vectors, compiling the 299 | above match on the vector to match instead on |n| then project from 300 | the vector. 301 | 302 | Miquel's implicit calculus of constructions (ICC)~\cite{Miquel01} 303 | extends type theory with a static implicit quantifier, the ``implicit 304 | product'', which erases like a System F |forall|quantifier. 305 | % 306 | Barras and Bernado's ICC$^*$~\cite{BarrasB08} adds a static explicit 307 | quantifier to restore decidable type checking. 308 | % 309 | Adding something like the static explicit quantifier (and a 310 | Pollack-style implicit synthesis mechanism) to Agda would restore to 311 | Agda the missing static half of our quantifier matrix. 312 | 313 | To sum up, we have distinguished Haskell's dependent static implicit 314 | |forall|quantifier from the dependent dynamic explicit $\Pi$-types of 315 | dependent type theory. We have seen how to make |forall| static and 316 | explicit with a |Proxy|, and how to make it dynamic and explicit 317 | whenever the singleton construction is possible. However, we have noted 318 | that whilst Haskell struggles to simulate $\Pi$ with |forall|, the reverse 319 | is the case in type theory. What is needed, on both sides, is a more 320 | systematic treatment of the varieties of quantification. 321 | 322 | %if False 323 | 324 | > infixr 4 :> 325 | > instance Show x => Show (Vec n x) where 326 | > show V0 = "V0" 327 | > show (x :> xs) = show x ++ " :> " ++ show xs 328 | 329 | %endif 330 | 331 | %% LocalWords: GADTs PolyKinds KindSignatures MultiParamTypeClasses 332 | %% LocalWords: DataKinds FlexibleInstances RankNTypes TypeOperators 333 | %% LocalWords: FlexibleContexts TypeFamilies NatVec Haskell's Eq ys 334 | %% LocalWords: Ord generalized contrarian Vec Haskell functorial xs 335 | %% LocalWords: intensional normalization associativity vappend GADT 336 | %% LocalWords: commutativity vchop forall Zy Sy Agda zs vtake GHC 337 | %% LocalWords: injective axiomatised definedness polymorphism Coq's 338 | %% LocalWords: ScopedTypeVariables Brady's definitional ary Arity 339 | %% LocalWords: varity detagging optimization infixr Milner's Coq 340 | %% LocalWords: encodings Idris axiomatizes Monnier Haguenauer Hsu 341 | %% LocalWords: promotable Weirich Eisenberg Miquel's Barras 342 | %% LocalWords: Bernado's 343 | -------------------------------------------------------------------------------- /Hasochism/Pics/hasochism1.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slindley/dependent-haskell/f0ea64b4e50464e8c60c11a82a7f432b0fccf122/Hasochism/Pics/hasochism1.jpg -------------------------------------------------------------------------------- /Hasochism/Pics/hasochism2.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slindley/dependent-haskell/f0ea64b4e50464e8c60c11a82a7f432b0fccf122/Hasochism/Pics/hasochism2.jpg -------------------------------------------------------------------------------- /Hasochism/Pics/hasochism3.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slindley/dependent-haskell/f0ea64b4e50464e8c60c11a82a7f432b0fccf122/Hasochism/Pics/hasochism3.jpg -------------------------------------------------------------------------------- /Hasochism/Pics/hasochism4.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slindley/dependent-haskell/f0ea64b4e50464e8c60c11a82a7f432b0fccf122/Hasochism/Pics/hasochism4.jpg -------------------------------------------------------------------------------- /Hasochism/Pies.lhs: -------------------------------------------------------------------------------- 1 | %if False 2 | 3 | > {-# LANGUAGE GADTs, PolyKinds, KindSignatures, MultiParamTypeClasses, 4 | > DataKinds, FlexibleInstances, RankNTypes, FlexibleContexts, 5 | > TypeOperators, TypeFamilies, ScopedTypeVariables #-} 6 | 7 | > module Pies where 8 | > 9 | > import NatVec 10 | > import Control.Applicative 11 | > import Data.Foldable 12 | > import Data.Traversable 13 | 14 | %endif 15 | 16 | %format read = "\F{read}" 17 | 18 | %format :**: = ":\!\!*\!*\!\!:" 19 | %format :&&: = ":\!\!\&\!\&\!\!:" 20 | 21 | 22 | %format natter = "\F{natter}" 23 | %format natty = "\F{natty}" 24 | %format vcopies = "\F{vcopies}" 25 | %format vapp = "\F{vapp}" 26 | %format pure = "\F{pure}" 27 | %format traverse = "\F{traverse}" 28 | 29 | %format fmap = "\F{fmap}" 30 | %format fmapDefault = "\F{fmapDefault}" 31 | %format foldMapDefault = "\F{foldMapDefault}" 32 | %format foldMap = "\F{foldMap}" 33 | 34 | We have already seen that singletons like |Natty| simulate a dependent 35 | dynamic explicit quantifier, corresponding to the explicit $\Pi$-type 36 | of type theory: Agda's $(x\!:\!S)\to T$. Implementations of type 37 | theory, following Pollack's lead~\cite{Pollack90}, often support a 38 | dependent dynamic \emph{implicit} quantifier, the $\{x\!:\!S\}\to T$ 39 | of Agda, allowing type constraints to induce the synthesis of useful 40 | information. The method is Milner's---substitution arising from 41 | unification problems generated by the typechecker---but the direction 42 | of inference runs from types to programs, rather than the other way 43 | around. 44 | 45 | The Haskell analogue of the implicit $\Pi$ is constructed with 46 | singleton \emph{classes}. For example, the following |NATTY| type 47 | class defines a single method |natty|, delivering the |Natty| 48 | singleton corresponding to each promoted |Nat|. A |NATTY| number is 49 | known at run time, despite not being given explicitly. 50 | 51 | > class NATTY (n :: Nat) where 52 | > natty :: Natty n 53 | > 54 | > instance NATTY Z where 55 | > natty = Zy 56 | > 57 | > instance NATTY n => NATTY (S n) where 58 | > natty = Sy natty 59 | 60 | For example, we may write a more implicit version of |vtake|: 61 | 62 | %format vtrunc = "\F{vtrunc}" 63 | 64 | > vtrunc :: NATTY m => Proxy n -> Vec (m :+ n) x -> Vec m x 65 | > vtrunc = vtake natty 66 | 67 | The return type determines the required length, so we can leave 68 | the business of singleton construction to instance inference. 69 | 70 | < > vtrunc Proxy (1 :> 2 :> 3 :> 4 :> V0) :: Vec (S (S Z)) Int 71 | < 1 :> 2 :> V0 72 | 73 | \subsection{Instances for Indexed Types} 74 | 75 | It is convenient to omit singleton arguments when the machine can 76 | figure them out, but we are entitled to ask whether the additional 77 | cost of defining singleton classes as well as singleton types is worth 78 | the benefit. However, there is a situation where we have no choice but 79 | to work implicitly: we cannot abstract an |instance| over a singleton 80 | type, but we can constrain it. For example, the |Applicative| 81 | instance~\cite{McbrideP08} for vectors requires a |NATTY| constraint. 82 | 83 | > instance NATTY n => Applicative (Vec n) where 84 | > pure = vcopies natty 85 | > (<*>) = vapp 86 | 87 | where |vcopies| needs to inspect a run time length to make the right number of 88 | copies---we are obliged to define a helper function: 89 | 90 | > vcopies :: forall n x. Natty n -> x -> Vec n x 91 | > vcopies Zy x = V0 92 | > vcopies (Sy n) x = x :> vcopies n x 93 | 94 | Meanwhile, |vapp| is pointwise application, requiring only static knowledge 95 | of the length. 96 | 97 | > vapp :: forall n s t. Vec n (s -> t) -> Vec n s -> Vec n t 98 | > vapp V0 V0 = V0 99 | > vapp (f :> fs) (s :> ss) = f s :> vapp fs ss 100 | 101 | We note that simply defining |(<*>)| by pattern matching in place 102 | 103 | < instance NATTY n => Applicative (Vec n) where -- |BAD| 104 | < pure = vcopies natty 105 | < V0 <*> V0 = V0 106 | < (f :> fs) <*> (s :> ss) = f s :> (fs <*> ss) 107 | 108 | yields an error in the step case, where |n ~ S m| but |NATTY m| cannot 109 | be deduced. \emph{We} know that the |NATTY n| instance must be a 110 | |NATTY (S m)| instance which can arise only via an instance 111 | declaration which presupposes |NATTY m|. However, such an argument via 112 | `inversion' does not explain how to construct the method dictionary 113 | for |NATTY m| from that of |NATTY (S m)|. When we work with |Natty| 114 | explicitly, the corresponding inversion is just what we get from 115 | pattern matching. The irony here is that |(<*>)| does not need the 116 | singleton at all! 117 | 118 | Although we are obliged to define the helper functions, |vcopies| and 119 | |vapp|, we could keep them local to their usage sites inside the 120 | instance declaration. We choose instead to expose them: it can be 121 | convenient to call |vcopies| rather than |pure| when a |Natty n| value 122 | is to hand but a |NATTY n| dictionary is not; |vapp| needs neither. 123 | 124 | To finish the |Applicative| instance, we must ensure that |Vec n| is 125 | a |Functor|. In fact, vectors are |Traversable|, hence also |Foldable| 126 | |Functor|s in the default way, without need for a |NATTY| 127 | constraint. 128 | 129 | > instance Traversable (Vec n) where 130 | > traverse f V0 = pure V0 131 | > traverse f (x :> xs) = (:>) <$> f x <*> traverse f xs 132 | > 133 | > instance Foldable (Vec n) where 134 | > foldMap = foldMapDefault 135 | > 136 | > instance Functor (Vec n) where 137 | > fmap = fmapDefault 138 | 139 | \subsection{Matrices and a Monad} 140 | 141 | It is quite handy that |Vec n| is both |Applicative| and |Traversable|. 142 | If we define a |Matrix| as a vertical vector of height |h| containing 143 | horizontal vectors of width |w|, thus (arranging |Matrix|'s arguments 144 | conveniently for the tiling library later in the paper), 145 | 146 | %format unMat = "\F{unMat}" 147 | 148 | > data Matrix :: * -> (Nat, Nat) -> * where 149 | > Mat :: {unMat :: Vec h (Vec w a)} -> Matrix a (Pair w h) 150 | 151 | %if False 152 | 153 | > instance Show x => Show (Matrix x (Pair w h)) where 154 | > show = show . (foldMap ((:[]) . foldMap (:[]))) . unMat 155 | 156 | %endif 157 | 158 | \noindent 159 | we get transposition cheaply, provided we know the width. 160 | 161 | %format xpose = "\F{transpose}" 162 | %format sequenceA = "\F{sequenceA}" 163 | 164 | > xpose :: NATTY w => Matrix a (Pair w h) -> Matrix a (Pair h w) 165 | > xpose = Mat . sequenceA . unMat 166 | 167 | The width information really is used at run time, and is otherwise 168 | unobtainable in the degenerate case when the height is |Z|: |xpose| must 169 | know how many |V0|s to deliver. 170 | 171 | %format join = "\F{join}" 172 | 173 | Completists may also be interested to define the |Monad| instance 174 | for vectors whose |join| is given by the diagonal of a matrix. 175 | This fits the |Applicative| instance, whose |(<*>)| method more directly 176 | captures the notion of `corresponding positions'. 177 | 178 | %format vhead = "\F{vhead}" 179 | %format vtail = "\F{vtail}" 180 | %format diagonal = "\F{diag}" 181 | %format return = "\F{return}" 182 | 183 | > vtail :: Vec (S n) x -> Vec n x 184 | > vtail (_ :> xs) = xs 185 | > 186 | > diagonal :: Matrix x (Pair n n) -> Vec n x 187 | > diagonal (Mat V0) = V0 188 | > diagonal (Mat ((x :> _) :> xss)) = x :> diagonal (Mat (fmap vtail xss)) 189 | > 190 | > instance NATTY n => Monad (Vec n) where 191 | > return = pure 192 | > xs >>= f = diagonal (Mat (fmap f xs)) 193 | 194 | Gibbons (in communication with McBride and Paterson~\cite{McbrideP08}) notes that the 195 | |diagonal| construction for unsized lists does not yield a monad, because 196 | the associativity law fails in the case of `ragged' lists of lists. By 197 | using sized vectors, we square away the problem cases. 198 | 199 | 200 | \subsection{Exchanging Explicit and Implicit} 201 | 202 | Some interplay between the explicit and implicit $\Pi$-types is 203 | inevitable. Pollack wisely anticipated situations where argument 204 | synthesis fails because the constraints are too difficult or too few, 205 | and provides a way to override the default implicit behaviour 206 | manually. In Agda, if $f : \{x\!:\!S\}\to T$, then one may write 207 | $f\:\{s\}$ to give the argument. 208 | 209 | The Hindley-Milner type system faces the same issue: even though 210 | unification is more tractable, we still encounter terms like |const 211 | True undefined :: Bool| where we do not know which type to give 212 | |undefined|---parametric polymorphism ensures that we don't need to 213 | know. As soon as we lose parametricity, e.g. in |show . read|, the 214 | ambiguity of the underconstrained type is a problem and rightly yields 215 | a type error. The `manual override' takes the form of a type annotation, 216 | which may need to refer to type variables in scope. 217 | 218 | As we have already seen, the |natty| method allows us to extract an 219 | explicit singleton whenever we have implicit run time knowledge of a value. 220 | Occasionally, however, we must work the other way around. Suppose we have 221 | an explicit |Natty n| to hand, but would like to 222 | use it in a context with an implicit |NATTY n| type class constraint. 223 | We can cajole GHC into building us a |NATTY n| dictionary as follows: 224 | 225 | > natter :: Natty n -> (NATTY n => t) -> t 226 | > natter Zy t = t 227 | > natter (Sy n) t = natter n t 228 | 229 | This may look like an obfuscated identity function, but its type tells 230 | us otherwise. The |t| being passed along recursively is successively 231 | but silently precomposed with the dictionary transformer generated 232 | from the |instance NATTY n => NATTY (S n)| declaration. Particularly 233 | galling, however, is the fact that the dictionary thus constructed 234 | contains just an exact replica of the |Natty n| value which |natter| 235 | has traversed. 236 | 237 | We have completed our matrix of dependent quantifiers involving the 238 | kind |Nat| and two ways (neither of which is the type |Nat|) to give 239 | its inhabitants run time representation, |NATTY| and |Natty|, which 240 | are only clumsily interchangeable despite the former wrapping the 241 | latter. We could (and indeed SHE does) provide a more pleasing 242 | notation to make the dynamic quantifiers look like $\Pi$-types and 243 | their explicit instantiators look like ordinary data, but the 244 | awkwardness is more than skin deep. 245 | 246 | %$% 247 | 248 | 249 | 250 | 251 | %% LocalWords: PolyKinds KindSignatures MultiParamTypeClasses Agda 252 | %% LocalWords: DataKinds FlexibleInstances RankNTypes TypeOperators 253 | %% LocalWords: FlexibleContexts TypeFamilies ScopedTypeVariables Zy 254 | %% LocalWords: NatVec Applicative Foldable Traversable Agda's Sy fs 255 | %% LocalWords: Milner's typechecker Haskell vtake vtrunc Vec vapp 256 | %% LocalWords: vcopies forall pointwise ss Functor xs foldMap fmap 257 | %% LocalWords: foldMapDefault fmapDefault Monad unMat xpose vtail 258 | %% LocalWords: sequenceA Completists xss unsized monad Hindley Bool 259 | %% LocalWords: associativity Milner const polymorphism GHC GADTs 260 | %% LocalWords: parametricity underconstrained precomposed 261 | %% LocalWords: Strathclyde instantiators 262 | -------------------------------------------------------------------------------- /Hasochism/hasochism.bib: -------------------------------------------------------------------------------- 1 | @TechReport{aitken.reppy, 2 | author = {William Aitken and John Reppy}, 3 | title = {Abstract Value Constructors}, 4 | institution = {Cornell University}, 5 | year = 1992, 6 | number = {TR 92-1290}} 7 | 8 | @phdthesis{norell:thesis, 9 | author = {Ulf Norell}, 10 | title = {Towards a practical programming language based on dependent type 11 | theory}, 12 | school = {Department of Computer Science and Engineering, Chalmers University of Technology}, 13 | year = 2007, 14 | month = {September}, 15 | } 16 | 17 | @Unpublished{she, 18 | author = {Conor McBride}, 19 | title = {The {S}trathclyde {H}askell {E}nhancement}, 20 | note = {\url{https://personal.cis.strath.ac.uk/conor.mcbride/pub/she/}}, 21 | year = 2013} 22 | 23 | @inproceedings{Weirich13, 24 | author = {Stephanie Weirich and Justin Hsu and Richard A. Eisenberg}, 25 | title = {Towards dependently typed {Haskell}: {System FC} with kind equality}, 26 | booktitle = {ICFP}, 27 | year = 2013, 28 | publisher = {ACM} 29 | } 30 | 31 | @inproceedings{WadlerB89, 32 | author = {Philip Wadler and 33 | Stephen Blott}, 34 | title = {How to Make ad-hoc Polymorphism Less ad-hoc}, 35 | booktitle = {POPL}, 36 | year = {1989}, 37 | pages = {60-76}, 38 | publisher = {ACM}, 39 | ee = {http://doi.acm.org/10.1145/75277.75283}, 40 | bibsource = {DBLP, http://dblp.uni-trier.de} 41 | } 42 | 43 | @book{ML, 44 | author = {Robin Milner and 45 | Mads Tofte and 46 | Robert Harper}, 47 | title = {The Definition of standard {ML}}, 48 | publisher = {MIT Press}, 49 | year = {1990}, 50 | OPTisbn = {978-0-262-63132-7}, 51 | pages = {I-XI, 1-101}, 52 | bibsource = {DBLP, http://dblp.uni-trier.de} 53 | } 54 | 55 | @article{Milner78, 56 | author = {Robin Milner}, 57 | title = {A Theory of Type Polymorphism in Programming}, 58 | journal = {J. Comput. Syst. Sci.}, 59 | volume = {17}, 60 | number = {3}, 61 | year = {1978}, 62 | pages = {348-375}, 63 | ee = {http://dx.doi.org/10.1016/0022-0000(78)90014-4}, 64 | bibsource = {DBLP, http://dblp.uni-trier.de} 65 | } 66 | 67 | @Unpublished{McBride00:case-talk, 68 | author = {Conor McBride}, 69 | title = {A {C}ase {F}or {D}ependent {F}amilies}, 70 | note = {Seminar at {LFCS}, Edinburgh. 71 | \url{http://www.strictlypositive.org/a-case/}}, 72 | year = {2000} 73 | } 74 | 75 | @UNPUBLISHED{Pollack90, 76 | AUTHOR = {Robert Pollack}, 77 | TITLE = {Implicit Syntax}, 78 | NOTE = {Informal Proceedings of First Workshop on 79 | Logical Frameworks, Antibes}, 80 | YEAR = {1990}, 81 | OPTMONTH = MAY 82 | } 83 | 84 | @inproceedings{Paulin89a, 85 | author = {Christine Paulin-Mohring}, 86 | OPTaddress = {Austin}, 87 | booktitle = {POPL}, 88 | OPTmonth = jan, 89 | publisher = {ACM}, 90 | title = {Extracting ${F}_{\omega}$'s programs from proofs in 91 | the {Calculus of Constructions}}, 92 | year = {1989} 93 | } 94 | 95 | @phdthesis{ brady-thesis, 96 | author = {Edwin Brady}, 97 | title = {Practical Implementation of a Dependently Typed Functional Programming Language}, 98 | year = 2005, 99 | school = {University of Durham} 100 | } 101 | 102 | 103 | @inproceedings{BradyMM03, 104 | author = {Edwin Brady and 105 | Conor McBride and 106 | James McKinna}, 107 | title = {Inductive Families Need Not Store Their Indices}, 108 | booktitle = {TYPES}, 109 | year = {2003}, 110 | pages = {115--129}, 111 | ee = {http://dx.doi.org/10.1007/978-3-540-24849-1_8}, 112 | crossref = {DBLP:conf/types/2003}, 113 | bibsource = {DBLP, http://dblp.uni-trier.de} 114 | } 115 | 116 | @proceedings{DBLP:conf/types/2003, 117 | OPTeditor = {Stefano Berardi and 118 | Mario Coppo and 119 | Ferruccio Damiani}, 120 | title = {Types for Proofs and Programs, International Workshop, TYPES 121 | 2003, Torino, Italy, April 30 - May 4, 2003, Revised Selected 122 | Papers}, 123 | booktitle = {TYPES}, 124 | publisher = {Springer}, 125 | series = {LNCS}, 126 | volume = {3085}, 127 | year = {2004}, 128 | OPTisbn = {3-540-22164-6}, 129 | bibsource = {DBLP, http://dblp.uni-trier.de} 130 | } 131 | 132 | @inproceedings{Kiselyov07position:lightweight, 133 | author = {Oleg Kiselyov and 134 | Shan, Chung-chieh}, 135 | title = {Lightweight Static Resources: Sexy types for 136 | embedded and systems programming}, 137 | booktitle = {TFP}, 138 | year = {2007} 139 | } 140 | 141 | @inproceedings{EisenbergW12, 142 | author = {Richard A. Eisenberg and 143 | Stephanie Weirich}, 144 | title = {Dependently typed programming with singletons}, 145 | booktitle = {Haskell}, 146 | publisher = {ACM}, 147 | year = {2012}, 148 | pages = {117-130}, 149 | ee = {http://doi.acm.org/10.1145/2364506.2364522}, 150 | bibsource = {DBLP, http://dblp.uni-trier.de} 151 | } 152 | 153 | @inproceedings{YorgeyWCJVM12, 154 | author = {Brent A. Yorgey and 155 | Stephanie Weirich and 156 | Julien Cretin and 157 | Simon L. {Peyton Jones} and 158 | Dimitrios Vytiniotis and 159 | Jos{\'e} Pedro Magalh{\~a}es}, 160 | title = {Giving {H}askell a promotion}, 161 | booktitle = {TLDI}, 162 | year = {2012}, 163 | publisher = {ACM}, 164 | pages = {53--66}, 165 | ee = {http://doi.acm.org/10.1145/2103786.2103795}, 166 | bibsource = {DBLP, http://dblp.uni-trier.de} 167 | } 168 | 169 | @inproceedings{CuiDX05, 170 | author = {Sa Cui and 171 | Kevin Donnelly and 172 | Hongwei Xi}, 173 | title = {{ATS}: A Language That Combines Programming with Theorem Proving}, 174 | booktitle = {FroCoS}, 175 | year = {2005}, 176 | publisher = {Springer}, 177 | volume = 3717, 178 | series = {LNCS}, 179 | pages = {310--320}, 180 | ee = {http://dx.doi.org/10.1007/11559306_19}, 181 | bibsource = {DBLP, http://dblp.uni-trier.de} 182 | } 183 | 184 | @inproceedings{SulzmannCJD07, 185 | author = {Martin Sulzmann and 186 | Manuel M. T. Chakravarty and 187 | Simon L. Peyton Jones and 188 | Kevin Donnelly}, 189 | title = {{System F} with type equality coercions}, 190 | booktitle = {TLDI}, 191 | year = {2007}, 192 | publisher = {ACM}, 193 | pages = {53--66}, 194 | ee = {http://doi.acm.org/10.1145/1190315.1190324}, 195 | bibsource = {DBLP, http://dblp.uni-trier.de} 196 | } 197 | 198 | @article{Huet97, 199 | author = {G{\'e}rard P. Huet}, 200 | title = {The {Z}ipper}, 201 | journal = {J. Funct. Program.}, 202 | volume = {7}, 203 | number = {5}, 204 | year = {1997}, 205 | pages = {549-554}, 206 | ee = {http://journals.cambridge.org/action/displayAbstract?aid=44121}, 207 | bibsource = {DBLP, http://dblp.uni-trier.de} 208 | } 209 | 210 | @article{mcbride2001derivative, 211 | title={The derivative of a regular type is its type of one-hole contexts}, 212 | author={Conor McBride}, 213 | journal={Unpublished manuscript}, 214 | year={2001}, 215 | } 216 | 217 | @article{McbrideP08, 218 | author = {Conor McBride and 219 | Ross Paterson}, 220 | title = {Applicative programming with effects}, 221 | journal = {J. Funct. Program.}, 222 | volume = {18}, 223 | number = {1}, 224 | year = {2008}, 225 | pages = {1--13}, 226 | ee = {http://dx.doi.org/10.1017/S0956796807006326}, 227 | bibsource = {DBLP, http://dblp.uni-trier.de} 228 | } 229 | 230 | @article{McBrideM04, 231 | author = {Conor McBride and 232 | James McKinna}, 233 | title = {The view from the left}, 234 | journal = {J. Funct. Program.}, 235 | volume = {14}, 236 | number = {1}, 237 | year = {2004}, 238 | pages = {69--111}, 239 | ee = {http://dx.doi.org/10.1017/S0956796803004829}, 240 | bibsource = {DBLP, http://dblp.uni-trier.de} 241 | } 242 | 243 | @inproceedings{Magalhaes12, 244 | author = {Magalh\~{a}es, Jos{\'e} Pedro}, 245 | title = {The right kind of generic programming}, 246 | booktitle = {WGP}, 247 | year = {2012}, 248 | pages = {13--24}, 249 | numpages = {12}, 250 | publisher = {ACM}, 251 | } 252 | 253 | @misc{McBride11, 254 | author = {Conor McBride}, 255 | title = {Kleisli arrows of outrageous fortune}, 256 | year = {2011}, 257 | note = {Accepted for publication. \\ 258 | \url{https://personal.cis.strath.ac.uk/conor.mcbride/Kleisli.pdf}} 259 | } 260 | 261 | @inproceedings{Reynolds02, 262 | author = {John C. Reynolds}, 263 | title = {Separation Logic: A Logic for Shared Mutable Data Structures}, 264 | booktitle = {LICS}, 265 | year = {2002}, 266 | pages = {55--74}, 267 | ee = {http://doi.ieeecomputersociety.org/10.1109/LICS.2002.1029817}, 268 | publisher = {IEEE Computer Society}, 269 | bibsource = {DBLP, http://dblp.uni-trier.de} 270 | } 271 | 272 | @article{AbelS12, 273 | author = {Andreas Abel and 274 | Gabriel Scherer}, 275 | title = {On Irrelevance and Algorithmic Equality in Predicative Type 276 | Theory}, 277 | journal = {Logical Methods in Computer Science}, 278 | volume = {8}, 279 | number = {1}, 280 | year = {2012}, 281 | ee = {http://dx.doi.org/10.2168/LMCS-8(1:29)2012}, 282 | bibsource = {DBLP, http://dblp.uni-trier.de} 283 | } 284 | 285 | @inproceedings{Miquel01, 286 | author = {Alexandre Miquel}, 287 | title = {The Implicit Calculus of Constructions}, 288 | booktitle = {TLCA}, 289 | year = {2001}, 290 | publisher = {Springer}, 291 | series = {LNCS}, 292 | pages = {344--359}, 293 | ee = {http://dx.doi.org/10.1007/3-540-45413-6_27}, 294 | bibsource = {DBLP, http://dblp.uni-trier.de} 295 | } 296 | 297 | @inproceedings{BarrasB08, 298 | author = {Bruno Barras and 299 | Bruno Bernardo}, 300 | title = {The Implicit Calculus of Constructions as a Programming 301 | Language with Dependent Types}, 302 | booktitle = {FoSSaCS}, 303 | series = {LNCS}, 304 | volume = {4962}, 305 | year = {2008}, 306 | pages = {365--379}, 307 | ee = {http://dx.doi.org/10.1007/978-3-540-78499-9_26}, 308 | bibsource = {DBLP, http://dblp.uni-trier.de} 309 | } 310 | 311 | @inproceedings{MonnierH10, 312 | author = {Stefan Monnier and 313 | David Haguenauer}, 314 | title = {Singleton types here, singleton types there, singleton types 315 | everywhere}, 316 | booktitle = {PLPV}, 317 | publisher = {ACM}, 318 | year = {2010}, 319 | pages = {1-8}, 320 | ee = {http://doi.acm.org/10.1145/1707790.1707792}, 321 | bibsource = {DBLP, http://dblp.uni-trier.de} 322 | } 323 | -------------------------------------------------------------------------------- /Hasochism/talks/haskell2013/Makefile: -------------------------------------------------------------------------------- 1 | all: hasochism.pdf 2 | 3 | hasochism.tex: hasochism.lhs 4 | if [ -f "hasochism.tex" ]; then chmod +w hasochism.tex; fi 5 | lhs2TeX -o hasochism.tex hasochism.lhs 6 | chmod -w hasochism.tex 7 | 8 | hasochism.aux: hasochism.tex 9 | pdflatex hasochism 10 | 11 | #hasochism.bbl: hasochism.aux hasochism.bib 12 | # bibtex hasochism 13 | 14 | hasochism.pdf: hasochism.aux # hasochism.bbl 15 | pdflatex hasochism 16 | pdflatex hasochism 17 | 18 | clean: 19 | rm -f *.aux *.log *.bbl *.blg *.ptb *.nav *.out *.snm *.toc *.vrb *~ \ 20 | hasochism.tex 21 | 22 | clean-all: clean 23 | rm hasochism.pdf 24 | -------------------------------------------------------------------------------- /Hasochism/talks/haskell2013/mathpartir.sty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/slindley/dependent-haskell/f0ea64b4e50464e8c60c11a82a7f432b0fccf122/Hasochism/talks/haskell2013/mathpartir.sty -------------------------------------------------------------------------------- /OldBox/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module ANSIEscapes 2 | (upLine, 3 | downLine, 4 | up, 5 | down, 6 | forward, 7 | backward, 8 | killLine, 9 | restoreCursor, 10 | saveCursor, 11 | clearScreen, 12 | yellow, 13 | brown, 14 | red, 15 | blue, 16 | purple, 17 | green, 18 | orange, 19 | white, 20 | yellowOnGrey, 21 | brownOnGrey, 22 | redOnGrey, 23 | blueOnGrey, 24 | purpleOnGrey, 25 | greenOnGrey, 26 | whiteOnGrey, 27 | onBlack, 28 | onGrey, 29 | onGreyEsc, 30 | onWhiteEsc, 31 | resetCursor, 32 | initTermSize) where 33 | 34 | data Dir = UpDir | DownDir | RightDir | LeftDir 35 | 36 | instance Show Dir where 37 | show UpDir = "A" 38 | show DownDir = "B" 39 | show RightDir = "C" 40 | show LeftDir = "D" 41 | 42 | upLine = putStr "\ESC[1A" 43 | downLine = putStr "\ESC[1B" 44 | 45 | up = moveCursor UpDir 46 | down = moveCursor DownDir 47 | backward = moveCursor LeftDir 48 | forward = moveCursor RightDir 49 | 50 | moveCursor :: Dir -> Int -> IO () 51 | moveCursor dir 0 = return () 52 | moveCursor dir n = putStr $ "\ESC[" ++ show n ++ show dir 53 | 54 | killLine = escape "K" 55 | restoreCursor = escape "u" 56 | saveCursor = escape "s" 57 | clearScreen = escape "2J" 58 | initTermSize = (escape "[=3h") 59 | 60 | resetCursor = escape "0;0H" 61 | 62 | escape e = putStr $ "\ESC[" ++ e 63 | 64 | yellow str = "\ESC[1;33m" ++ str ++ "\ESC[0m" 65 | brown str = "\ESC[0;33m" ++ str ++ "\ESC[0m" 66 | blue str = "\ESC[1;34m" ++ str ++ "\ESC[0m" 67 | red str = "\ESC[1;31m" ++ str ++ "\ESC[0m" 68 | green str = "\ESC[1;32m" ++ str ++ "\ESC[0m" 69 | purple str = "\ESC[1;35m" ++ str ++ "\ESC[0m" 70 | white str = "\ESC[37m" ++ str ++ "\ESC[0m" 71 | 72 | 73 | 74 | --Be careful, these assume someone else will reset the background colour 75 | yellowOnGrey str = "\ESC[1;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 76 | brownOnGrey str = "\ESC[0;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 77 | blueOnGrey str = "\ESC[1;34m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 78 | redOnGrey str = "\ESC[1;31m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 79 | greenOnGrey str = "\ESC[1;32m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 80 | purpleOnGrey str = "\ESC[1;35m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 81 | whiteOnGrey str = "\ESC[37m" ++ str ++ "\ESC[0m" 82 | 83 | onBlack str = "\ESC[40m" ++ str ++ "\ESC[0m" 84 | onGrey str = onGreyEsc ++ str ++ onWhiteEsc 85 | onGreyEsc = "\ESC[47m" 86 | onWhiteEsc = "\ESC[0m" 87 | orange str = str -------------------------------------------------------------------------------- /OldBox/Box.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators, 2 | RankNTypes, PolyKinds, ScopedTypeVariables, FlexibleInstances #-} 3 | 4 | module Box where 5 | 6 | import Data.Monoid 7 | import Control.Applicative 8 | import Data.Foldable 9 | import Data.Traversable 10 | 11 | data Nat = Z | S Nat 12 | 13 | data Natty :: Nat -> * where 14 | Zy :: Natty Z 15 | Sy :: Natty n -> Natty (S n) 16 | 17 | class NATTY (n :: Nat) where 18 | natty :: Natty n 19 | 20 | instance NATTY Z where 21 | natty = Zy 22 | 23 | instance NATTY n => NATTY (S n) where 24 | natty = Sy natty 25 | 26 | -- natter effectively converts an explicit Natty to an implicit NATTY 27 | natter :: Natty x -> (NATTY x => t) -> t 28 | natter Zy t = t 29 | natter (Sy x) t = natter x t 30 | 31 | {- plus -} 32 | type family (m :: Nat) :+ (n :: Nat) :: Nat 33 | type instance Z :+ n = n 34 | type instance S m :+ n = S (m :+ n) 35 | 36 | (/+/) :: Natty m -> Natty n -> Natty (m :+ n) 37 | Zy /+/ n = n 38 | Sy m /+/ n = Sy (m /+/ n) 39 | 40 | {- minus -} 41 | type family (m :: Nat) :- (n :: Nat) :: Nat 42 | type instance Z :- n = Z 43 | type instance S m :- Z = S m 44 | type instance S m :- S n = (m :- n) 45 | 46 | (/-/) :: Natty m -> Natty n -> Natty (m :- n) 47 | Zy /-/ n = Zy 48 | Sy m /-/ Zy = Sy m 49 | Sy m /-/ Sy n = m /-/ n 50 | 51 | {- max -} 52 | type family Max (m :: Nat) (n :: Nat) :: Nat 53 | type instance Max Z n = n 54 | type instance Max (S m) Z = S m 55 | type instance Max (S m) (S n) = S (Max m n) 56 | 57 | maxn :: Natty m -> Natty n -> Natty (Max m n) 58 | maxn Zy n = n 59 | maxn (Sy m) Zy = Sy m 60 | maxn (Sy m) (Sy n) = Sy (maxn m n) 61 | 62 | 63 | data Cmp :: Nat -> Nat -> * where 64 | LTNat :: ((x :+ S z) ~ y, Max x y ~ y, (x :- y) ~ Z) => Natty z -> Cmp x y 65 | EQNat :: (x ~ y, Max x y ~ x, (x :- y) ~ Z) => Cmp x y 66 | GTNat :: (x ~ (y :+ S z), Max x y ~ x, (x :- y) ~ S z) => Natty z -> Cmp x y 67 | 68 | cmp :: Natty x -> Natty y -> Cmp x y 69 | cmp Zy Zy = EQNat 70 | cmp Zy (Sy y) = LTNat y 71 | cmp (Sy x) Zy = GTNat x 72 | cmp (Sy x) (Sy y) = case cmp x y of 73 | LTNat z -> LTNat z 74 | EQNat -> EQNat 75 | GTNat z -> GTNat z 76 | 77 | data CmpCuts :: Nat -> Nat -> Nat -> Nat -> * where 78 | LTCuts :: Natty b -> CmpCuts a (S b :+ c) (a :+ S b) c 79 | EQCuts :: CmpCuts a b a b 80 | GTCuts :: Natty b -> CmpCuts (a :+ S b) c a (S b :+ c) 81 | 82 | cmpCuts :: ((a :+ b) ~ (c :+ d)) => Natty a -> Natty b -> Natty c -> Natty d -> CmpCuts a b c d 83 | cmpCuts Zy b Zy d = EQCuts 84 | cmpCuts Zy b (Sy c) d = LTCuts c 85 | cmpCuts (Sy a) b Zy d = GTCuts a 86 | cmpCuts (Sy a) b (Sy c) d = case cmpCuts a b c d of 87 | LTCuts z -> LTCuts z 88 | EQCuts -> EQCuts 89 | GTCuts z -> GTCuts z 90 | 91 | {- 92 | leftCan :: forall a b c t. ((a :+ b) ~ (a :+ c)) => Natty a -> Natty b -> Natty c -> ((b ~ c) => t) -> t 93 | leftCan Zy b c t = t 94 | leftCan (Sy a) b c t = leftCan a b c t 95 | 96 | assocLR :: forall l a b c t. (l ~ ((a :+ b) :+ c)) => Natty a -> Natty b -> Natty c -> ((l ~ (a :+ (b :+ c))) => t) -> t 97 | assocLR Zy b c t = t 98 | assocLR (Sy a) b c t = assocLR a b c t 99 | -} 100 | 101 | data Box :: ((Nat, Nat) -> *) -> (Nat, Nat) -> * where 102 | Stuff :: p xy -> Box p xy 103 | Clear :: Box p xy 104 | Hor :: Natty x1 -> Box p '(x1, y) -> Natty x2 -> Box p '(x2, y) -> Box p '(x1 :+ x2, y) 105 | Ver :: Natty y1 -> Box p '(x, y1) -> Natty y2 -> Box p '(x, y2) -> Box p '(x, y1 :+ y2) 106 | 107 | type s :-> t = forall i. s i -> t i 108 | 109 | ebox :: (p :-> Box q) -> Box p :-> Box q 110 | ebox f (Stuff b) = f b 111 | ebox f Clear = Clear 112 | ebox f (Hor x1 l x2 r) = Hor x1 (ebox f l) x2 (ebox f r) 113 | ebox f (Ver y1 t y2 b) = Ver y1 (ebox f t) y2 (ebox f b) 114 | 115 | class Cut (p :: (Nat, Nat) -> *) where 116 | horCut :: Natty xl -> Natty xr -> p '(xl :+ xr, y) -> (p '(xl, y), p '(xr, y)) 117 | verCut :: Natty yt -> Natty yb -> p '(x, yt :+ yb) -> (p '(x, yt), p '(x, yb)) 118 | 119 | instance Cut p => Cut (Box p) where 120 | horCut xl xr (Stuff p) = (Stuff pl, Stuff pr) where (pl, pr) = horCut xl xr p 121 | horCut xl xr Clear = (Clear, Clear) 122 | horCut xl xr (Hor x1 b1 x2 b2) = case cmpCuts xl xr x1 x2 of 123 | LTCuts z -> let (ll, lr) = horCut xl (Sy z) b1 in (ll, Hor (Sy z) lr x2 b2) 124 | EQCuts -> (b1, b2) 125 | GTCuts z -> let (rl, rr) = horCut (Sy z) xr b2 in (Hor x1 b1 (Sy z) rl, rr) 126 | horCut xl xr (Ver y1 tb y2 bb) = (Ver y1 tl y2 bl, Ver y1 tr y2 br) 127 | where (tl, tr) = horCut xl xr tb ; (bl, br) = horCut xl xr bb 128 | 129 | verCut yl yr (Stuff p) = (Stuff pl, Stuff pr) where (pl, pr) = verCut yl yr p 130 | verCut yl yr Clear = (Clear, Clear) 131 | verCut yl yr (Ver y1 b1 y2 b2) = case cmpCuts yl yr y1 y2 of 132 | LTCuts z -> let (tt, tb) = verCut yl (Sy z) b1 in (tt, Ver (Sy z) tb y2 b2) 133 | EQCuts -> (b1, b2) 134 | GTCuts z -> let (bt, bb) = verCut (Sy z) yr b2 in (Ver y1 b1 (Sy z) bt, bb) 135 | verCut yl yr (Hor x1 tb x2 bb) = (Hor x1 tl x2 bl, Hor x1 tr x2 br) 136 | where (tl, tr) = verCut yl yr tb ; (bl, br) = verCut yl yr bb 137 | 138 | instance Cut p => Monoid (Box p xy) where 139 | mempty = Clear 140 | mappend b Clear = b 141 | mappend Clear b' = b' 142 | mappend b@(Stuff _) _ = b 143 | mappend (Hor x1 b1 x2 b2) b' = Hor x1 (mappend b1 b1') x2 (mappend b2 b2') 144 | where (b1', b2') = horCut x1 x2 b' 145 | mappend (Ver y1 b1 y2 b2) b' = Ver y1 (mappend b1 b1') y2 (mappend b2 b2') 146 | where (b1', b2') = verCut y1 y2 b' 147 | 148 | data Vec :: Nat -> * -> * where 149 | V0 :: Vec Z x 150 | (:>) :: x -> Vec n x -> Vec (S n) x 151 | 152 | vlength :: Vec n x -> Natty n 153 | vlength V0 = Zy 154 | vlength (x :> xs) = Sy (vlength xs) 155 | 156 | instance Show x => Show (Vec n x) where 157 | show = show . foldMap (:[]) 158 | 159 | vcopies :: forall n x.Natty n -> x -> Vec n x 160 | vcopies Zy x = V0 161 | vcopies (Sy n) x = x :> vcopies n x 162 | 163 | vapp :: forall n s t.Vec n (s -> t) -> Vec n s -> Vec n t 164 | vapp V0 V0 = V0 165 | vapp (f :> fs) (s :> ss) = f s :> vapp fs ss 166 | 167 | instance NATTY n => Applicative (Vec n) where 168 | pure = vcopies natty where 169 | (<*>) = vapp where 170 | 171 | instance Traversable (Vec n) where 172 | traverse f V0 = pure V0 173 | traverse f (x :> xs) = (:>) <$> f x <*> traverse f xs 174 | 175 | instance Functor (Vec n) where 176 | fmap = fmapDefault 177 | 178 | instance Foldable (Vec n) where 179 | foldMap = foldMapDefault 180 | 181 | vappend :: Vec m x -> Vec n x -> Vec (m :+ n) x 182 | vappend V0 ys = ys 183 | vappend (x :> xs) ys = x :> vappend xs ys 184 | 185 | vchop :: Natty m -> Natty n -> Vec (m :+ n) x -> (Vec m x, Vec n x) 186 | vchop Zy n xs = (V0, xs) 187 | vchop (Sy m) n (x :> xs) = (x :> ys, zs) where (ys, zs) = vchop m n xs 188 | 189 | data Matrix :: * -> (Nat, Nat) -> * where 190 | Mat :: Vec y (Vec x a) -> Matrix a '(x, y) 191 | 192 | instance Show x => Show (Matrix x '(m, n)) where 193 | show = show . (foldMap ((:[]) . foldMap (:[]))) . unMat 194 | 195 | unMat :: Matrix a '(x,y) -> Vec y (Vec x a) 196 | unMat (Mat m) = m 197 | 198 | instance Cut (Matrix e) where 199 | horCut xl xr (Mat ess) = (Mat (fst <$> lrs), Mat (snd <$> lrs)) where 200 | lrs = vchop xl xr <$> ess 201 | verCut yt yb (Mat ess) = (Mat tess, Mat bess) where 202 | (tess, bess) = vchop yt yb ess 203 | 204 | {- smart constructors for clear boxes -} 205 | clear :: (Natty x, Natty y) -> Box p '(x, y) 206 | clear (x, y) = Clear 207 | 208 | emptyBox :: Box p '(Z, Z) 209 | emptyBox = Clear 210 | 211 | hGap :: Natty x -> Box p '(x, Z) 212 | hGap x = Clear 213 | 214 | vGap :: Natty y -> Box p '(Z, y) 215 | vGap y = Clear 216 | 217 | {- placing boxes -} 218 | 219 | {- 220 | --- lemmas about max --- 221 | 222 | -- we wire this knowledge into the Cmp datatype 223 | 224 | maxAddR :: forall x y z t.Natty x -> Natty y -> ((Max x (x :+ S y) ~ (x :+ S y)) => t) -> t 225 | maxAddR Zy y t = t 226 | maxAddR (Sy x) y t = maxAddR x y t 227 | 228 | maxAddL :: forall x y z t.Natty x -> Natty y -> ((Max (x :+ S y) x ~ (x :+ S y)) => t) -> t 229 | maxAddL x y t = maxAddR x y (maxSym x (x /+/ Sy y) t) 230 | 231 | maxRefl :: forall x y t.Natty x -> ((Max x x ~ x) => t) -> t 232 | maxRefl Zy t = t 233 | maxRefl (Sy x) t = maxRefl x t 234 | 235 | maxSym :: forall x y t.Natty x -> Natty y -> ((Max x y ~ Max y x) => t) -> t 236 | maxSym Zy Zy t = t 237 | maxSym Zy (Sy y) t = t 238 | maxSym (Sy x) Zy t = t 239 | maxSym (Sy x) (Sy y) t = maxSym x y t 240 | ------------------------ 241 | -} 242 | 243 | -- place boxes horizontally 244 | joinH :: (Natty x1, Natty y1) -> (Natty x2, Natty y2) -> 245 | Box p '(x1, y1) -> Box p '(x2, y2) -> Box p '(x1 :+ x2, Max y1 y2) 246 | joinH (x1, y1) (x2, y2) b1 b2 = 247 | case cmp y1 y2 of 248 | LTNat n' -> Hor x1 (Ver y1 b1 (Sy n') (clear (x1, Sy n'))) x2 b2 249 | EQNat -> Hor x1 b1 x2 b2 250 | GTNat n' -> Hor x1 b1 x2 (Ver y2 b2 (Sy n') (clear (x2, Sy n'))) 251 | 252 | -- place boxes vertically 253 | joinV :: (Natty x1, Natty y1) -> (Natty x2, Natty y2) -> 254 | Box p '(x1, y1) -> Box p '(x2, y2) -> Box p '(Max x1 x2, y1 :+ y2) 255 | joinV (x1, y1) (x2, y2) b1 b2 = 256 | case cmp x1 x2 of 257 | LTNat n' -> Ver y1 (Hor x1 b1 (Sy n') (clear (Sy n', y1))) y2 b2 258 | EQNat -> Ver y1 b1 y2 b2 259 | GTNat n' -> Ver y1 b1 y2 (Hor x2 b2 (Sy n') (clear (Sy n', y2))) 260 | 261 | {- cropping -} 262 | type Size w h = (Natty w, Natty h) 263 | type Point x y = (Natty x, Natty y) 264 | 265 | type Region x y w h = (Point x y, Size w h) 266 | 267 | cropper :: Cut p => Region x y w h -> Size s t -> Box p '(s, t) -> Box p '(w, h) 268 | cropper ((x, y), (w, h)) (s, t) b = 269 | fit (s /-/ x, t /-/ y) (w, h) (clip (s, t) (x, y) b) 270 | 271 | clip :: Cut p => Size w h -> Point x y -> Box p '(w, h) -> Box p '(w :- x, h :- y) 272 | clip (w, h) (x, y) b = clipV (w /-/ x, h) y (clipH (w, h) x b) 273 | 274 | clipH :: Cut p => Size w h -> Natty x -> Box p '(w, h) -> Box p '(w :- x, h) 275 | clipH (w, h) x b = 276 | case cmp w x of 277 | GTNat d -> snd (horCut x (Sy d) b) 278 | _ -> Clear 279 | 280 | clipV :: Cut p => Size w h -> Natty y -> Box p '(w, h) -> Box p '(w, h :- y) 281 | clipV (w, h) y b = 282 | case cmp h y of 283 | GTNat d -> snd (verCut y (Sy d) b) 284 | _ -> Clear 285 | 286 | fit :: Cut p => Size w1 h1 -> Size w2 h2 -> Box p '(w1, h1) -> Box p '(w2, h2) 287 | fit (w1, h1) (w2, h2) b = fitV h1 h2 (fitH w1 w2 b) 288 | 289 | fitH :: Cut p => Natty w1 -> Natty w2 -> Box p '(w1, h) -> Box p '(w2, h) 290 | fitH w1 w2 b = 291 | case cmp w1 w2 of 292 | LTNat d -> Hor w1 b (Sy d) Clear 293 | EQNat -> b 294 | GTNat d -> fst (horCut w2 (Sy d) b) 295 | 296 | fitV :: Cut p => Natty h1 -> Natty h2 -> Box p '(w, h1) -> Box p '(w, h2) 297 | fitV h1 h2 b = 298 | case cmp h1 h2 of 299 | LTNat d -> Ver h1 b (Sy d) Clear 300 | EQNat -> b 301 | GTNat d -> fst (verCut h2 (Sy d) b) 302 | 303 | 304 | 305 | {- Min -} 306 | type family Min (m :: Nat) (n :: Nat) :: Nat 307 | type instance Min Z Z = Z 308 | type instance Min Z (S n) = Z 309 | type instance Min (S m) Z = Z 310 | type instance Min (S m) (S n) = S (Min m n) 311 | 312 | minn :: Natty m -> Natty n -> Natty (Min m n) 313 | minn Zy Zy = Zy 314 | minn Zy (Sy n) = Zy 315 | minn (Sy m) Zy = Zy 316 | minn (Sy m) (Sy n) = Sy (minn m n) 317 | 318 | 319 | {-- mess --} 320 | 321 | {- 322 | -- crop with known sizes 323 | cropBox :: Cut p => (Point x y, Size w h) -> Size r s -> Box p '(x :+ (w :+ r), y :+ (h :+ s)) -> Box p '(w, h) 324 | cropBox ((x, y), (w, h)) (r, s) b = 325 | let (_, bxwr) = horCut x (w /+/ r) b in 326 | let (bxw, _) = horCut w r bxwr in 327 | let (_, bxwyhs) = verCut y (h /+/ s) bxw in 328 | let (bxwyh, _) = verCut h s bxwyhs in 329 | bxwyh 330 | 331 | cropBox' :: forall x y w h r s p.(NATTY r, NATTY s, Cut p) => 332 | (Point x y, Size w h) -> Box p '(x :+ (w :+ r), y :+ (h :+ s)) -> Box p '(w, h) 333 | cropBox' region box = cropBox region ((natty, natty) :: Size r s) box 334 | 335 | 336 | -- this seems a rather ridiculous way of doing it... 337 | cropper' :: Cut p => (Point x y, Size w h) -> Size s t -> Box p '(s, t) -> Box p '(w, h) 338 | cropper' ((x, y), (w, h)) (s, t) b = 339 | fit (minn w (s /-/ x), minn h (t /-/ y)) (w, h) (croppy ((x, y), (w, h)) (s, t) b) 340 | 341 | -- this might be the cropping function we actually want 342 | croppy :: Cut p => (Point x y, Size w h) -> Size s t -> Box p '(s, t) -> Box p '(Min w (s :- x), Min h (t :- y)) 343 | croppy ((x, y), (w, h)) (s, t) b = 344 | let (((x', y'), (w', h')), (r', s')) = chopCrop ((x, y), (w, h)) (s, t) in 345 | minLem x s w 346 | (minLem y t h 347 | (cropBox ((x', y'), (w', h')) (r', s') b)) 348 | 349 | -- chop a viewport to ensure it doesn't extend outside the world 350 | -- return the a pair of the chopped viewport and the diff between the 351 | -- chopped viewport and the edge of the world 352 | chopCrop :: (Point x y, Size w h) -> Size s t -> 353 | ((Point (Min x s) (Min y t), 354 | Size (Min w (s :- x)) (Min h (t :- y))), 355 | (Size (s :- (x :+ w)) (t :- (y :+ h)))) 356 | chopCrop ((x, y), (w, h)) (s, t) = 357 | (((minn x s, minn y t), 358 | (minn w (s /-/ x), minn h (t /-/ y))), 359 | (s /-/ (x /+/ w), t /-/ (y /+/ h))) 360 | 361 | {- 362 | to use chopCrop we have to prove: 363 | forall x s w.(Min x s) :+ (Min w (s :- x) :+ (s :- (x :+ w))) ~ s 364 | -} 365 | 366 | {- lemmas about min and minus -} 367 | minLem :: forall x s w t.Natty x -> Natty s -> Natty w -> 368 | (((Min x s :+ (Min w (s :- x) :+ (s :- (x :+ w)))) ~ s) => t) -> t 369 | minLem Zy Zy Zy t = t 370 | minLem Zy Zy (Sy w) t = t 371 | minLem Zy (Sy s) Zy t = t 372 | minLem Zy (Sy s) (Sy w) t = minDiff (Sy w) (Sy s) t 373 | minLem (Sy x) Zy Zy t = t 374 | minLem (Sy x) Zy (Sy w) t = t 375 | minLem (Sy x) (Sy s) Zy t = minLem x s Zy t 376 | minLem (Sy x) (Sy s) (Sy w) t = minLem x s (Sy w) t 377 | 378 | minDiff :: forall x y t.Natty x -> Natty y -> (((Min x y :+ (y :- x)) ~ y) => t) -> t 379 | minDiff Zy Zy t = t 380 | minDiff Zy (Sy y) t = t 381 | minDiff (Sy x) Zy t = t 382 | minDiff (Sy x) (Sy y) t = minDiff x y t 383 | 384 | -} 385 | -------------------------------------------------------------------------------- /OldBox/CharBox.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators, 2 | RankNTypes, PolyKinds, ScopedTypeVariables, MultiParamTypeClasses #-} 3 | 4 | module CharBox where 5 | 6 | import Data.Monoid 7 | import Control.Applicative 8 | import Data.Foldable 9 | import Data.Traversable 10 | 11 | import Box 12 | 13 | type CharMatrix = Matrix Char 14 | type CharBox xy = Box CharMatrix xy 15 | 16 | matrixChar :: Char -> (Natty x, Natty y) -> CharMatrix '(x, y) 17 | matrixChar c (x, y) = Mat (vcopies y (vcopies x c)) 18 | -- alternatively we could do the presumably less efficient: 19 | -- natter x (natter y (Mat (pure (pure c)))) 20 | 21 | renderCharBox' :: (Natty x, Natty y) -> CharBox '(x, y) -> CharMatrix '(x, y) 22 | renderCharBox' _ (Stuff css) = css 23 | renderCharBox' (x, y) Clear = matrixChar ' ' (x, y) 24 | renderCharBox' (x, _) (Ver y1 t y2 b) = 25 | Mat (unMat (renderCharBox' (x, y1) t) `vappend` unMat (renderCharBox' (x, y2) b)) 26 | renderCharBox' (_, y) (Hor x1 l x2 r) = 27 | Mat (vcopies y vappend `vapp` unMat (renderCharBox' (x1, y) l) `vapp` unMat (renderCharBox' (x2, y) r)) 28 | 29 | renderCharBox :: (NATTY x, NATTY y) => CharBox '(x, y) -> CharMatrix '(x, y) 30 | renderCharBox = renderCharBox' (natty, natty) 31 | 32 | renderBox :: (NATTY x, NATTY y) => (forall xy.p xy -> CharMatrix xy) -> Box p '(x, y) -> CharMatrix '(x, y) 33 | renderBox f b = renderCharBox (ebox (Stuff . f) b) 34 | 35 | stringsOfCharMatrix :: CharMatrix '(x, y) -> [String] 36 | stringsOfCharMatrix (Mat vs) = foldMap ((:[]) . foldMap (:[])) vs 37 | 38 | boxChar :: Char -> (Natty x, Natty y) -> CharBox '(x, y) 39 | boxChar c (x, y) = Stuff (matrixChar c (x, y)) 40 | 41 | boxZ :: CharBox '(Z, Z) 42 | boxZ = emptyBox 43 | 44 | boxS :: Vec x Char -> CharBox '(x, S Z) 45 | boxS s = Stuff (Mat (pure s)) 46 | 47 | one = Sy Zy 48 | type One = S Z 49 | 50 | {- unused bounded stuff -} 51 | 52 | {- 53 | 54 | -- a bounded string (no more than n characters) 55 | data BString (n :: Nat) where 56 | BNil :: Natty n -> BString n 57 | BCons :: Char -> BString n -> BString (S n) 58 | 59 | bmax :: BString n -> Natty n 60 | bmax (BNil g) = g 61 | bmax (BCons _ cs) = Sy (bmax cs) 62 | 63 | 64 | data Split (s :: Nat -> *) (t :: Nat -> *) (n :: Nat) where 65 | Split :: s l -> t r -> Split s t (l :+ r) 66 | 67 | newtype FlipVec a n = FlipVec {unFlipVec :: Vec n a} 68 | 69 | boundCharVec :: Natty d -> Vec n Char -> BString (n :+ d) 70 | boundCharVec d V0 = BNil d 71 | boundCharVec d (c :> cs) = BCons c (boundCharVec d cs) 72 | 73 | splitBString :: BString w -> Split (FlipVec Char) Natty w 74 | splitBString (BNil g) = Split (FlipVec V0) g 75 | splitBString (BCons c cs) = case splitBString cs of 76 | Split (FlipVec cs') g -> Split (FlipVec (c :> cs')) g 77 | 78 | boxOfBString :: BString w -> CharBox '(w, One) 79 | boxOfBString s = case splitBString s of 80 | Split (FlipVec cs) g -> Hor (vlength cs) (boxS cs) g Clear 81 | -- boxOfBString (BNil g) = clear (g, one) 82 | -- boxOfBString (BCons c cs) = Hor one (boxChar c (one, one)) (bmax cs) (boxOfBString cs) 83 | 84 | boxOfBStrings :: Vec h (BString w) -> CharBox '(w, h) 85 | boxOfBStrings V0 = Clear 86 | boxOfBStrings (s :> ss) = Ver one (boxOfBString s) (vlength ss) (boxOfBStrings ss) 87 | 88 | weakenBString :: BString n -> BString (S n) 89 | weakenBString (BNil g) = BNil (Sy g) 90 | weakenBString (BCons c cs) = BCons c (weakenBString cs) 91 | 92 | -} -------------------------------------------------------------------------------- /OldBox/Cursor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators, 2 | RankNTypes, PolyKinds, ScopedTypeVariables, LiberalTypeSynonyms, ImpredicativeTypes #-} 3 | 4 | module Cursor where 5 | 6 | import Box 7 | import CharBox 8 | import GHC.TypeLits (Sing, sing, fromSing, Symbol) 9 | 10 | type Cursor a m l r = (Vec l a, m, Vec r a) 11 | type StringCursor l r = Cursor Char () l r 12 | 13 | -- a cursor in a text buffer with bounded width w, where d = w - (l + 14 | -- r + 1), i.e., d is the difference between the bound and the length 15 | -- of the current line 16 | type BTextCursor d l r t b = (Natty d, Cursor (BString ((l :+ r) :+ S d)) (StringCursor l r) t b) 17 | 18 | --- sum lemmas --- 19 | sumShift :: forall x y t.Natty x -> Natty y -> ((x :+ S y) ~ (S x :+ y) => t) -> t 20 | sumShift Zy _ t = t 21 | sumShift (Sy x) y t = sumShift x y t 22 | 23 | -- assocLR :: forall a b c t.Natty a -> Natty b -> Natty c -> (((a :+ b) :+ c) ~ (a :+ (b :+ c)) => t) -> t 24 | -- assocLR Zy b c t = t 25 | -- assocLR (Sy a) b c t = assocLR a b c t 26 | 27 | sumIdR :: forall x t.Natty x -> ((x ~ (x :+ Z)) => t) -> t 28 | sumIdR Zy t = t 29 | sumIdR (Sy x) t = sumIdR x t 30 | ------------------ 31 | 32 | cursorPos (xz, _, xs) = (vlength xz, vlength xs) 33 | 34 | deactivate :: Cursor a () l r -> Vec (l :+ r) a 35 | deactivate c = outward c where 36 | outward :: forall a l r.Cursor a () l r -> Vec (l :+ r) a 37 | outward (V0, (), xs) = xs 38 | outward (x :> xz, (), xs) = sumShift (vlength xz) (vlength xs) (outward (xz, (), x :> xs)) 39 | 40 | 41 | activate :: Natty l -> Vec (l :+ r) a -> Cursor a () l r 42 | activate n xs = inward Zy n (V0, (), xs) where 43 | inward :: forall l r n a.Natty l -> Natty n -> Cursor a () l (n :+ r) -> Cursor a () (l :+ n) r 44 | inward l Zy c = sumIdR l c 45 | inward l (Sy n) (xz, (), x :> xs) = sumShift l n (inward (Sy l) n (x :> xz, (), xs)) 46 | 47 | activate' :: Vec n a -> Cursor a () n Z 48 | activate' xs = sumIdR n (activate n xs) where n = vlength xs 49 | 50 | vreverse :: Vec n a -> Vec n a 51 | vreverse xs = xz where (xz, _, _) = activate' xs 52 | 53 | -- this version might be useful... 54 | -- 55 | -- activate'' :: Natty n -> Vec m a -> Cursor a () (Min m n) (m :- n) 56 | 57 | 58 | 59 | whatAndWhere :: BTextCursor d l r t b -> (CharBox '((l :+ r) :+ S d, t :+ S b), Point l (S t)) 60 | whatAndWhere (d, (czz, cur@(cz, (), cs), css)) = (boxOfBStrings strs, (l, Sy (vlength czz))) 61 | where 62 | l = vlength cz 63 | r = vlength cs 64 | cs' = boundCharVec (Sy d) (deactivate cur) 65 | strs = deactivate (czz, (), cs' :> css) 66 | 67 | 68 | {- key strokes -} 69 | data ArrowDir = UpArrow | DownArrow | LeftArrow | RightArrow 70 | data Modifier = Normal | Shift | Control 71 | 72 | data Key 73 | = CharKey -- an ordinary printable character 74 | | ArrowKey Modifier ArrowDir -- an arrow key 75 | | Return 76 | | Backspace 77 | | Delete 78 | | Quit 79 | 80 | data SArrowDir :: ArrowDir -> * where 81 | SUpArrow :: SArrowDir UpArrow 82 | SDownArrow :: SArrowDir DownArrow 83 | SLeftArrow :: SArrowDir LeftArrow 84 | SRightArrow :: SArrowDir RightArrow 85 | 86 | data SModifier :: Modifier -> * where 87 | SNormal :: SModifier Normal 88 | SShift :: SModifier Shift 89 | SControl :: SModifier Control 90 | 91 | data SKey :: Key -> * where 92 | SCharKey :: Char -> SKey CharKey 93 | SArrowKey :: SModifier m -> SArrowDir d -> SKey (ArrowKey m d) 94 | 95 | directions :: [(Char, ArrowDir)] 96 | directions = [('A', UpArrow), ('B', DownArrow), 97 | ('C', RightArrow), ('D', LeftArrow)] 98 | 99 | escapeKeys :: [(String, Key)] 100 | escapeKeys = 101 | [([c], ArrowKey Normal d) | (c, d) <- directions] ++ 102 | [("1;2" ++ [c], ArrowKey Shift d) | (c, d) <- directions] ++ 103 | [("1;5" ++ [c], ArrowKey Control d) | (c, d) <- directions] ++ 104 | [("3~", Delete)] 105 | 106 | 107 | data Damage 108 | = NoChange -- nothing at all happened 109 | | PointChanged -- moved the cursor but kept the text 110 | | LineChanged -- changed text only on the current line 111 | | LotsChanged -- changed text off the current line 112 | deriving (Show, Eq, Ord) 113 | 114 | data BTC :: (Nat, (Nat, Nat), (Nat, Nat)) -> * where 115 | BTC :: Natty d -> Cursor (BString ((l :+ r) :+ S d)) (StringCursor l r) t b -> BTC '(d, '(l, r), '(t, b)) 116 | 117 | type Spec = '(Nat, '(Nat, Nat), '(Nat, Nat)) 118 | 119 | type family Adjust (k :: Key) (spec :: (Nat, (Nat, Nat), (Nat, Nat))) :: (Nat, (Nat, Nat), (Nat, Nat)) 120 | type instance Adjust (CharKey) '(Z, '(l, r), v) = '(Z, '(S l, r), v) 121 | type instance Adjust (CharKey) '(S d, '(l, r), v) = '(d, '(S l, r), v) 122 | type instance Adjust (ArrowKey Normal LeftArrow) '(d, '(S l, r), v) = '(d, '(l, S r), v) 123 | type instance Adjust (ArrowKey Normal RightArrow) '(d, '(l, S r), v) = '(d, '(S l, r), v) 124 | 125 | handleKey :: SKey key -> BTC spec -> Maybe (Damage, BTC (Adjust key spec)) 126 | handleKey (SCharKey c) (BTC (Sy d) (sz, (cz, (), cs), ss)) = 127 | sumShift (vlength cz /+/ vlength cs) (Sy d) (Just (LineChanged, BTC d (sz, (c :> cz, (), cs), ss))) 128 | handleKey (SCharKey c) (BTC Zy (sz, (cz, (), cs), ss)) = 129 | Just (LineChanged, 130 | BTC Zy (fmap weakenBString sz, 131 | (c :> cz, (), cs), 132 | fmap weakenBString ss)) 133 | handleKey (SArrowKey SNormal SLeftArrow) (BTC d (sz, (c :> cz, (), cs), ss)) = 134 | sumShift (vlength cz) (vlength cs) (Just (PointChanged, BTC d (sz, (cz, (), c :> cs), ss))) 135 | handleKey (SArrowKey SNormal SRightArrow) (BTC d (sz, (cz, (), c :> cs), ss)) = 136 | sumShift (vlength cz) (vlength cs) (Just (PointChanged, BTC d (sz, (c :> cz, (), cs), ss))) 137 | 138 | -- ... 139 | -------------------------------------------------------------------------------- /OldBox/Edit.hs: -------------------------------------------------------------------------------- 1 | {- deprecated {-# INCLUDE #-} -} 2 | {-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators, 3 | RankNTypes, PolyKinds, ForeignFunctionInterface #-} 4 | 5 | -- use flag -lncurses to compile 6 | 7 | import Foreign 8 | import Foreign.C (CInt(..)) 9 | import ANSIEscapes 10 | import System.IO 11 | import System.Environment 12 | 13 | import Box 14 | import CharBox 15 | import PlainCursor 16 | 17 | data Window = Window 18 | type WindowPtr = Ptr Window 19 | 20 | foreign import ccall 21 | initscr :: IO () 22 | 23 | foreign import ccall "endwin" 24 | endwin :: IO CInt 25 | 26 | foreign import ccall "refresh" 27 | refresh :: IO CInt 28 | 29 | foreign import ccall "&LINES" 30 | linesPtr :: Ptr CInt 31 | 32 | foreign import ccall "&COLS" 33 | colsPtr :: Ptr CInt 34 | 35 | scrSize :: IO (Int, Int) 36 | scrSize = do 37 | lnes <- peek linesPtr 38 | cols <- peek colsPtr 39 | return (fromIntegral cols, fromIntegral lnes) 40 | 41 | copies :: Int -> a -> [a] 42 | copies n a = take n (repeat a) 43 | 44 | crlf :: IO () 45 | crlf = putStr "\r\n" 46 | 47 | putLn :: String -> IO () 48 | putLn x = putStr x >> crlf 49 | 50 | type UPoint = (Int, Int) 51 | type USize = (Int, Int) 52 | 53 | type ScreenState = (UPoint, USize) 54 | -- position in buffer of top left corner of screen, screen size 55 | 56 | -- onScreen c ps 57 | -- c is where the cursor currently is 58 | -- ps is where the viewport currently is 59 | -- the return value is an updated viewport 60 | -- containing c 61 | onScreen :: UPoint -> ScreenState -> ScreenState 62 | onScreen (cx, cy) ((px, py), s@(sw, sh)) 63 | = (( intoRange px cx sw, intoRange py cy sh), s) 64 | where 65 | intoRange i j x 66 | | i <= j && j <= i + x = i -- in range, no change 67 | | otherwise = max 0 (j - div x 2) 68 | 69 | -- if we did the following, and defined appropriate wrappers over the 70 | -- curses API then we could remove the calls to wrapPoint in the main 71 | -- loop and use type indexed nats everywhere 72 | {- 73 | type ScreenState' = (WrappedPoint, WrappedPoint) 74 | 75 | onScreen' :: WrappedPoint -> ScreenState' -> ScreenState' 76 | onScreen' (WPoint cx cy) (WPoint px py, WPoint sw sh) = 77 | case (intoRange px cx sw, intoRange py cy sh) of 78 | (WNat px', WNat py') -> (WPoint px' py', WPoint sw sh) 79 | where 80 | intoRange :: Natty i -> Natty j -> Natty x -> WrappedNat 81 | intoRange i j x = 82 | case (cmp i j, cmp j (i /+/ x)) of 83 | (GTNat _, _) -> case div2 x of WNat d -> WNat (j /-/ d) 84 | (_, GTNat _) -> case div2 x of WNat d -> WNat (j /-/ d) 85 | _ -> WNat i 86 | 87 | div2 :: Natty n -> WrappedNat 88 | div2 Zy = WNat Zy 89 | div2 (Sy Zy) = WNat Zy 90 | div2 (Sy (Sy n)) = case div2 n of WNat m -> WNat (Sy m) 91 | -} 92 | 93 | getEscapeKey :: [(String, Key)] -> IO (Maybe Key) 94 | getEscapeKey [] = return Nothing 95 | getEscapeKey sks = case lookup "" sks of 96 | Just k -> return (Just k) 97 | _ -> do 98 | c <- getChar 99 | getEscapeKey [(cs, k) | (d : cs, k) <- sks, d == c] 100 | 101 | keyReady :: IO (Maybe Key) 102 | keyReady = do 103 | b <- hReady stdin 104 | if not b then return Nothing else do 105 | c <- getChar 106 | case c of 107 | '\n' -> return $ Just Return 108 | '\r' -> return $ Just Return 109 | '\b' -> return $ Just Backspace 110 | '\DEL' -> return $ Just Backspace 111 | _ | c >= ' ' -> return $ Just (CharKey c) 112 | '\ESC' -> do 113 | b <- hReady stdin 114 | if not b then return $ Just Quit else do 115 | c <- getChar 116 | case c of 117 | '[' -> getEscapeKey escapeKeys 118 | _ -> return $ Just Quit 119 | _ -> return $ Nothing 120 | 121 | layout :: Size w h -> CharBox '(w, h) -> [String] 122 | layout s l = stringsOfCharMatrix (renderCharBox' s l) 123 | 124 | outer :: ScreenState -> TextCursor -> IO () 125 | outer ps tc = inner ps tc (whatAndWhere tc) LotsChanged 126 | where 127 | inner ps@(p, _) tc lc@(WBox (lw, lh) l, c@(cx, cy)) d = do 128 | refresh 129 | s' <- scrSize 130 | let ps'@((px, py), (sw, sh)) = onScreen c (p, s') 131 | if px < 0 || py < 0 || fst s' < 0 || snd s' < 0 then error "oops" else return () 132 | let d' = if ps /= ps' then LotsChanged else d 133 | case d' of 134 | LotsChanged -> do 135 | clearScreen 136 | resetCursor 137 | case (wrapPoint (px, py), wrapPoint (sw, sh)) of 138 | (WPoint x y, WPoint w h) -> do 139 | let cropped = cropper ((x, y), (w, h)) (lw, lh) l 140 | mapM_ putStr (layout (w, h) cropped) 141 | LineChanged -> do 142 | resetCursor 143 | down (cy - py) 144 | case (wrapPoint (px, cy), wrapPoint (sw, 1)) of 145 | (WPoint x y, WPoint w h) -> do 146 | let cropped = cropper ((x, y), (w, h)) (lw, lh) l 147 | mapM_ putStr (layout (w, h) cropped) 148 | _ -> return () 149 | if d' > NoChange then do 150 | resetCursor 151 | forward (cx - px) 152 | down (cy - py) 153 | else return () 154 | mc <- keyReady 155 | case mc of 156 | Nothing -> inner ps' tc lc NoChange 157 | Just Quit -> return () 158 | Just k -> case handleKey k tc of 159 | Nothing -> inner ps' tc lc NoChange 160 | Just (d, tc') -> inner ps' tc' (whatAndWhere tc') d 161 | 162 | main = do 163 | hSetBuffering stdout NoBuffering 164 | hSetBuffering stdin NoBuffering 165 | xs <- getArgs 166 | s <- case xs of 167 | [] -> return "" 168 | (x : _) -> readFile x 169 | let (l, ls) = case lines s of 170 | [] -> ("", []) 171 | (l : ls) -> (l, ls) 172 | initscr 173 | outer ((0, 0), (-1, -1)) ([], ([], (), l), ls) 174 | endwin 175 | 176 | --foreign import ccall unsafe "nomacro_getyx" 177 | -- nomacro_getyx :: Ptr Window -> Ptr CInt -> Ptr CInt -> IO () 178 | 179 | --standardScreen :: Window 180 | --standardScreen = unsafePerformIO (peek stdscr) 181 | 182 | --foreign import ccall "static &stdscr" 183 | -- stdscr :: Ptr Window 184 | 185 | 186 | --getYX :: Ptr Window -> IO (Int, Int) 187 | -- getYX w = 188 | -- alloca $ \py -> -- allocate two ints on the stack 189 | -- alloca $ \px -> do 190 | -- nomacro_getyx w py px -- writes current cursor coords 191 | -- y <- peek py 192 | -- x <- peek px 193 | -- return (fromIntegral y, fromIntegral x) 194 | 195 | 196 | -------------------------------------------------------------------------------- /OldBox/Makefile: -------------------------------------------------------------------------------- 1 | edit: Box.hs CharBox.hs PlainCursor.hs Edit.hs ANSIEscapes.hs 2 | ghc -lncurses --make Edit -o edit 3 | -------------------------------------------------------------------------------- /OldBox/PlainCursor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators, 2 | RankNTypes, PolyKinds #-} 3 | 4 | module PlainCursor where 5 | 6 | import Box 7 | import CharBox 8 | 9 | type Cursor a m = ([a], m, [a]) 10 | type StringCursor = Cursor Char () 11 | 12 | type TextCursor = Cursor String StringCursor 13 | 14 | deactivate :: Cursor a () -> (Int, [a]) 15 | deactivate c = outward 0 c where 16 | outward i ([], (), xs) = (i, xs) 17 | outward i (x : xz, (), xs) = outward (i + 1) (xz, (), x : xs) 18 | 19 | 20 | activate :: (Int, [a]) -> Cursor a () 21 | activate (i, xs) = inward i ([], (), xs) where 22 | inward _ c@(_, (), []) = c 23 | inward 0 c = c 24 | inward i (xz, (), x : xs) = inward (i - 1) (x : xz, (), xs) 25 | 26 | 27 | data WrappedNat :: * where 28 | WNat :: Natty n -> WrappedNat 29 | 30 | wrapNat :: Int -> WrappedNat 31 | wrapNat 0 = WNat Zy 32 | wrapNat n = case wrapNat (n-1) of 33 | WNat wn -> WNat (Sy wn) 34 | 35 | intOfNat :: Natty n -> Int 36 | intOfNat Zy = 0 37 | intOfNat (Sy n) = 1 + intOfNat n 38 | 39 | data WrappedPoint :: * where 40 | WPoint :: Natty x -> Natty y -> WrappedPoint 41 | 42 | wrapPoint :: (Int, Int) -> WrappedPoint 43 | wrapPoint (x, y) = 44 | case (wrapNat x, wrapNat y) of 45 | (WNat x, WNat y) -> WPoint x y 46 | 47 | data WrappedBox :: * where 48 | WBox :: Size w h -> CharBox '(w, h) -> WrappedBox 49 | 50 | data WrappedVec a :: * where 51 | WVec :: Vec n a -> WrappedVec a 52 | 53 | vecOfList :: [a] -> WrappedVec a 54 | vecOfList [] = WVec V0 55 | vecOfList (x:xs) = case vecOfList xs of 56 | WVec v -> WVec (x :> v) 57 | 58 | boxOfString :: String -> WrappedBox 59 | boxOfString s = case vecOfList s of 60 | WVec v -> WBox (vlength v, one) (boxS v) 61 | 62 | boxOfStrings :: [String] -> WrappedBox 63 | boxOfStrings [] = WBox (Zy, Zy) boxZ 64 | boxOfStrings (s:ss) = case (boxOfString s, boxOfStrings ss) of 65 | (WBox (x1, y1) b1, WBox (x2, y2) b2) -> 66 | WBox 67 | (x1 `maxn` x2, y1 /+/ y2) 68 | (joinV (x1, y1) (x2, y2) b1 b2) 69 | 70 | whatAndWhere :: TextCursor -> (WrappedBox, (Int, Int)) 71 | whatAndWhere (czz, cur, css) = (boxOfStrings strs, (x, y)) 72 | where 73 | (x, cs) = deactivate cur 74 | (y, strs) = deactivate (czz, (), cs : css) 75 | 76 | data ArrowDir = UpArrow | DownArrow | LeftArrow | RightArrow 77 | data Modifier = Normal | Shift | Control 78 | 79 | data Key 80 | = CharKey Char -- an ordinary printable character 81 | | ArrowKey Modifier ArrowDir -- an arrow key 82 | | Return 83 | | Backspace 84 | | Delete 85 | | Quit 86 | 87 | directions :: [(Char, ArrowDir)] 88 | directions = [('A', UpArrow), ('B', DownArrow), 89 | ('C', RightArrow), ('D', LeftArrow)] 90 | 91 | escapeKeys :: [(String, Key)] 92 | escapeKeys = 93 | [([c], ArrowKey Normal d) | (c, d) <- directions] ++ 94 | [("1;2" ++ [c], ArrowKey Shift d) | (c, d) <- directions] ++ 95 | [("1;5" ++ [c], ArrowKey Control d) | (c, d) <- directions] ++ 96 | [("3~", Delete)] 97 | 98 | data Damage 99 | = NoChange -- use this if nothing at all happened 100 | | PointChanged -- use this if we moved the cursor but kept the text 101 | | LineChanged -- use this if we changed text only on the current line 102 | | LotsChanged -- use this if we changed text off the current line 103 | deriving (Show, Eq, Ord) 104 | 105 | {--------------------------------------------------------------------------} 106 | {- Given a Key and an initial TextCursor, either reject the keystroke or -} 107 | {- return a modified cursor, with an overestimate of the damage we've -} 108 | {- done. -} 109 | {--------------------------------------------------------------------------} 110 | 111 | handleKey :: Key -> TextCursor -> Maybe (Damage, TextCursor) 112 | handleKey (CharKey c) (sz, (cz, (), cs), ss) = 113 | Just (LineChanged, (sz, (c : cz, (), cs), ss)) 114 | handleKey (ArrowKey Normal LeftArrow) (sz, (c : cz, (), cs), ss) = 115 | Just (PointChanged, (sz, (cz, (), c : cs), ss)) 116 | handleKey (ArrowKey Normal RightArrow) (sz, (cz, (), c : cs), ss) = 117 | Just (PointChanged, (sz, (c : cz, (), cs), ss)) 118 | handleKey (ArrowKey Normal UpArrow) (sUp : sz, pos, ss) = 119 | Just (PointChanged, (sz, activate (i, sUp), s : ss)) 120 | where 121 | (i, s) = deactivate pos 122 | handleKey (ArrowKey Normal DownArrow) (sz, pos, sDown : ss) = 123 | Just (PointChanged, (s : sz, activate (i, sDown), ss)) 124 | where 125 | (i, s) = deactivate pos 126 | handleKey Return (sz, (cz, (), cs), ss) = 127 | Just (LotsChanged, (prefix : sz, ([], (), cs), ss)) 128 | where 129 | (_, prefix) = deactivate (cz, (), []) 130 | handleKey Delete (sz, (cz, (), c : cs), ss) = 131 | Just (LineChanged, (sz, (cz, (), cs), ss)) 132 | handleKey Backspace (sz, (c : cz, (), cs), ss) = 133 | Just (LineChanged, (sz, (cz, (), cs), ss)) 134 | handleKey Delete (sz, (cz, (), []), s : ss) = 135 | Just (LotsChanged, (sz, (cz, (), s), ss)) 136 | handleKey Backspace (s : sz, ([], (), cs), ss) = 137 | Just (LotsChanged, (sz, (cz, (), cs), ss)) 138 | where 139 | (cz, _, _) = activate (length s, s) 140 | handleKey _ _ = Nothing 141 | -------------------------------------------------------------------------------- /PlainBox/ANSIEscapes.hs: -------------------------------------------------------------------------------- 1 | module ANSIEscapes 2 | (upLine, 3 | downLine, 4 | up, 5 | down, 6 | forward, 7 | backward, 8 | killLine, 9 | restoreCursor, 10 | saveCursor, 11 | clearScreen, 12 | yellow, 13 | brown, 14 | red, 15 | blue, 16 | purple, 17 | green, 18 | orange, 19 | white, 20 | yellowOnGrey, 21 | brownOnGrey, 22 | redOnGrey, 23 | blueOnGrey, 24 | purpleOnGrey, 25 | greenOnGrey, 26 | whiteOnGrey, 27 | onBlack, 28 | onGrey, 29 | onGreyEsc, 30 | onWhiteEsc, 31 | resetCursor, 32 | initTermSize) where 33 | 34 | data Dir = UpDir | DownDir | RightDir | LeftDir 35 | 36 | instance Show Dir where 37 | show UpDir = "A" 38 | show DownDir = "B" 39 | show RightDir = "C" 40 | show LeftDir = "D" 41 | 42 | upLine = putStr "\ESC[1A" 43 | downLine = putStr "\ESC[1B" 44 | 45 | up = moveCursor UpDir 46 | down = moveCursor DownDir 47 | backward = moveCursor LeftDir 48 | forward = moveCursor RightDir 49 | 50 | moveCursor :: Dir -> Int -> IO () 51 | moveCursor dir 0 = return () 52 | moveCursor dir n = putStr $ "\ESC[" ++ show n ++ show dir 53 | 54 | killLine = escape "K" 55 | restoreCursor = escape "u" 56 | saveCursor = escape "s" 57 | clearScreen = escape "2J" 58 | initTermSize = (escape "[=3h") 59 | 60 | resetCursor = escape "0;0H" 61 | 62 | escape e = putStr $ "\ESC[" ++ e 63 | 64 | yellow str = "\ESC[1;33m" ++ str ++ "\ESC[0m" 65 | brown str = "\ESC[0;33m" ++ str ++ "\ESC[0m" 66 | blue str = "\ESC[1;34m" ++ str ++ "\ESC[0m" 67 | red str = "\ESC[1;31m" ++ str ++ "\ESC[0m" 68 | green str = "\ESC[1;32m" ++ str ++ "\ESC[0m" 69 | purple str = "\ESC[1;35m" ++ str ++ "\ESC[0m" 70 | white str = "\ESC[37m" ++ str ++ "\ESC[0m" 71 | 72 | 73 | 74 | --Be careful, these assume someone else will reset the background colour 75 | yellowOnGrey str = "\ESC[1;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 76 | brownOnGrey str = "\ESC[0;33m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 77 | blueOnGrey str = "\ESC[1;34m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 78 | redOnGrey str = "\ESC[1;31m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 79 | greenOnGrey str = "\ESC[1;32m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 80 | purpleOnGrey str = "\ESC[1;35m\ESC[47m" ++ str ++ "\ESC[0m\ESC[47m" 81 | whiteOnGrey str = "\ESC[37m" ++ str ++ "\ESC[0m" 82 | 83 | onBlack str = "\ESC[40m" ++ str ++ "\ESC[0m" 84 | onGrey str = onGreyEsc ++ str ++ onWhiteEsc 85 | onGreyEsc = "\ESC[47m" 86 | onWhiteEsc = "\ESC[0m" 87 | orange str = str -------------------------------------------------------------------------------- /PlainBox/Box.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | 3 | module Box where 4 | 5 | import Data.Monoid 6 | 7 | type Size = (Int, Int) 8 | type Point = (Int, Int) 9 | type Region = (Point, Size) 10 | 11 | type Box a = (Size, Block a) 12 | data Block a 13 | = Stuff a 14 | | Clear 15 | | Ver (Box a) (Box a) 16 | | Hor (Box a) (Box a) 17 | 18 | class Cut a where 19 | horCut :: Int -> a -> (a, a) 20 | verCut :: Int -> a -> (a, a) 21 | 22 | instance Cut a => Cut (Block a) where 23 | horCut m (Stuff p) = (Stuff p1, Stuff p2) 24 | where (p1, p2) = horCut m p 25 | horCut m Clear = (Clear, Clear) 26 | horCut m (Hor ((w1, h1), b1) ((w2, h2), b2)) 27 | | m < w1 = let (b11, b12) = horCut m b1 28 | in (b11, Hor ((w1-m, h1), b12) ((w2, h2), b2)) 29 | | m == w1 = (b1, b2) 30 | | m > w1 = let (b21, b22) = horCut (m-w1) b2 31 | in (Hor ((w1, h1), b1) ((m-w1, h2), b21), b22) 32 | horCut m (Ver (wh1, b1) (wh2, b2)) = 33 | (Ver (wh1, b11) (wh2, b21), Ver (wh1, b12) (wh2, b22)) 34 | where (b11, b12) = horCut m b1 35 | (b21, b22) = horCut m b2 36 | 37 | verCut m (Stuff p) = (Stuff p1, Stuff p2) 38 | where (p1, p2) = verCut m p 39 | verCut m Clear = (Clear, Clear) 40 | verCut m (Ver ((w1, h1), b1) ((w2, h2), b2)) 41 | | m < h1 = let (b11, b12) = verCut m b1 42 | in (b11, Ver ((w1, h1-m), b12) ((w2, h2), b2)) 43 | | m == h1 = (b1, b2) 44 | | m > h1 = let (b21, b22) = verCut (m-h1) b2 45 | in (Ver ((w1, h1), b1) ((w2, m-h1), b21), b22) 46 | verCut m (Hor (wh1, b1) (wh2, b2)) = 47 | (Hor (wh1, b11) (wh2, b21), Hor (wh1, b12) (wh2, b22)) 48 | where (b11, b12) = verCut m b1 49 | (b21, b22) = verCut m b2 50 | 51 | instance Cut a => Cut (Box a) where 52 | horCut m ((w, h), b) = (((m, h), b1), ((w-m, h), b2)) 53 | where (b1, b2) = horCut m b 54 | verCut m ((w, h), b) = (((w, m), b1), ((w, h-m), b2)) 55 | where (b1, b2) = verCut m b 56 | 57 | -- this doesn't really make sense 58 | -- it is only correct if the sizes of the boxes match up 59 | instance Cut a => Monoid (Block a) where 60 | mempty = Clear 61 | mappend b Clear = b 62 | mappend Clear b' = b' 63 | mappend b@(Stuff _) _ = b 64 | mappend (Hor (wh1@(w1, _), b1) (wh2@(w2, _), b2)) b' = Hor (wh1, mappend b1 b1') (wh2, mappend b2 b2') 65 | where (b1', b2') = horCut w1 b' 66 | mappend (Ver (wh1@(_, h1), b1) (wh2@(_, h2), b2)) b' = Ver (wh1, mappend b1 b1') (wh2, mappend b2 b2') 67 | where (b1', b2') = verCut h1 b' 68 | 69 | -- this makes even less sense 70 | instance Cut a => Monoid (Box a) where 71 | mempty = ((0, 0), Clear) 72 | mappend ((0, 0), b1) (wh2, b2) = (wh2, mappend b1 b2) 73 | mappend (wh1, b1) (wh2, b2) = (wh1, mappend b1 b2) 74 | 75 | clear :: Size -> Box a 76 | clear wh = (wh, Clear) 77 | 78 | hGap :: Int -> Box a 79 | hGap w = clear (w, 0) 80 | 81 | vGap :: Int -> Box a 82 | vGap h = clear (0, h) 83 | 84 | joinH :: Box a -> Box a -> Box a 85 | joinH b1@((w1, h1), _) b2@((w2, h2), _) 86 | | h1 < h2 87 | = ((w1 + w2, h2), Hor ((w1, h2), Ver b1 ((w1, h2 - h1), Clear)) b2) 88 | | h1 == h2 = ((w1 + w2, h1), Hor b1 b2) 89 | | h1 > h2 90 | = ((w1 + w2, h1), Hor b1 ((w2, h1), Ver b2 ((w2, h1 - h2), Clear))) 91 | 92 | joinV :: Box a -> Box a -> Box a 93 | joinV b1@((w1, h1), _) b2@((w2, h2), _) 94 | | w1 < w2 95 | = ((w2, h1 + h2), Ver ((w2, h1), Hor b1 ((w2 - w1, h1), Clear)) b2) 96 | | w1 == w2 = ((w1, h1 + h2), Ver b1 b2) 97 | | w1 > w2 98 | = ((w1, h1 + h2), Ver b1 ((w1, h2), Hor b2 ((w1 - w2, h2), Clear))) 99 | 100 | {- cropping -} 101 | cropper :: Cut p => Region -> Box p -> Box p 102 | cropper ((x, y), (w, h)) b = 103 | fit (w, h) (clip (x, y) b) 104 | 105 | clip :: Cut p => Point -> Box p -> Box p 106 | clip (x, y) b@((w, h), _) = clipV y (clipH x b) 107 | 108 | clipH :: Cut p => Int -> Box p -> Box p 109 | clipH x b@((w, h), _) 110 | | w > x = snd (horCut x b) 111 | | w <= x = ((x-w, h), Clear) 112 | 113 | clipV :: Cut p => Int -> Box p -> Box p 114 | clipV y b@((w, h), _) 115 | | h > y = snd (verCut y b) 116 | | h <= y = ((w, y-h), Clear) 117 | 118 | fit :: Cut p => Size -> Box p -> Box p 119 | fit (w, h) b = fitV h (fitH w b) 120 | 121 | fitH :: Cut p => Int -> Box p -> Box p 122 | fitH w2 box@((w1, h), _) 123 | | w1 < w2 = ((w2, h), Hor box ((w2-w1, h), Clear)) 124 | | w1 == w2 = box 125 | | w1 > w2 = fst (horCut w2 box) 126 | 127 | fitV :: Cut p => Int -> Box p -> Box p 128 | fitV h2 box@((w, h1), _) 129 | | h1 < h2 = ((w, h2), Ver box ((w, h2-h1), Clear)) 130 | | h1 == h2 = box 131 | | h1 > h2 = fst (verCut h2 box) 132 | -------------------------------------------------------------------------------- /PlainBox/CharBox.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | 3 | module CharBox where 4 | 5 | import Box 6 | 7 | type CharMatrix = [[Char]] 8 | type CharBox = Box CharMatrix 9 | 10 | matrixChar :: Char -> Size -> CharMatrix 11 | matrixChar c (x, y) = replicate y (replicate x c) 12 | 13 | renderCharBox :: CharBox -> CharMatrix 14 | renderCharBox (_, Stuff css) = css 15 | renderCharBox ((x, y), Clear) = matrixChar ' ' (x, y) 16 | renderCharBox (_, Ver b1 b2) = 17 | renderCharBox b1 ++ renderCharBox b2 18 | renderCharBox (_, Hor b1 b2) = 19 | zipWith (++) (renderCharBox b1) (renderCharBox b2) 20 | 21 | instance Cut CharMatrix where 22 | horCut m css = (map (take m) css, map (drop m) css) 23 | verCut m css = (take m css, drop m css) 24 | -------------------------------------------------------------------------------- /PlainBox/Cursor.hs: -------------------------------------------------------------------------------- 1 | module Cursor where 2 | 3 | import Box 4 | import CharBox 5 | 6 | type Cursor a m = ([a], m, [a]) 7 | type StringCursor = Cursor Char () 8 | 9 | type TextCursor = Cursor String StringCursor 10 | 11 | deactivate :: Cursor a () -> (Int, [a]) 12 | deactivate c = outward 0 c where 13 | outward i ([], (), xs) = (i, xs) 14 | outward i (x : xz, (), xs) = outward (i + 1) (xz, (), x : xs) 15 | 16 | activate :: (Int, [a]) -> Cursor a () 17 | activate (i, xs) = inward i ([], (), xs) where 18 | inward _ c@(_, (), []) = c 19 | inward 0 c = c 20 | inward i (xz, (), x : xs) = inward (i - 1) (x : xz, (), xs) 21 | 22 | layZ :: Box p 23 | layZ = clear (0, 0) 24 | 25 | layS :: String -> CharBox 26 | layS s = ((length s, 1), Stuff [s]) 27 | 28 | whatAndWhere :: TextCursor -> (CharBox, Point) 29 | whatAndWhere (czz, cur, css) = (foldr (joinV . layS) layZ strs, (x, y)) where 30 | (x, cs) = deactivate cur 31 | (y, strs) = deactivate (czz, (), cs : css) 32 | 33 | data ArrowDir = UpArrow | DownArrow | LeftArrow | RightArrow 34 | data Modifier = Normal | Shift | Control 35 | 36 | data Key 37 | = CharKey Char -- an ordinary printable character 38 | | ArrowKey Modifier ArrowDir -- an arrow key 39 | | Return 40 | | Backspace 41 | | Delete 42 | | Quit 43 | 44 | directions :: [(Char, ArrowDir)] 45 | directions = [('A', UpArrow), ('B', DownArrow), 46 | ('C', RightArrow), ('D', LeftArrow)] 47 | 48 | escapeKeys :: [(String, Key)] 49 | escapeKeys = 50 | [([c], ArrowKey Normal d) | (c, d) <- directions] ++ 51 | [("1;2" ++ [c], ArrowKey Shift d) | (c, d) <- directions] ++ 52 | [("1;5" ++ [c], ArrowKey Control d) | (c, d) <- directions] ++ 53 | [("3~", Delete)] 54 | 55 | data Damage 56 | = NoChange -- use this if nothing at all happened 57 | | PointChanged -- use this if we moved the cursor but kept the text 58 | | LineChanged -- use this if we changed text only on the current line 59 | | LotsChanged -- use this if we changed text off the current line 60 | deriving (Show, Eq, Ord) 61 | 62 | {--------------------------------------------------------------------------} 63 | {- Given a Key and an initial TextCursor, either reject the keystroke or -} 64 | {- return a modified cursor, with an overestimate of the damage we've -} 65 | {- done. -} 66 | {--------------------------------------------------------------------------} 67 | 68 | handleKey :: Key -> TextCursor -> Maybe (Damage, TextCursor) 69 | handleKey (CharKey c) (sz, (cz, (), cs), ss) = 70 | Just (LineChanged, (sz, (c : cz, (), cs), ss)) 71 | handleKey (ArrowKey Normal LeftArrow) (sz, (c : cz, (), cs), ss) = 72 | Just (PointChanged, (sz, (cz, (), c : cs), ss)) 73 | handleKey (ArrowKey Normal RightArrow) (sz, (cz, (), c : cs), ss) = 74 | Just (PointChanged, (sz, (c : cz, (), cs), ss)) 75 | handleKey (ArrowKey Normal UpArrow) (sUp : sz, pos, ss) = 76 | Just (PointChanged, (sz, activate (i, sUp), s : ss)) 77 | where 78 | (i, s) = deactivate pos 79 | handleKey (ArrowKey Normal DownArrow) (sz, pos, sDown : ss) = 80 | Just (PointChanged, (s : sz, activate (i, sDown), ss)) 81 | where 82 | (i, s) = deactivate pos 83 | handleKey Return (sz, (cz, (), cs), ss) = 84 | Just (LotsChanged, (prefix : sz, ([], (), cs), ss)) 85 | where 86 | (_, prefix) = deactivate (cz, (), []) 87 | handleKey Delete (sz, (cz, (), c : cs), ss) = 88 | Just (LineChanged, (sz, (cz, (), cs), ss)) 89 | handleKey Backspace (sz, (c : cz, (), cs), ss) = 90 | Just (LineChanged, (sz, (cz, (), cs), ss)) 91 | handleKey Delete (sz, (cz, (), []), s : ss) = 92 | Just (LotsChanged, (sz, (cz, (), s), ss)) 93 | handleKey Backspace (s : sz, ([], (), cs), ss) = 94 | Just (LotsChanged, (sz, (cz, (), cs), ss)) 95 | where 96 | (cz, _, _) = activate (length s, s) 97 | handleKey _ _ = Nothing 98 | 99 | -------------------------------------------------------------------------------- /PlainBox/Edit.hs: -------------------------------------------------------------------------------- 1 | {- deprecated {-# INCLUDE #-} -} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | 4 | -- use flag -lncurses to compile 5 | 6 | import Foreign 7 | import Foreign.C (CInt(..)) 8 | import ANSIEscapes 9 | import System.IO 10 | import System.Environment 11 | 12 | import Box 13 | import CharBox 14 | import Cursor 15 | 16 | data Window = Window 17 | type WindowPtr = Ptr Window 18 | 19 | foreign import ccall 20 | initscr :: IO () 21 | 22 | foreign import ccall "endwin" 23 | endwin :: IO CInt 24 | 25 | foreign import ccall "refresh" 26 | refresh :: IO CInt 27 | 28 | foreign import ccall "&LINES" 29 | linesPtr :: Ptr CInt 30 | 31 | foreign import ccall "&COLS" 32 | colsPtr :: Ptr CInt 33 | 34 | scrSize :: IO (Int, Int) 35 | scrSize = do 36 | lnes <- peek linesPtr 37 | cols <- peek colsPtr 38 | return (fromIntegral cols, fromIntegral lnes) 39 | 40 | copies :: Int -> a -> [a] 41 | copies n a = take n (repeat a) 42 | 43 | crlf :: IO () 44 | crlf = putStr "\r\n" 45 | 46 | putLn :: String -> IO () 47 | putLn x = putStr x >> crlf 48 | 49 | type ScreenState = (Point, Size) 50 | -- position in buffer of top left corner of screen, screen size 51 | 52 | onScreen :: Point -> ScreenState -> ScreenState 53 | onScreen (cx, cy) ((px, py), s@(sw, sh)) 54 | = (( intoRange px cx sw, intoRange py cy sh), s) 55 | where 56 | intoRange i j x 57 | | i <= j && j <= i + x = i -- in range, no change 58 | | otherwise = max 0 (j - div x 2) 59 | 60 | getEscapeKey :: [(String, Key)] -> IO (Maybe Key) 61 | getEscapeKey [] = return Nothing 62 | getEscapeKey sks = case lookup "" sks of 63 | Just k -> return (Just k) 64 | _ -> do 65 | c <- getChar 66 | getEscapeKey [(cs, k) | (d : cs, k) <- sks, d == c] 67 | 68 | keyReady :: IO (Maybe Key) 69 | keyReady = do 70 | b <- hReady stdin 71 | if not b then return Nothing else do 72 | c <- getChar 73 | case c of 74 | '\n' -> return $ Just Return 75 | '\r' -> return $ Just Return 76 | '\b' -> return $ Just Backspace 77 | '\DEL' -> return $ Just Backspace 78 | _ | c >= ' ' -> return $ Just (CharKey c) 79 | '\ESC' -> do 80 | b <- hReady stdin 81 | if not b then return $ Just Quit else do 82 | c <- getChar 83 | case c of 84 | '[' -> getEscapeKey escapeKeys 85 | _ -> return $ Just Quit 86 | _ -> return $ Nothing 87 | 88 | layout :: CharBox -> [String] 89 | layout = renderCharBox 90 | 91 | outer :: ScreenState -> TextCursor -> IO () 92 | outer ps tc = inner ps tc (whatAndWhere tc) LotsChanged 93 | where 94 | inner ps@(p, s) tc lc@(l, c@(cx, cy)) d = do 95 | refresh 96 | s' <- scrSize 97 | let ps'@((px, py), (sw, _)) = onScreen c (p, s') 98 | let d' = if ps /= ps' then LotsChanged else d 99 | case d' of 100 | LotsChanged -> do 101 | clearScreen 102 | resetCursor 103 | mapM_ putStr (layout (cropper ps' l)) 104 | LineChanged -> do 105 | resetCursor 106 | down (cy - py) 107 | mapM_ putStr (layout (cropper ((px, cy), (sw, 1)) l)) 108 | _ -> return () 109 | if d' > NoChange then do 110 | resetCursor 111 | forward (cx - px) 112 | down (cy - py) 113 | else return () 114 | mc <- keyReady 115 | case mc of 116 | Nothing -> inner ps' tc lc NoChange 117 | Just Quit -> return () 118 | Just k -> case handleKey k tc of 119 | Nothing -> inner ps' tc lc NoChange 120 | Just (d, tc') -> inner ps' tc' (whatAndWhere tc') d 121 | 122 | main :: IO () 123 | main = do 124 | hSetBuffering stdout NoBuffering 125 | hSetBuffering stdin NoBuffering 126 | xs <- getArgs 127 | s <- case xs of 128 | [] -> return "" 129 | (x : _) -> readFile x 130 | let (l, ls) = case lines s of 131 | [] -> ("", []) 132 | (l : ls) -> (l, ls) 133 | initscr 134 | outer ((0, 0), (-1, -1)) ([], ([], (), l), ls) 135 | endwin 136 | return () 137 | -------------------------------------------------------------------------------- /PlainBox/Makefile: -------------------------------------------------------------------------------- 1 | edit: Box.hs CharBox.hs Cursor.hs Edit.hs ANSIEscapes.hs 2 | ghc -lncurses --make Edit -o edit 3 | 4 | clean: 5 | rm -f *.o *.hi edit 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | dependent-haskell 2 | ================= --------------------------------------------------------------------------------