├── Context.lhs ├── LICENSE ├── README ├── Setup.hs ├── arrays.lhs ├── codo-notation.cabal ├── edit-distance-array.lhs ├── edit-distance-trans.lhs ├── edit-distance.lhs ├── lucid-streams.lhs ├── num-functions.lhs ├── sample.lhs ├── sample2.lhs └── src └── Language └── Haskell └── Codo.lhs /Context.lhs: -------------------------------------------------------------------------------- 1 | > module Context where 2 | 3 | > import Data.Monoid 4 | > import Control.Comonad 5 | 6 | InContext or CoState comonad - models context-aware computations 7 | 8 | > data InContext c a = InContext (c -> a) c 9 | 10 | > instance Comonad (InContext c) where 11 | > extract (InContext s c) = s c 12 | > extend k (InContext s c) = InContext (\c' -> k (InContext s c')) c 13 | 14 | > instance Functor (InContext c) where 15 | > fmap f = extend (f . extract) 16 | 17 | 18 | > at :: InContext c a -> c -> a 19 | > at (InContext s _) c' = s c' 20 | 21 | > context :: InContext c a -> c 22 | > context (InContext s c) = c 23 | 24 | 25 | Param or exponent comonad - models context-oblivious computations 26 | 27 | instance Monoid x => Comonad ((->) x) where 28 | extract f = f mempty 29 | extend k f = (\x' -> k (\x -> f (mappend x x'))) 30 | 31 | instance Monoid x => Functor ((->) x) where 32 | fmap f = extend (f . extract) 33 | 34 | Product comonad 35 | 36 | instance Comonad ((,) x) where 37 | extract (x, a) = a 38 | extend f (x, a) = (x, f (x, a)) 39 | 40 | instance Functor ((,) x) where 41 | fmap f = extend (f . extract) 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Dominic Orchard 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | The codo-notation provides a lightweight, do-like, syntactic sugar for 2 | programming with comonads in Haskell. 3 | 4 | A number of examples can be found here: 5 | https://github.com/dorchard/codo-notation 6 | 7 | and in the following paper: 8 | http://www.cl.cam.ac.uk/~dao29/drafts/codo-notation-orchard-ifl12.pdf 9 | 10 | --------------- 11 | Dominic Orchard -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /arrays.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE QuasiQuotes #-} 3 | 4 | > {-# LANGUAGE NoMonomorphismRestriction #-} 5 | 6 | > import Control.Comonad 7 | > import Language.Haskell.Codo 8 | 9 | > import qualified Control.Category as Math 10 | 11 | 12 | > import Data.Array 13 | 14 | > class Comonad c => ComonadZip c where 15 | > czip :: (c a, c b) -> c (a, b) 16 | 17 | 18 | > data PArray i a = PA (Array i a) i deriving Show 19 | 20 | > instance Ix i => Comonad (PArray i) where 21 | > extract (PA arr c) = arr!c 22 | > extend f (PA x c) = 23 | > let es' = map (\i -> (i, f (PA x i))) (indices x) 24 | > in PA (array (bounds x) es') c 25 | 26 | > instance Ix i => Functor (PArray i) where 27 | > fmap f = extend (f . extract) 28 | 29 | > laplace1D :: Fractional a => PArray Int a -> a 30 | > laplace1D (PA a i) = 31 | > let (b1, b2) = bounds a 32 | > in if (i>b1 && i then a!(i-1) - 2*(a!i) + a!(i+1) 34 | > else 0.0 35 | 36 | 37 | > data PBArray i a = PBA (Array i a) i (i, i) deriving Show 38 | 39 | > instance Ix i => Comonad (PBArray i) where 40 | > extract (PBA arr c _) = arr!c 41 | > extend f (PBA x c b) = 42 | > let es' = map (\i -> (i, f (PBA x i b))) (indices x) 43 | > in PBA (array (bounds x) es') c b 44 | 45 | > instance Ix i => Functor (PBArray i) where 46 | > fmap f = extend (f . extract) 47 | 48 | 49 | > withInterior :: Ord i => (PBArray i a -> b) -> (PBArray i a -> b) -> (PBArray i a -> b) 50 | > withInterior f g x@(PBA a c (b1, b2)) = if (c>=b1 && c then g x 52 | > else f x 53 | 54 | > withExterior :: Ord i => (PBArray i a -> b) -> (PBArray i a -> b) -> (PBArray i a -> b) 55 | > withExterior f g x@(PBA a c (b1, b2)) = if (c>=b1 && c then f x 57 | > else g x 58 | 59 | > laplace1Db :: Fractional a => PBArray Int a -> a 60 | > laplace1Db = (\(PBA a i _) -> a!(i-1) - 2*(a!i) + a!(i+1)) 61 | > `withExterior` extract 62 | 63 | > localMean1Db :: Fractional a => PBArray Int a -> a 64 | > localMean1Db = (\(PBA a i _) -> (a!(i-1) + a!i + a!(i+1)) / 3.0) 65 | > `withExterior` extract 66 | 67 | > filterC :: Comonad c => (a -> Bool) -> a -> c a -> a 68 | > filterC p x a = if p (extract a) then x else extract a 69 | 70 | 71 | Example array values 72 | 73 | > x = PBA (array (0,4) [(0, 0.0), (1, 0.5), (2, 0.7), (3, 0.5), (4, 0.0)]) (0::Int) (1,4) 74 | > y = PBA (array (0,4) [(0, 0.0), (1, 0.5), (2, 0.7), (3, 0.0), (4, 1.0)]) (0::Int) (1,4) 75 | 76 | 77 | > -- Examples in the paper 78 | 79 | > prog1 = [codo| x => y <- laplace1Db x 80 | > z <- localMean1Db y 81 | > extract z |] 82 | 83 | > plus :: (Comonad c, Num a) => c a -> c a -> a 84 | > plus x y = extract x + extract y 85 | 86 | > prog2 = [codo| a => b <- localMean1Db a 87 | > c <- laplace1Db b 88 | > d <- plus b c 89 | > localMean1Db d |] 90 | 91 | > -- equivalent translation 92 | > prog2e a = let b = localMean1Db <<= a 93 | > d = (\b' -> let c = laplace1Db <<= b' 94 | > in plus b' c) <<= b 95 | > in localMean1Db d 96 | 97 | > -- non-pointwise (bad) version (by hand) 98 | > prog2bad a = let b = localMean1Db <<= a 99 | > c = laplace1Db <<= b 100 | > d = (plus b) <<= c 101 | > in localMean1Db d 102 | 103 | > -- non-pointwise with context 104 | > prog2' = [codo| a => b <- localMean1Db a 105 | > (codo b' => c <- laplace1Db b' 106 | > d <- plus b c 107 | > localMean1Db d) b |] 108 | 109 | > prog3 = [context| (x, y) => a <- laplace1Db x 110 | > b <- laplace1Db y 111 | > (extract a) + (extract b) |] 112 | 113 | prog3 <<= (czip (x, y)) 114 | 115 | > instance (Eq i, Ix i) => ComonadZip (PBArray i) where 116 | > czip (PBA a c (b1, b2), PBA a' c' (b1', b2')) = 117 | > if (c/=c' || b1 /= b1' || b2 /= b2') then 118 | > error "Cursor and boundaries must be the same for zipping" 119 | > else let es'' = map (\i -> (i, (a!i, a'!i))) (indices a) 120 | > in PBA (array (bounds a) es'') c (b1, b2) 121 | 122 | > instance (Eq i, Ix i) => ComonadZip (PArray i) where 123 | > czip (PA a c, PA a' c') = 124 | > if (c/=c') then 125 | > error "Cursor and boundaries must be the same for zipping" 126 | > else let es'' = map (\i -> (i, (a!i, a'!i))) (indices a) 127 | > in PA (array (bounds a) es'') c 128 | 129 | 130 | -------------------- 131 | Other expermintation with abstractions on boundary testing 132 | 133 | 134 | > laplace1Dc, localMean1Dc :: Floating a => PBArray Int a -> a 135 | > laplace1Dc (PBA a i _) = a!(i-1) - 2*(a!i) + a!(i+1) 136 | > localMean1Dc (PBA a i _) = (a!(i-1) + a!i + a!(i+1)) / 3.0 137 | 138 | > withBoundary :: (Num i, Ix i) => PBArray i a -> PBArray i a -> a 139 | > withBoundary x y = withBoundary' . czip $ (x, y) 140 | 141 | > withBoundary' :: (Num i, Ix i) => PBArray i (a, a) -> a 142 | > withBoundary' (PBA a c (b1, b2)) = if (c>=b1 && c fst $ a!c 144 | > else 145 | > snd $ a!c 146 | 147 | > withExterior' :: (Num i, Ix i) => PBArray i a -> PBArray i a -> a -- assumes synchronisation 148 | > withExterior' (PBA a c (b1, b2)) (PBA a' _ _) = if (c>=b1 && c else a'!c 150 | 151 | > foo3 = [context| a => b <- laplace1Dc a 152 | > b' <- b `withBoundary` a 153 | > c <- localMean1Dc b' 154 | > c' <- c `withBoundary` a 155 | > d <- (extract b') `min` (extract c') 156 | > filterC (<0.3) 0.3 d |] 157 | 158 | > boo4 = [context| a => b <- laplace1Dc a 159 | > b' <- b `withBoundary` a 160 | > c <- localMean1Dc b' 161 | > c' <- c `withBoundary` a 162 | > d <- (extract b') `min` (extract c') 163 | > w <- localMean1Dc d 164 | > w `withBoundary` a |] 165 | 166 | > boo4' = [context| a => b <- laplace1Dc a 167 | > b' <- b `withExterior'` a 168 | > c <- localMean1Dc b' 169 | > c' <- c `withExterior'` a 170 | > d <- (extract b') `min` (extract c') 171 | > w <- localMean1Dc d 172 | > w `withExterior'` a|] 173 | 174 | > boo4'' = [context| a => b <- laplace1Dc `withExterior` extract $ a 175 | > c <- localMean1Dc `withExterior` extract $ b 176 | > d <- (extract b) `min` (extract c) 177 | > localMean1Dc `withExterior` extract $ d |] 178 | 179 | 180 | 181 | ------------ 182 | 183 | 184 | > xa = PA (array (0,4) [(0, 3.0), (1, 0.5), (2, 0.7), (3, 0.5), (4, 0.0)]) (0::Int) 185 | > xb = PA (array (0,4) [(0, 5.4), (1, 1.5), (2, 3.4), (3, 4.5), (4, 4.0)]) (0::Int) 186 | 187 | > prog1a = [context| x => y <- laplace1D x 188 | > laplace1D y |] 189 | 190 | > prog2a = [context| x => y <- laplace1D x 191 | > z <- (extract x) + (extract y) 192 | > extract z |] 193 | 194 | > prog3a = [context| x => y <- laplace1D x 195 | > z <- (extract x) + (extract y) 196 | > laplace1D z |] 197 | 198 | --------------------- 199 | 200 | > -- ==================== 2D arrays ============== 201 | 202 | > -- To simplify code, make tuples of numbers a number type themselves 203 | > instance (Num a, Num b) => Num (a, b) where 204 | > (x, y) + (a, b) = (x + a, y + b) 205 | > (x, y) - (a, b) = (x - a, y - b) 206 | > (x, y) * (a, b) = (x * a, y * b) 207 | > abs (x, y) = (abs x, abs y) 208 | > signum (x, y) = (signum x, signum y) 209 | > fromInteger x = (fromInteger x, fromInteger x) 210 | 211 | 212 | > laplace2D, gauss2D :: Fractional a => PArray (Int, Int) a -> a 213 | > laplace2D a = a ? (-1, 0) + a ? (1, 0) + a ? (0, -1) + a ? (0, 1) - 4 * a ? (0, 0) 214 | > gauss2D a = (a ? (-1, 0) + a ? (1, 0) + a ? (0, -1) + a ? (0, 1) + 2 * a ? (0, 0)) / 6.0 215 | 216 | > (?) :: (Ix i, Num a, Num i) => PArray i a -> i -> a 217 | > (PA a i) ? i' = if (inRange (bounds a) (i+i')) then a!(i+i') else 0 218 | 219 | > xx :: PArray (Int, Int) Double 220 | > xx = PA (array ((0,0), (2,2)) [((0, 0), 1), ((0, 1), 1), ((0, 2), 2), 221 | > ((1, 0), 1), ((1, 1), 2), ((1, 2), 3), 222 | > ((2, 0), 3), ((2, 1), 2), ((2, 2), 1)]) (0,0) 223 | 224 | > proj (PA arr _) = arr 225 | 226 | > getData (PA arr _) = assocs arr 227 | 228 | > contours :: PArray (Int, Int) Double -> Double 229 | > contours = [context| x => y <- gauss2D x 230 | > z <- gauss2D y 231 | > w <- (extract y) - (extract z) 232 | > laplace2D w |] 233 | 234 | > (^.) g f = g . extend f 235 | 236 | > minus x y = extract x - extract y 237 | 238 | > contours' = laplace2D 239 | > ^. (\y' -> minus y' ^. gauss2D $ y') 240 | > ^. gauss2D 241 | 242 | contours_bad' = laplace2D 243 | ^. (minus 244 | ^. gauss2D 245 | ^. gauss2D 246 | 247 | > foo1 = [context| (a, b) => minus a b |] 248 | 249 | > foo2 = [context| (a, b) => (a', b') <- extract $ czip (a, b) 250 | > minus a' b' |] 251 | 252 | -------------------------------------------------------------------------------- /codo-notation.cabal: -------------------------------------------------------------------------------- 1 | name: codo-notation 2 | version: 0.7 3 | synopsis: A notation for comonads, analogous to the do-notation for monads. 4 | description: A notation for comonads, analogous to the do-notation for monads. 5 | . 6 | Requires the @TemplateHaskell@ and @QuasiQuotes@ extensions. 7 | . 8 | Example 1: 9 | . 10 | @ 11 | {-\# LANGUAGE TemplateHaskell \#-} 12 | {-\# LANGUAGE QuasiQuotes \#-} 13 | . 14 | import Control.Comonad 15 | import Language.Haskell.Codo 16 | . 17 | foo :: (Comonad c, Num a) => c a -> a 18 | foo = [codo| x => extract x + 1 |] 19 | @ 20 | . 21 | Example 2: 22 | . 23 | @ 24 | import Data.Monoid 25 | 26 | instance Monoid Double where 27 | mempty = 0.0 28 | mappend = (+) 29 | . 30 | differentiate f = ((f 0.001) - f 0) / 0.001 31 | . 32 | minima :: (Double -> Double) -> Bool 33 | minima = [codo| f => f' <- differentiate f 34 | f'' <- differentiate f' 35 | (extract f' < 0.001) && (extract f'' > 0) |] 36 | @ 37 | . 38 | Further explanation of the syntax can be found in the following (short) paper: with a numer of examples. 39 | . 40 | Further examples can be found here: . 41 | 42 | -- description: 43 | license: BSD3 44 | license-file: LICENSE 45 | author: Dominic Orchard (with additions from Edward Kmett) 46 | maintainer: Dominic Orchard 47 | stability: experimental 48 | -- copyright: 49 | category: Language 50 | build-type: Simple 51 | cabal-version: >=1.7 52 | 53 | source-repository head 54 | type: git 55 | location: git://github.com/dorchard/codo-notation.git 56 | 57 | library 58 | exposed-modules: Language.Haskell.Codo 59 | -- other-modules: 60 | build-depends: base >= 4.2 && < 5, 61 | comonad >= 3, 62 | template-haskell >= 2.7, 63 | haskell-src-meta >= 0.5.1, 64 | parsec >= 3, 65 | lens >= 3.0 66 | hs-source-dirs: src 67 | -------------------------------------------------------------------------------- /edit-distance-array.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE QuasiQuotes #-} 3 | > {-# LANGUAGE MultiParamTypeClasses #-} 4 | > {-# LANGUAGE FlexibleInstances #-} 5 | 6 | > import Language.Haskell.Codo 7 | > import Control.Comonad 8 | > import Data.Monoid 9 | 10 | > import Data.Array.IArray 11 | 12 | Usea an array to do dynamic programming as opposed to the (inefficient) InContext 13 | 14 | > data DynP x a = DynP (Array (Int, Int) a) [x] [x] (Int, Int) ((Int, Int), (Int, Int)) 15 | 16 | > instance Comonad (DynP x) where 17 | > extract (DynP a _ _ c _) = a ! c 18 | 19 | > extend f (DynP a x y c (b1, b2)) = 20 | > let es = map (\c' -> (c', f (DynP a x y c' (b1, b2)))) (range (b1, b2)) 21 | > a' = array (b1, b2) es 22 | > in DynP a' x y c (b1, b2) 23 | 24 | > instance Functor (DynP x) where 25 | > fmap f = extend (f . extract) 26 | 27 | 28 | Levenshtein edit-distance algorithms 29 | 30 | > levenshtein :: DynP Char Int -> Int 31 | > levenshtein = [codo| _ => -- Initialise first row and column 32 | > d <- levenshtein _ 33 | > dn <- (extract d) + 1 34 | > d0 <- (constant 0) `fbyX` dn 35 | > d' <- d0 `fbyY` dn 36 | > -- Shift (-1, 0), (0, -1), (-1, -1) 37 | > d_w <- d !!! (-1, 0) 38 | > d_n <- d !!! (0, -1) 39 | > d_nw <- d !!! (-1, -1) 40 | > -- Body 41 | > d'' <- if (correspondingX d == correspondingY d) then 42 | > extract d_nw 43 | > else minimum [(extract d_w) + 1, 44 | > (extract d_n) + 1, 45 | > (extract d_nw) + 1] 46 | > d' `thenXY` d'' |] 47 | 48 | > edit_distance x y = levenshtein <<= (DynP undefined (' ':x) (' ':y) (0, 0) ((0, 0), (length x, length y))) 49 | 50 | Operations on dynamic programming grids 51 | 52 | > (!!!) = flip ixRelative 53 | 54 | > -- Relative indexing of the grid 55 | > ixRelative :: (Int, Int) -> DynP x a -> a 56 | > ixRelative (x1, x2) (DynP a _ _ c@(c1, c2) _) = a ! (c1 + x1, c2 + x2) 57 | 58 | > correspondingX, correspondingY :: DynP x a -> x 59 | > correspondingX (DynP s x y c@(c1, c2) _) = x!!c1 60 | > correspondingY (DynP s x y c@(c1, c2) _) = y!!c2 61 | 62 | 63 | > fbyX :: DynP x a -> DynP y a -> a 64 | > fbyX (DynP s _ _ c@(c1, c2) _) (DynP s' _ _ c'@(c1', c2') _) 65 | > = if (c1 == 0 && c1' == 0) then s ! (0, c2) 66 | > else s' ! (c1' - 1, c2') 67 | 68 | > fbyY :: DynP x a -> DynP y a -> a 69 | > fbyY (DynP s _ _ c@(c1, c2) _) (DynP s' _ _ c'@(c1', c2') _) 70 | > = if (c2 == 0 && c2' == 0) then s ! (c1, 0) 71 | > else s' ! (c1', c2' - 1) 72 | 73 | > thenXY :: DynP x a -> DynP x a -> a 74 | > thenXY (DynP s _ _ c@(c1, c2) _) (DynP s' _ _ c'@(c1', c2') _) 75 | > = if ((c1 == 0 && c1' == 0) || (c2 == 0 && c2' == 0)) then 76 | > s ! (c1, c2) 77 | > else s' ! (c1', c2') 78 | 79 | > constant :: a -> DynP x a 80 | > constant x = let arr = array ((0, 0), (0, 0)) [((0, 0), x)] 81 | > in DynP arr [] [] (0, 0) ((0, 0), (0, 0)) 82 | 83 | Output functions 84 | 85 | > instance (Show a) => Show (DynP x a) where 86 | > show (DynP a x y c ((bx0, by0), (bxn, byn))) = 87 | > let row v = (show $ map (\u -> a ! (u,v)) [bx0..bxn]) ++ "\n" 88 | > in concatMap row [by0..byn] -- ("b - " ++ (show ((bx0, by0), (bxn, byn)))) `trace` 89 | 90 | > output :: Show a => DynP Char a -> String 91 | > output (DynP a x y c _) = 92 | > let top = " " ++ foldr (\c -> \r -> [c] ++ " " ++ r) "" x ++ "\n" 93 | > row v = [y!!v] ++ (show $ map (\u -> (a ! (u,v))) [0..(length x - 1)]) ++ "\n" 94 | > in top ++ concatMap row [0..(length y - 1)] 95 | 96 | > l = "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?" 97 | 98 | > r = "But I must explain to you how all this mistaken idea of denouncing pleasure and praising pain was born and I will give you a complete account of the system, and expound the actual teachings of the great explorer of the truth, the master-builder of human happiness. No one rejects, dislikes, or avoids pleasure itself, because it is pleasure, but because those who do not know how to pursue pleasure rationally encounter consequences that are extremely painful. Nor again is there anyone who loves or pursues or desires to obtain pain of itself, because it is pain, but because occasionally circumstances occur in which toil and pain can procure him some great pleasure. To take a trivial example, which of us ever undertakes laborious physical exercise, except to obtain some advantage from it? But who has any right to find fault with a man who chooses to enjoy a pleasure that has no annoying consequences, or one who avoids a pain that produces no resultant pleasure?" 99 | 100 | 101 | Not used in this example 102 | 103 | 104 | > prod :: [a] -> [b] -> [(a, b)] 105 | > prod xs ys = xs >>= (\x' -> ys >>= (\y' -> return (x', y'))) 106 | 107 | > class Comonad c => ComonadZip c where 108 | > czip :: (c a, c b) -> c (a, b) 109 | 110 | > -- pre condition: the dyn prog paramerters are equal 111 | > instance ComonadZip (DynP x) where 112 | > czip ((DynP s l t c@(c1, c2) ((bx0, by0), (bxn, byn))), 113 | > (DynP s' _ _ d@(d1, d2) ((bx0', by0'), (bxn', byn')))) = 114 | > let (y1, y2) = (max c1 d1, max c2 d2) 115 | > es = map (\(x1, x2) -> let c' = (x1 - y1 + c1, x2 - y2 + c2) 116 | > d' = (x1 - y1 + d1, x2 - y2 + d2) 117 | > in ((x1, x2), (s ! c', s' ! d'))) 118 | > (prod [(min bx0 bx0')..(max bxn bxn')] 119 | > [(min by0 by0')..(max byn byn')]) 120 | > a' = array ((min bx0 bx0', min by0 by0'), (max bxn bxn', max byn byn')) es 121 | > in DynP a' l t (y1, y2) ((min bx0 bx0', min by0 by0'), (max bxn bxn', max byn byn')) -------------------------------------------------------------------------------- /edit-distance-trans.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE QuasiQuotes #-} 3 | > {-# LANGUAGE MultiParamTypeClasses #-} 4 | > {-# LANGUAGE FlexibleInstances #-} 5 | > {-# LANGUAGE TypeOperators #-} 6 | 7 | > import Language.Haskell.Codo 8 | > import Control.Comonad 9 | > import Data.Monoid 10 | 11 | > import Control.Compose 12 | > import Context 13 | 14 | Use a "comonad transformer" to define !the dynamic programming comonad 15 | as the composite of the InContext and product comonads. 16 | 17 | > type DynP x = ((,) ([x], [x])) :. (InContext (Int, Int)) 18 | 19 | > -- Distributive law between comonads 20 | > class ComonadDist c d where 21 | > cdist :: c (d a) -> d (c a) 22 | 23 | > -- The composite of any two comonads with a (coherence preserving) distributive law 24 | > -- forms a comonad 25 | > instance (Comonad c, Comonad d, ComonadDist c d) => Comonad (c :. d) where 26 | > extract (O x) = extract . extract $ x 27 | > duplicate (O x) = O . (fmap (fmap O)) . (fmap cdist) . (fmap (fmap duplicate)) . duplicate $ x 28 | 29 | 30 | > -- Comonad transformers 31 | > class ComonadTrans t where 32 | > liftC :: Comonad c => t c a -> c a 33 | 34 | > -- Comonad transformer for composites 35 | > class ComonadTransComp t where 36 | > liftC_comp :: Comonad c => (t :. c) a -> c a 37 | 38 | 39 | > instance ComonadDist ((,) x) (InContext s) where 40 | > cdist (x, InContext s c) = InContext (\c -> (x, s c)) c 41 | 42 | > instance ComonadTransComp ((,) x) where 43 | > liftC_comp (O (x, a)) = a 44 | 45 | 46 | 47 | Levenshtein edit-distance algorithms 48 | 49 | > levenshtein :: DynP Char Int -> Int 50 | > levenshtein = [codo| _ => -- Initialise first row and column 51 | > d <- levenshtein _ 52 | > dn <- (extract d) + 1 53 | > d0 <- (constant 0) `fbyXl` dn 54 | > d' <- d0 `fbyYl` dn 55 | > -- Shift (-1, 0), (0, -1), (-1, -1) 56 | > d_w <- d !!! (-1, 0) 57 | > d_n <- d !!! (0, -1) 58 | > d_nw <- d !!! (-1, -1) 59 | > -- Body 60 | > d'' <- if (correspondingX d == correspondingY d) then 61 | > extract d_nw 62 | > else minimum [(extract d_w) + 1, 63 | > (extract d_n) + 1, 64 | > (extract d_nw) + 1] 65 | > d' `thenXYl` d'' |] 66 | 67 | > edit_distance x y = levenshtein <<= (O ((' ':x, ' ':y), InContext undefined (0, 0))) 68 | 69 | *Main> putStr $ output $ edit_distance "hello" "hey" 70 | h e l l o 71 | [0,1,2,3,4,5] 72 | h[1,0,1,2,3,4] 73 | e[2,1,0,1,2,3] 74 | y[3,2,1,1,2,3] 75 | 76 | 77 | Operations on dynamic programming grids 78 | 79 | > (!!!) :: DynP x a -> (Int, Int) -> a 80 | > (!!!) = flip (\x -> (ixRelative x) . liftC_comp) 81 | 82 | > -- Relative indexing of the grid - can be generalised 83 | > ixRelative :: (Int, Int) -> InContext (Int, Int) a -> a 84 | > ixRelative (x1, x2) (InContext s c@(c1, c2)) = s (c1 + x1, c2 + x2) 85 | 86 | > correspondingX, correspondingY :: DynP x a -> x 87 | > correspondingX (O ((x, y), (InContext s c@(c1, c2)))) = x!!c1 88 | > correspondingY (O ((x, y), (InContext s c@(c1, c2)))) = y!!c2 89 | 90 | > fbyXl x y = fbyX (liftC_comp x) (liftC_comp y) 91 | > fbyYl x y = fbyY (liftC_comp x) (liftC_comp y) 92 | > thenXYl x y = thenXY (liftC_comp x) (liftC_comp y) 93 | 94 | > fbyX :: InContext (Int, Int) a -> InContext (Int, Int) a -> a 95 | > fbyX (InContext s c@(c1, c2)) (InContext s' c'@(c1', c2')) = 96 | > if (c1 == 0 && c1' == 0) then s (0, c2) 97 | > else s' (c1' - 1, c2') 98 | 99 | > fbyY :: InContext (Int, Int) a -> InContext (Int, Int) a -> a 100 | > fbyY (InContext s c@(c1, c2)) (InContext s' c'@(c1', c2')) = 101 | > if (c2 == 0 && c2' == 0) then s (c1, 0) 102 | > else s' (c1', c2' - 1) 103 | 104 | 105 | fbyXY :: InContext (Int, Int) a -> InContext (Int, Int) a -> a 106 | fbyXY (InContext s c@(c1, c2)) (InContext s' c'@(c1', c2')) = 107 | if ((c1 == 0 || c2 == 0) && (c1' == 0 || c2' == 0)) then 108 | s (max c1 c1', max c2 c2') 109 | else 110 | s' (c1' - 1, c2' - 1)n fst $ s c 111 | 112 | > thenXY :: InContext (Int, Int) a -> InContext (Int, Int) a -> a 113 | > thenXY (InContext s c@(c1, c2)) (InContext s' c'@(c1', c2')) = 114 | > if ((c1 == 0 && c1' == 0) || (c2 == 0 && c2' == 0)) then 115 | > s (c1, c2) 116 | > else s' (c1', c2') 117 | 118 | > constant :: a -> DynP x a 119 | > constant x = O (([], []), InContext (\c -> x) (0, 0)) 120 | 121 | Output functions 122 | 123 | > output :: Show a => DynP Char a -> String 124 | > output (O ((x, y), (InContext s c))) = 125 | > let top = " " ++ foldr (\c -> \r -> [c] ++ " " ++ r) "" x ++ "\n" 126 | > row v = [y!!v] ++ (show $ map (\u -> s (u,v)) [0..(length x - 1)]) ++ "\n" 127 | > in top ++ concatMap row [0..(length y - 1)] 128 | 129 | 130 | 131 | 132 | -------------------------------------------------------------------------------- /edit-distance.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE QuasiQuotes #-} 3 | > {-# LANGUAGE MultiParamTypeClasses #-} 4 | > {-# LANGUAGE FlexibleInstances #-} 5 | 6 | > import Language.Haskell.Codo 7 | > import Control.Comonad 8 | 9 | > import Context 10 | 11 | 2D dynamic programming example 12 | Comonad is a composite of InContext and product comonad 13 | 14 | > data DynP x a = DynP (InContext (Int, Int) a) [x] [x] 15 | 16 | Comonad definition 17 | 18 | > instance Comonad (DynP x) where 19 | > extract (DynP d _ _) = extract d 20 | 21 | > extend f (DynP (InContext s c) x y) = 22 | > DynP (InContext (\c' -> f (DynP (InContext s c') x y)) c) x y 23 | 24 | > instance Functor (DynP x) where 25 | > fmap f = extend (f . extract) 26 | 27 | Levenshtein edit-distance example 28 | 29 | > levenshtein :: DynP Char Int -> Int 30 | > levenshtein = [codo| _ => -- Initialise first row and column 31 | > d <- levenshtein _ 32 | > dn <- (extract d) + 1 33 | > d0 <- (constant 0) `fbyX` dn 34 | > d' <- d0 `fbyY` dn 35 | > -- Shift (-1, 0), (0, -1), (-1, -1) 36 | > d_w <- d !!! (-1, 0) 37 | > d_n <- d !!! (0, -1) 38 | > d_nw <- d !!! (-1, -1) 39 | > -- Body 40 | > d'' <- if (correspondingX d == correspondingY d) then 41 | > extract d_nw 42 | > else minimum [(extract d_w) + 1, 43 | > (extract d_n) + 1, 44 | > (extract d_nw) + 1] 45 | > d' `thenXY` d'' |] 46 | 47 | > edit_distance x y = levenshtein <<= (DynP (InContext undefined (0, 0)) (' ':x) (' ':y)) 48 | 49 | e.g. 50 | 51 | *Main> edit_distance "hello" "hey" 52 | ' ' 'h' 'e' 'l' 'l' 'o' 53 | ' '[0,1,2,3,4,5] 54 | 'h'[1,0,1,2,3,4] 55 | 'e'[2,1,0,1,2,3] 56 | 'y'[3,2,1,1,2,3] 57 | 58 | 59 | Operations on dynamic programming grids 60 | 61 | > (!!!) = flip ixRelative 62 | 63 | > -- Relative indexing of the grid 64 | > ixRelative :: (Int, Int) -> DynP x a -> a 65 | > ixRelative (x1, x2) (DynP (InContext s c@(c1, c2)) _ _) = s (c1 + x1, c2 + x2) 66 | 67 | > correspondingX, correspondingY :: DynP x a -> x 68 | > correspondingX (DynP (InContext s c@(c1, c2)) x y) = x!!c1 69 | > correspondingY (DynP (InContext s c@(c1, c2)) x y) = y!!c2 70 | 71 | > fbyX :: DynP x a -> DynP y a -> a 72 | > fbyX (DynP (InContext s c@(c1, c2)) x y) (DynP (InContext s' c'@(c1', c2')) _ _) 73 | > = if (c1 == 0 && c1' == 0) then s (0, c2) 74 | > else s' (c1' - 1, c2') 75 | 76 | > fbyY :: DynP x a -> DynP y a -> a 77 | > fbyY (DynP (InContext s c@(c1, c2)) x y) (DynP (InContext s' c'@(c1', c2')) _ _) 78 | > = if (c2 == 0 && c2' == 0) then s (c1, 0) 79 | > else s' (c1', c2' - 1) 80 | 81 | fbyXY :: DynP x a -> DynP y a -> a 82 | fbyXY (DynP (InContext s c@(c1, c2)) x y) (DynP (InContext s' c'@(c1', c2')) _ _) 83 | = if ((c1 == 0 || c2 == 0) && (c1' == 0 || c2' == 0)) then 84 | s (max c1 c1', max c2 c2') 85 | else 86 | s' (c1' - 1, c2' - 1) 87 | 88 | > thenXY :: DynP x a -> DynP x a -> a 89 | > thenXY (DynP (InContext s c@(c1, c2)) x y) (DynP (InContext s' c'@(c1', c2')) _ _) = 90 | > if ((c1 == 0 && c1' == 0) || (c2 == 0 && c2' == 0)) then 91 | > s (c1, c2) 92 | > else s' (c1', c2') 93 | 94 | > constant :: a -> DynP x a 95 | > constant x = DynP (InContext (\c -> x) (0, 0)) [] [] 96 | 97 | > -- Not used in this example 98 | > prevX, nextX, prevY, nextY, prevXY, nextXY :: DynP x a -> a 99 | > prevX = ixRelative (-1, 0) 100 | > prevY = ixRelative (0, -1) 101 | > prevXY = ixRelative (-1, -1) 102 | > nextX = ixRelative (1, 0) 103 | > nextY = ixRelative (0, 1) 104 | > nextXY = ixRelative (1, 1) 105 | 106 | 107 | Output functions 108 | 109 | > instance (Show a, Show x) => Show (DynP x a) where 110 | > show (DynP (InContext s c) x y) = 111 | > let top = foldr (\c -> \r -> (show c) ++ " " ++ r) "" x ++ "\n" 112 | > row v = (show $ y!!v) ++ (show $ map (\u -> s (u,v)) [0..(length x - 1)]) ++ "\n" 113 | > in top ++ concatMap row [0..(length y - 1)] 114 | 115 | output :: Show a => DynP Char a -> String 116 | output (DynP (InContext s c) x y) = 117 | let top = " " ++ foldr (\c -> \r -> [c] ++ " " ++ r) "" x ++ "\n" 118 | row v = [y!!v] ++ (show $ map (\u -> s (u,v)) [0..(length x - 1)]) ++ "\n" 119 | in top ++ concatMap row [0..(length y - 1)] 120 | 121 | 122 | -------------------------------------------------------------------------------- /lucid-streams.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE QuasiQuotes #-} 2 | > {-# LANGUAGE FlexibleInstances #-} 3 | > {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | > {-# LANGUAGE NoMonomorphismRestriction #-} 6 | 7 | > import Control.Comonad 8 | > import Language.Haskell.Codo 9 | 10 | > import Context 11 | 12 | > type Stream a = InContext Int a 13 | 14 | > -- n = 0 fby n + 1 15 | > nat' :: Num a => Stream b -> a 16 | > nat' = [codo| _ => n' <- (nat' _) + 1 17 | > (constant 0) `fby` n' |] 18 | 19 | > nat = nat' <<= (constant ()) 20 | 21 | > -- fib = 0 fby 1 fby (fib + next fib) 22 | > fib' :: Num a => Stream () -> a 23 | > fib' = [codo| _ => fib <- fib' _ 24 | > fibn2 <- (next fib) + (extract fib) 25 | > fibn1 <- (constant 1) `fby` fibn2 26 | > (constant 0) `fby` fibn1 |] 27 | 28 | > fib = fib' <<= (constant ()) 29 | 30 | 31 | > -- Example of nested tuple patterns 32 | > tup3 = [codo| (x, (y, z)) => a <- (extract y) + (extract z) 33 | > x `fby` a |] 34 | 35 | Stream operations 36 | 37 | > next :: Stream a -> a 38 | > next ~(InContext s c) = s (c+1) 39 | 40 | > fby :: Stream a -> Stream a -> a 41 | > fby ~(InContext s c) ~(InContext t d) = if (c==0 && d==0) then s 0 else t (d-1) 42 | 43 | > constant :: a -> Stream a 44 | > constant x = InContext (\_ -> x) 0 45 | 46 | Output function 47 | 48 | > instance Show a => Show (Stream a) where 49 | > show (InContext s c) = (show (map s [0..20]))++("@"++(show c)) 50 | -------------------------------------------------------------------------------- /num-functions.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE FlexibleInstances #-} 2 | > {-# LANGUAGE TemplateHaskell #-} 3 | > {-# LANGUAGE QuasiQuotes #-} 4 | > {-# LANGUAGE NoMonomorphismRestriction #-} 5 | 6 | > import Language.Haskell.Codo 7 | > import Control.Comonad 8 | > import Data.Monoid 9 | > import Data.Array 10 | > import Text.Printf 11 | 12 | > import Context 13 | 14 | > import System.IO 15 | 16 | Monoid for the domain of the exponent comonad 17 | 18 | > instance Monoid Float where 19 | > mempty = 0 20 | > mappend = (+) 21 | 22 | Differentiate function 23 | 24 | > differentiate :: (Float -> Float) -> Float 25 | > differentiate f = (f ep - f 0.0) / ep where ep = 0.01 26 | 27 | 28 | 29 | Minima testing function 30 | 31 | > roughlyEqual x y = x < (y+0.0000001) && x > (y-0.0000001) 32 | 33 | > minima = [codo| f => f' <- differentiate f 34 | > f'' <- differentiate f' 35 | > (extract f'' `roughlyEqual` 0) && (extract f'' < 0) |] 36 | 37 | Macluarin approximations 38 | 39 | > m3 = [codo| (f, x) => f' <- differentiate f 40 | > f'' <- differentiate f' 41 | > (f (-extract x)) 42 | > + (f' (-extract x)) * (extract x) 43 | > + (f'' (-extract x)) / 2 * (extract x)**2 |] 44 | 45 | > m3' = [codo| (f, xf) => f' <- differentiate f 46 | > f'' <- differentiate f' 47 | > let x = extract xf 48 | > (f (-x)) 49 | > + (f' (-x)) * x 50 | > + ((f'' (-x)) / 2) * x**2 |] 51 | 52 | Zipping operations 53 | 54 | > class Comonad c => ComonadZip c where 55 | > czip :: (c a, c b) -> c (a, b) 56 | 57 | > instance Monoid x => ComonadZip ((->) x) where 58 | > czip (f, g) = \x -> (f x, g x) 59 | 60 | 61 | Example curves 62 | 63 | > circF :: Float -> Float 64 | > circF x = sqrt (1 - x*x) 65 | > 66 | > lineF :: Float -> Float -> (Float -> Float) 67 | > lineF m c x = m*x + c 68 | 69 | > expF :: Float -> Float 70 | > expF = exp 71 | 72 | Output functions 73 | 74 | > instance Show a => Show (Float -> a) where 75 | > show c = concatMap (\i -> show i ++ " = " ++ show (c i) ++ "\n") [-2,-1.75..2] 76 | 77 | 78 | Output to .dat file for gnuplot 79 | 80 | > plotGraph f = concatMap (\i -> if (isNaN (f i)) then printf "\n" else printf "%.3f %.3f\n" (f i) i) [-2,-1.99..2] 81 | 82 | > plot f file = writeFile file (plotGraph f) 83 | 84 | > plotGraph2 f g = concatMap (\i -> if (isNaN (f i) || isNaN (g i)) then printf "\n" else printf "%.3f \t %.3f \t %.3f\n" i (f i) (g i)) [-2,-1.999..2] 85 | > plot2 x y f = writeFile f ("# \"x\" \t \"f x\" \t \"g x\"\n" ++ plotGraph2 x y) 86 | 87 | 88 | e.g. 89 | 90 | > foo1 = plot2 expF (m3 <<= (czip (expF, id))) "exp-approx.dat" 91 | 92 | gnuplot> set style data lines 93 | gnuplot> plot "exp-approx.dat" using 1:2 title 'exp', "exp-approx.dat" using 1:3 title 'exp-approx' 94 | -------------------------------------------------------------------------------- /sample.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE QuasiQuotes #-} 3 | > import Control.Comonad 4 | > import Language.Haskell.Codo 5 | > 6 | > foo :: (Comonad c, Num a) => c a -> a 7 | > foo = [codo| x => extract x + 1 |] -------------------------------------------------------------------------------- /sample2.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE QuasiQuotes #-} 3 | > import Control.Comonad 4 | > import Language.Haskell.Codo 5 | > import Data.Monoid 6 | 7 | > instance Monoid Double where 8 | > mempty = 0.0 9 | > mappend = (+) 10 | 11 | > differentiate f = ((f 0.001) - f 0) / 0.001 12 | 13 | > minima :: (Double -> Double) -> Bool 14 | > minima = [codo| f => f' <- differentiate f 15 | > f'' <- differentiate f' 16 | > (extract f' < 0.001) && (extract f'' > 0) |] 17 | 18 | -------------------------------------------------------------------------------- /src/Language/Haskell/Codo.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE NoMonomorphismRestriction #-} 3 | 4 | > module Language.Haskell.Codo(codo,context,coextendR) where -- coextendR is only exported at the moment for illustration purposes but later should be hidden 5 | 6 | > import Text.ParserCombinators.Parsec 7 | > import Text.ParserCombinators.Parsec.Expr 8 | > import Text.Parsec.Char 9 | > import qualified Text.ParserCombinators.Parsec.Token as Token 10 | 11 | > import Control.Lens 12 | > import Data.Data.Lens 13 | 14 | > import Language.Haskell.TH 15 | > import Language.Haskell.TH.Syntax 16 | > import Language.Haskell.TH.Quote 17 | > import Language.Haskell.Meta.Parse 18 | 19 | > import Data.Maybe 20 | > import Debug.Trace 21 | > import Data.Char 22 | 23 | > import Control.Comonad 24 | 25 | Optimisation re-write rules - changes complexity from O(n^k) to O(n) for codo 26 | 27 | > {-# RULES "coextend/assoc" forall g f . coextendR (g . coextendR f) = coextendR g . coextendR f #-} 28 | 29 | > {-# RULES "coextend/cmap/assoc" forall h g f . coextendR ((g . coextendR f) . cmapR h) = coextendR g . coextendR f . cmapR h #-} 30 | 31 | For GHC rewriting to work it requires inlined-aliases to the 32 | core operations of the comonad 33 | 34 | > {-# INLINE cmapR #-} 35 | > cmapR :: Functor c => (a -> b) -> c a -> c b 36 | > cmapR = fmap 37 | 38 | > {-# INLINE coextendR #-} 39 | > coextendR :: Comonad c => (c a -> b) -> c a -> c b 40 | > coextendR = extend 41 | 42 | > fv var = varE $ mkName var 43 | 44 | > -- Codo translation comprises a (1) parsing/textual-transformation phase 45 | > -- (2) interpretation phase 46 | > -- i). top-level transformation 47 | > -- ii). bindings transformations 48 | > -- iii). expression transformation 49 | 50 | > -- ***************************** 51 | > -- (1) Parsing/textual-transformation 52 | > -- ***************************** 53 | 54 | > context = codo 55 | 56 | > codo :: QuasiQuoter 57 | > codo = QuasiQuoter { quoteExp = interpretCodo, 58 | > quotePat = undefined, 59 | > quoteType = undefined, 60 | > quoteDec = undefined } 61 | 62 | 63 | > interpretCodo s = do loc <- location 64 | > let pos = (loc_filename loc, 65 | > fst (loc_start loc), 66 | > 1) -- set to 1 as we add spaces in to account for 67 | > -- the start of the line 68 | > -- the following corrects the text to account for the preceding 69 | > -- Haskell code + quasiquote, to preserve alignment of further lines 70 | > s'' <- return ((take (snd (loc_start loc) - 1) (repeat ' ')) ++ s) 71 | > s''' <- (doParse codoTransPart pos s'') 72 | > case (parseExp s''') of 73 | > Left l -> error l 74 | > Right e -> codoMain e 75 | 76 | > doParse :: Monad m => (Parser a) -> (String, Int, Int) -> String -> m a 77 | > doParse parser (file, line, col) input = 78 | > case (runParser p () "" input) of 79 | > Left err -> fail $ show err 80 | > Right x -> return x 81 | > where 82 | > p = do { pos <- getPosition; 83 | > setPosition $ 84 | > (flip setSourceName) file $ 85 | > (flip setSourceLine) line $ 86 | > (flip setSourceColumn) col $ pos; 87 | > x <- parser; 88 | > return x; } 89 | 90 | 91 | > -- Parsing a codo-block 92 | 93 | > pattern = (try ( do string "=>" 94 | > return "" )) <|> 95 | > ( do p <- anyChar 96 | > ps <- pattern 97 | > return $ p:ps ) 98 | 99 | 100 | > codoTransPart = do s1 <- many space 101 | > p <- pattern 102 | > rest <- many (codoTransPart') 103 | > return $ (take (length s1 - 4) (repeat ' ')) 104 | > ++ "\\" ++ p ++ "-> do" ++ concat rest 105 | 106 | > codoTransPart' = try ( do string "codo" 107 | > s1 <- many space 108 | > p <- pattern 109 | > s3 <- many space 110 | > pos <- getPosition 111 | > col <- return $ sourceColumn pos 112 | > marker <- return $ ("_reserved_codo_block_marker_\n" ++ (take (col - 1) (repeat ' '))) 113 | > return $ "\\" ++ p ++ "->" ++ s1 ++ "do " ++ s3 ++ marker) 114 | > <|> ( do c <- anyChar 115 | > if c=='_' then return "_reserved_gamma_" 116 | > else return [c] ) 117 | 118 | > -- ***************************** 119 | > -- (2) interpretation phase 120 | > -- ***************************** 121 | > -- i). top-level transformation 122 | > -- ***************************** 123 | 124 | > -- Top-level translation 125 | > codoMain :: Exp -> Q Exp 126 | > codoMain (LamE p bs) = [| $(codoMain' (LamE p bs)) . (cmapR $(return $ projFun p)) |] 127 | 128 | > codoMain' :: Exp -> Q Exp 129 | > codoMain' (LamE [TupP ps] (DoE stms)) = codoBind stms (concatMap patToVarPs ps) 130 | > codoMain' (LamE [WildP] (DoE stms)) = codoBind stms [mkName "_reserved_gamma_"] 131 | > codoMain' (LamE [VarP v] (DoE stms)) = codoBind stms [v] 132 | > codoMain' _ = error codoPatternError 133 | 134 | > codoPatternError = "Malformed codo: codo must start with either a variable, wildcard, or tuple pattern (of wildcards or variables)" 135 | 136 | > -- create the projection function to arrange the codo-Block parameters into the correct ordder 137 | > patToVarPs :: Pat -> [Name] 138 | > patToVarPs (TupP ps) = concatMap patToVarPs ps 139 | > patToVarPs WildP = [mkName "_reserved_gamma_"] 140 | > patToVarPs (VarP v) = [v] 141 | > patToVarPs _ = error "Only tuple, variable, or wildcard patterns currently allowed" 142 | 143 | > projExp [] = TupE [] 144 | > projExp (x:xs) = TupE [x, (projExp xs)] 145 | 146 | > projPat [] = TupP [] 147 | > projPat (x:xs) = TupP [x, (projPat xs)] 148 | 149 | > projFun p = LamE (map replaceWild p) (projExp (map VarE (concatMap patToVarPs p))) 150 | 151 | > replaceWild WildP = VarP $ mkName "_reserved_gamma_" 152 | > replaceWild x = x 153 | 154 | > -- ********************** 155 | > -- ii). bindings transformations 156 | > -- ********************** 157 | 158 | > convert lVars envVars = LamE [TupP [TupP (map VarP lVars), 159 | > projPat (map VarP envVars)]] (projExp (map VarE (lVars ++ envVars))) 160 | 161 | > -- Note all these functions for making binders take a variable which is the "gamma" variable 162 | > -- Binding interpretation (\vdash_c) 163 | 164 | > codoBind :: [Stmt] -> [Name] -> Q Exp 165 | > codoBind [NoBindS e] vars = [| \gamma -> $(envProj vars (transformMOf uniplate (doToCodo) e)) gamma |] 166 | > codoBind [x] vars = error "Codo block must end with an expressions" 167 | > codoBind ((NoBindS e):bs) vars = [| $(codoBind bs vars) . 168 | > (coextendR (\gamma -> 169 | > ($(envProj vars (transformMOf uniplate (doToCodo) e)) gamma, 170 | > extract gamma))) |] 171 | 172 | > codoBind ((LetS [ValD p (NormalB e) []]):bs) vars = 173 | > [| (\gamma -> 174 | > $(letE [valD (return p) 175 | > (normalB $ [| $(envProj vars (transformMOf uniplate (doToCodo) e)) gamma |]) []] [| $(codoBind bs vars) $(fv "gamma") |])) |] 176 | 177 | > codoBind ((BindS (VarP v) e):bs) vars = [| $(codoBind bs (v:vars)) . 178 | > (coextendR (\gamma -> 179 | > ($(envProj vars (transformMOf uniplate (doToCodo) e)) gamma, 180 | > extract gamma))) |] 181 | > codoBind ((BindS (TupP ps) e):bs) vars = [| $(codoBind bs ((concatMap patToVarPs ps) ++ vars)) . 182 | > (coextendR (\gamma -> 183 | > $(return $ convert (concatMap patToVarPs ps) vars) 184 | > ($(envProj vars (transformMOf uniplate (doToCodo) e)) gamma, 185 | > extract gamma))) |] 186 | > codoBind t _ = error "Ill-formed codo bindings" 187 | 188 | > doToCodo :: Exp -> Q Exp 189 | > doToCodo (LamE [VarP v] (DoE ((NoBindS (VarE n)):stmts))) 190 | > -- Nested codo-block 191 | > -- notably, doesn't pick up outside environment 192 | > | showName n == "_reserved_codo_block_marker_" = codoMain (LamE [VarP v] (DoE stmts)) 193 | > 194 | > | otherwise = return $ (DoE ((NoBindS (VarE n)):stmts)) 195 | > doToCodo e = return e 196 | 197 | 198 | > -- *********************** 199 | > -- iii). expression transformation 200 | > -- *********************** 201 | 202 | > -- Creates a scope where all the local variables are project 203 | > envProj :: [Name] -> ExpQ -> ExpQ 204 | > envProj vars exp = let gam = mkName "gamma" in (lamE [varP gam] (letE (projs vars (varE gam)) exp)) 205 | 206 | > -- Make a comonadic projection 207 | > mkProj gam (v, n) = valD (varP v) (normalB [| cmapR $(prj n) $(gam) |]) [] 208 | 209 | > -- Creates a list of projections 210 | > projs :: [Name] -> ExpQ -> [DecQ] 211 | > projs x gam = map (mkProj gam) (zip x [0..(length x - 1)]) 212 | 213 | > -- Computes the correct projection 214 | > prj 0 = [| fst |] 215 | > prj n = [| $(prj (n-1)) . snd |] 216 | --------------------------------------------------------------------------------