├── .gitignore ├── LICENSE ├── README.md ├── examples ├── blog-applicative.lhs ├── blog-constrainedmonad.lhs ├── blog-functors.lhs ├── blog-monad.lhs ├── blog-partiallyclosed.lhs ├── blog-rewrite.lhs ├── coretest.hs ├── criterion.hs ├── plots │ ├── mkplots.gnu │ ├── supercomp-lebesgue.dat │ └── unboxed.dat ├── supercomp-lebesgue.hs └── supercomp-manyparams.hs ├── src └── Data │ ├── Params.hs │ └── Params │ ├── Applicative.hs │ ├── Frac.hs │ ├── Functor.hs │ ├── Instances.hs │ ├── ModInt.hs │ ├── Monad.hs │ ├── PseudoPrim.hs │ ├── Vector.hs │ └── Vector │ ├── Storable.hs │ ├── StorableRaw.hs │ ├── Unboxed.hs │ └── UnboxedRaw.hs └── typeparams.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.swp 8 | .virtualenv 9 | .hsenv 10 | .cabal-sandbox/ 11 | cabal.sandbox.config 12 | cabal.config 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Michael Izbicki 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 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The typeparams library 2 | 3 | This library provides a lens-like interface for working with type parameters. In the code: 4 | 5 | ``` 6 | data Example p1 (p2::Config Nat) (p3::Constraint) = Example 7 | ``` 8 | 9 | `p1`, `p2`, and `p3` are the type parameters. The tutorial below uses unboxed vectors to demonstrate some of the library's capabilities. In particular, we'll see: 10 | 11 | 1. A type safe way to unbox your unboxed vectors. This technique gives a **25% speed improvement** on nearest neighbor queries. The standard `Vector` class provided in `Data.Vector.Generic` can be used, so we retain all the stream fusion goodness. 12 | 13 | 2. A simple interface for [supercompilation](http://stackoverflow.com/questions/9067545/what-is-supercompilation). In the example below, we combine this library and the [fast-math](https://github.com/liyang/fast-math) library to get up to a **40x speed improvement** when calculating the Lp distance between vectors. 14 | 15 | Further [documentation can be found on hackage](http://hackage.haskell.org/package/typeparams), and examples with non-vector data types can be found in the [examples folder](https://github.com/mikeizbicki/typeparams/tree/master/examples). You can download the library from github directly, or via cabal: 16 | 17 | ``` 18 | cabal update 19 | cabal install typeparams 20 | ``` 21 | 22 | ## Tutorial: unbox your unboxed vectors! 23 | 24 | The remainder of this README is a literate haskell file. Please follow along yourself! 25 | 26 | ``` 27 | > import Control.Category 28 | > import Data.Params 29 | > import Data.Params.Vector.Unboxed 30 | > import qualified Data.Vector.Generic as VG 31 | > import Prelude hiding ((.),id) 32 | ``` 33 | 34 | The `Data.Params.Vector.Unboxed` module contains the following definition for our vectors: 35 | 36 | ``` 37 | data family Vector (len::Config Nat) elem 38 | mkParams ''Vector 39 | ``` 40 | 41 | `mkParams` is a template haskell function that generates a number of useful functions and classes that will be described below. The `len` type param lets us statically enforce the size of a vector as follows: 42 | 43 | ``` 44 | > v1 = VG.fromList [1..10] :: Vector (Static 10) Float 45 | ``` 46 | 47 | Here, `Static` means that the parameter is known statically at compile time. If we don't know in advance the size of our vectors, however, we can set `len` to `Automatic`: 48 | 49 | ``` 50 | > v2 = VG.fromList [1..10] :: Vector Automatic Float 51 | ``` 52 | 53 | `v2` will behave exactly like the unboxed vectors in the `vector` package. 54 | 55 | The `Config` param generalizes the concept of implicit configurations introduced by [this functional pearl](http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf) by Oleg Kiselyov and Chung-chieh Shan. (See also the [ImplicitParams GHC extension](http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#implicit-parameters).) It can take on types of `Static x`, `Automatic`, or `RunTime`. This tutorial will begin by working through the capabilities of the `Static` configurations before discussing the other options. 56 | 57 | ### From type params to values 58 | 59 | 60 | We can get access to the value of the `len` parameter using the function: 61 | 62 | ``` 63 | viewParam :: ViewParam p t => TypeLens Base p -> t -> ParamType p 64 | ``` 65 | 66 | The singleton type `TypeLens Base p` identifies which parameter we are viewing in type `t`. The type lens we want is `_len :: TypeLens Base Param_len`. The value `_len` and type `Param_len` were created by the `mkParams` function above. The significance of `Base` will be explained in a subsequent section. 67 | 68 | All together, we use it as: 69 | 70 | ``` 71 | ghci> viewParam _len v1 72 | 10 73 | ``` 74 | 75 | The `viewParam` function does not evaluate its arguments, so we could also call the function as: 76 | 77 | ``` 78 | ghci> viewParam _len (undefined::Vector (Static 10) Float) 79 | 10 80 | ``` 81 | 82 | We cannot use `ViewParam` if the length is being managed automatically. `Vector Automatic Float` is not an instance of the `ViewParam` type class, so the type checker enforces this restriction automatically. 83 | 84 | ### Unboxing the vector 85 | 86 | If we know a vector's size at compile time, then the compiler has all the information it needs to unbox the vector. Therefore, we can construct a 2d unboxed vector by: 87 | 88 | ``` 89 | > vv1 :: Vector (Static 2) (Vector (Static 10) Float) 90 | > vv1 = VG.fromList [VG.fromList [1..10], VG.fromList [21..30]] 91 | ``` 92 | 93 | or even a 3d vector by: 94 | 95 | ``` 96 | > vvv1 :: Vector (Static 20) (Vector (Static 2) (Vector (Static 10) Float)) 97 | > vvv1 = VG.replicate 20 vv1 98 | ``` 99 | 100 | In general, there are no limits to the depth the vectors can be nested. 101 | 102 | ###Viewing nested parameters 103 | 104 | What if we want to view the length of a nested inner vector? The value `_elem :: TypeLens p (Param_elem p)` gives us this capability. It composes with `_len` to give the type: 105 | 106 | ``` 107 | _elem._len :: TypeLens Base (Param_elem Param_len) 108 | ``` 109 | 110 | `_elem` and `Param_elem` were also created by `mkParams`. In general, `mkParams` will generate these type lenses for every type param of its argument. If the type param `p1` has kind `*`, then the type lens will have type `_p1 :: TypeLens p (Param_p1 p)` and the class will have kind `Param_p1 :: (* -> Constraint) -> * -> Constraint`. If the type param has any other kind (e.g. `Config Nat`), then `mkParams` will generate `_p1 :: TypeLens Base Param_p1` and `Param_p1 :: * -> Constraint`. 111 | 112 | The type of `_elem` allows us to combine it with `_len` to view the inner parameters of a type. Using the vectors we created above, we can view their parameters with: 113 | 114 | ``` 115 | ghci> viewParam _len vv1 116 | 2 117 | 118 | ghci> viewParam (_elem._len) vv1 119 | 10 120 | 121 | ghci> viewParam _len vvv1 122 | 20 123 | 124 | ghci> viewParam (_elem._len) vvv1 125 | 2 126 | 127 | ghci> viewParam (_elem._elem._len) vvv1 128 | 10 129 | ``` 130 | 131 | ###Lensing into giant types 132 | 133 | What if instead of having a `Vector` of `Vector`s, we have some other data type of `Vectors`? For example, what if we have a `Maybe (Vector len elem)`. Now, how can we get access to the length of the vector? 134 | 135 | Consider the definition of `Maybe`: 136 | 137 | ``` 138 | data Maybe a = Nothing | Just a 139 | ``` 140 | 141 | If we run the following template haskell: 142 | 143 | ``` 144 | > mkParams ''Maybe 145 | ``` 146 | 147 | then we will generate the type lens `_a :: TypeLens p (Param_a p)` which will give us the desired capability: 148 | 149 | ``` 150 | ghci> viewParam (_a._len) (undefined :: Maybe (Vector (Static 10) Int)) 151 | 10 152 | ``` 153 | 154 | We can do the same process for any data type, even if the names of their type params overlap. For example, we can run: 155 | 156 | ``` 157 | > mkparams ''Either 158 | ``` 159 | 160 | This will reuse the already created `_a` type lens (which corresponds to the left component of `Either`) and generate the type lens `_b :: TypeLens p (Param_b p)` (which corresponds to the right component). 161 | 162 | We can use type lenses in this fashion to extract parameters from truly monstrous types. For example, given the type: 163 | 164 | ``` 165 | > type Monster a = Either 166 | > (Maybe (Vector (Static 34) Float)) 167 | > (Either 168 | > a 169 | > (Either 170 | > (Vector (Static 2) (Vector (Static 10) Double)) 171 | > (Vector (Static 1) Int) 172 | > ) 173 | > ) 174 | ``` 175 | 176 | We can do: 177 | 178 | ``` 179 | ghci> viewParam (_a._a._len) (undefined::Monster Int) 180 | 34 181 | 182 | ghci> viewParam (_b._b._a._elem._len) (undefined::Monster Float) 183 | 10 184 | ``` 185 | 186 | No matter how large the type is, we can compose `TypeLens`es to access any configuration parameter. 187 | 188 | It would be nice if the type lenses for these built in data types had more meaningful names (like `_just`,`_left`, and `_right`), but this would require a change to base. 189 | 190 | ###From values back to type params 191 | 192 | That's cool, but it's not super useful if we have to know the values of all our configurations at compile time. The `RunTime` and `Automatic` `Config` values give us more flexibility. We will see that the `RunTime` method is powerful but cumbersome, and the `Automatic` method will provide a much simpler interface that wraps the `RunTime` method. 193 | 194 | (The `RunTime` configurations use the magic of the [reflection](http://hackage.haskell.org/package/reflection) package. The internal code is based off of Austin Seipp's excellent [reflection tutorial](https://www.fpcomplete.com/user/thoughtpolice/using-reflection).) 195 | 196 | Whenever we need to specify a `RunTime` param, we use the function: 197 | 198 | ``` 199 | with1Param :: 200 | ( ParamIndex p 201 | ) => TypeLens Base p -> ParamType p -> ((ApplyConstraint p m) => m) -> m 202 | ``` 203 | 204 | For example, we can specify the length of the innermost vector as follows: 205 | 206 | ``` 207 | > vvv2 :: Vector (Static 1) (Vector (Static 1) (Vector RunTime Float)) 208 | > vvv2 = with1Param (_elem._elem._len) 10 $ VG.singleton $ VG.singleton $ VG.fromList [1..10] 209 | ``` 210 | 211 | Or we can specify the length of all vectors: 212 | 213 | ``` 214 | > vvv3 :: Vector RunTime (Vector RunTime (Vector RunTime Float)) 215 | > vvv3 = with1Param (_elem._elem._len) 10 216 | > $ with1Param (_elem._len) 1 217 | > $ with1Param _len 1 218 | > $ VG.singleton $ VG.singleton $ VG.fromList [1..10] 219 | ``` 220 | 221 | But wait! If we try to `show` either of these variables, we get an error message: 222 | 223 | ``` 224 | ghci> show vvv2 225 | :19:1: 226 | No instance for (Param_len (Vector 'RunTime Float)) 227 | arising from a use of ‘print’ 228 | In a stmt of an interactive GHCi command: print it 229 | ``` 230 | 231 | This is because `RunTime` configurations don't remember what value they were set to. Every time we use a variable with a `RunTime` configuration, we must manually specify the value. 232 | 233 | The `with1Param` function is only useful when we pass parameters to the output of whatever function we are calling. In the example of `show`, however, we need to pass parameters to the input of the function. We do this using the function: 234 | 235 | ``` 236 | apWith1Param :: 237 | ( ValidIndex p 238 | ) => TypeLens Base p 239 | -> ParamType p 240 | -> ((ApplyConstraint p m) => m -> n) 241 | -> ((ApplyConstraint p m) => m) 242 | -> n 243 | ``` 244 | 245 | Similar functions exist for passing more than one parameter. These functions let us specify configurations to the arguments of a function. So if we want to show our vectors, we could call: 246 | 247 | ``` 248 | ghci> apWith1Param (_elem._elem._len) 10 show vvv2 249 | "fromList [fromList [fromList [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]]]" 250 | 251 | ghci> apWith3Param (_elem._elem._len) 10 (_elem._len) 1 _len 1 show vvv3 252 | "fromList [fromList [fromList [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]]]" 253 | ``` 254 | 255 | #### A bug in GHC! 256 | 257 | Unfortunately, due to a [bug in GHC 7.8.2's typechecker](https://ghc.haskell.org/trac/ghc/ticket/9090), the above code doesn't typecheck. We must explicitly specify the specialized type of `apWithNParam` for it to work. This is syntactically very awkward. As a temporary workaround, the library provides the function: 258 | 259 | ``` 260 | apWith1Param' :: m -> ( 261 | ( ParamIndex p 262 | ) => TypeLens Base p 263 | -> ParamType p 264 | -> (ApplyConstraint p m => m -> n) 265 | -> (ApplyConstraint p m => m) 266 | -> n 267 | ) 268 | ``` 269 | 270 | The only difference is that the unconstrained type `m` is passed as the first argument, which causes the `apWith1Param'` function's type signature to be specialized for us correctly. We can use this function like: 271 | 272 | ``` 273 | ghci> apWith1Param' vvv2 (_elem._elem._len) 10 show vvv2 :: String 274 | "fromList [fromList [fromList [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]]]" 275 | 276 | ghci> apWith3Param vvv3 (_elem._elem._len) 10 (_elem._len) 1 _len 1 show vvv3 :: String 277 | "fromList [fromList [fromList [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]]]" 278 | ``` 279 | 280 | Notice that we can use the same variable as both the first and last parameter. This gives us a useable workaround in the presence of the GHC bug. 281 | 282 | ### Lying to the `RunTime` 283 | 284 | We can specify any value we want to a `RunTime` configuration. We can even change the value throughout the course of the program. For our `Vector` type, this will change the shape with no runtime overhead. For example: 285 | 286 | ``` 287 | ghci> apWith3Param' vvv3 (_elem._elem._len) 2 (_elem._len) 5 _len 1 show vvv3 :: String 288 | fromList [fromList [fromList [1.0,2.0] 289 | ,fromList [3.0,4.0] 290 | ,fromList [5.0,6.0] 291 | ,fromList [7.0,8.0] 292 | ,fromList [9.0,10.0] 293 | ]] 294 | ``` 295 | 296 | Of course, we must be careful. If we specify lengths that cause the size of the result to exceed the allocated `ByteArray`, then we will get undefined results: 297 | 298 | ``` 299 | ghci> apWith3Param vvv3 (_elem._elem._len) 2 (_elem._len) 5 _len 2 show vvv3 :: String 300 | fromList [fromList [fromList [1.0,2.0] 301 | ,fromList [3.0,4.0] 302 | ,fromList [5.0,6.0] 303 | ,fromList [7.0,8.0] 304 | ,fromList [9.0,10.0] 305 | ]] 306 | ,fromList [fromList [-1.7796708,4.5566e-41] 307 | ,fromList [-1.46142,4.5566e-41] 308 | ,fromList [-1.5570038e-7,4.5566e-41] 309 | ,fromList [-1.701097e-5,4.5566e-41] 310 | ,fromList [1.23e-43,0.0]] 311 | ] 312 | ``` 313 | 314 | (I've manually reformatted the output of show to make it easier to read.) 315 | 316 | ### Making it `Automatic` 317 | 318 | Let's recap... `Static` configurations are easy to work with but less flexible, whereas `RunTime` configurations are a flexible pain in the butt. We get the best of both worlds with `Automatic` configurations. 319 | 320 | With one dimensional vectors, making the length automatic is as easy as specifying the type signature: 321 | 322 | ``` 323 | > v3 :: Vector Automatic Float 324 | > v3 = VG.fromList [1..5] 325 | ``` 326 | 327 | Now, we can use `v3` just like we would use any vector from the `vector` package. 328 | 329 | With multiple dimensions, we must explicitly specify the inner dimensions like so: 330 | 331 | ``` 332 | > vvv4 :: Vector Automatic (Vector Automatic (Vector Automatic Float)) 333 | > vvv4 = with1ParamAutomatic (_elem._elem._len) 5 334 | > $ with1ParamAutomatic (_elem._len) 2 335 | > $ VG.singleton $ VG.replicate 2 $ VG.fromList [1..5] 336 | ``` 337 | 338 | This is required so that the vectors can enforce that every inner vector at the same level has the correct size. For example, the following code will give a run time error: 339 | 340 | ``` 341 | > vvv5 :: Vector Automatic (Vector Automatic (Vector Automatic Float)) 342 | > vvv5 = with1ParamAutomatic (_elem._elem._len) 5 343 | > $ with1ParamAutomatic (_elem._len) 2 344 | > $ VG.singleton $ VG.fromList [VG.fromList [1..5], VG.fromList [1..4]] 345 | ``` 346 | 347 | Using `vvv4` is as convenient as using any vectors from the `vector` package that can be nested. For example: 348 | 349 | ``` 350 | ghci> show vvv4 351 | fromList [fromList [fromList [1.0,2.0,3.0,4.0,5.0],fromList [1.0,2.0,3.0,4.0,5.0]]] 352 | 353 | ghci> vvv4 VG.! 0 VG.! 1 VG.! 3 354 | 4.0 355 | 356 | ghci> VG.foldl1' (VG.zipWith (+)) $ vvv4 VG.! 0 357 | fromList [2.0,4.0,6.0,8.0,10.0] 358 | ``` 359 | 360 | When using `Automatic` parameters, there is no need for the `apWithNParam` family of functions. Internally, the type will store the value of the configuration. Whenever the value is needed, `apWith1Param` is called for us automatically. 361 | 362 | ### So how much faster?! 363 | 364 | The file [examples/criterion.hs](https://github.com/mikeizbicki/typeparams/blob/master/examples/criterion.hs) contains some run time experiments that show just how fast the unboxed unboxed vectors are. In one test, it uses the naive O(n^2) algorithm to perform nearest neighbor searches. The results are shown below: 365 | 366 |

367 | 368 |

369 | 370 | The green line uses vectors provided in the `Data.Params.Vector.Unboxed` module of type `Vector Automatic (Vector Automatic Float)`; and the red line uses standard vectors from the `vector` package of type `Data.Vector.Vector (Data.Vector.Unboxed.Vector Float)`. In both cases, the number of dimensions of the data points was 400. 371 | 372 | Switching to unboxed unboxed vectors yields a nice performance boost of about 25%. The best part is that we barely have to change existing code at all. The only difference between the interface for a boxed unboxed vector and an unboxed unboxed vector is the initial construction. **If you have code that creates boxed unboxed vectors, you should get a similar performance gain switching over to this library.** 373 | 374 | ###Lebesgue or not to beg, that is the supercompilation 375 | 376 | If we combine this typeparams package with the [fast-math](https://github.com/liyang/fast-math) package, we get a very simple form of supercompilation. To demonstrate how this works, we will use the example of distance calculations in arbitrary [Lebesgue (Lp) spaces](https://en.wikipedia.org/wiki/Lp_space). For a given value `p`, the Lp norm is defined as: 377 | 378 |

379 | 380 |

381 | 382 | In haskell code we can create a `newtype` that will encode the value of `p` by: 383 | 384 | ``` 385 | newtype Lebesgue (p::Config Frac) (vec :: * -> *) elem = Lebesgue (vec elem) 386 | 387 | instance VG.Vector vec elem => VG.Vector (Lebesgue p vec) elem where 388 | {- ... -} 389 | 390 | ``` 391 | 392 | The `Frac` kind is similar to the `Nat` kind, except it represents any positive fraction at the type level. The file [src/Data/Params/Frac.hs](https://github.com/mikeizbicki/typeparams/blob/master/src/Data/Params/Frac.hs) contains the implementation of `Frac`. The file [examples/supercomp-lebesgue.hs](https://github.com/mikeizbicki/typeparams/blob/master/examples/supercomp-lebesgue.hs) for contains the implementation details of the `Lebesgue` example. 393 | 394 | We can then define a generic distance function over _any_ Lp space as: 395 | 396 | ``` 397 | lp_distance :: 398 | ( VG.Vector vec elem 399 | , Floating elem 400 | , ViewParam Param_p (Lebesgue p vec elem) 401 | ) => Lebesgue p vec elem -> Lebesgue p vec elem -> elem 402 | lp_distance !v1 !v2 = (go 0 (VG.length v1-1))**(1/p) 403 | where 404 | p = viewParam _p v1 405 | 406 | go tot (-1) = tot 407 | go tot i = go (tot+diff1**p) (i-1) 408 | where 409 | diff1 = abs $ v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 410 | ``` 411 | 412 | The value of `p` can now be set at compile time or at run time using the typeparams machinery. If we know the value at compile time, however, GHC can perform a number of optimizations: 413 | 414 | 1. The most important optimization is that the value of `p` never has to be stored in memory or even in a register. The resulting assembly uses what is called [immediate instructions](http://programmedlessons.org/AssemblyTutorial/Chapter-11/ass11_2.html). These assembly instructions are very fast in inner loops, and make the code run about 2x faster no matter what the value of `p` is. (The example [examples/coretest.hs](https://github.com/mikeizbicki/typeparams/blob/master/examples/coretest.hs) provides a minimal code sample that facilitates inspecting the effect of different parameters on the core code and resulting assembly.) 415 | 416 | 2. For specific values of `p`, we can optimize the formula of the Lp distance considerably. For example, exponentiation is very slow on x86 CPUs. Instead of evaluating `x**2`, it is much cheaper to evaluate `x*x`. Similarly, instead of evaluating `x**(1/2)`, it is cheaper to evaluate `sqrt x`. These optimizations are not safe for floating point numbers (small amounts of precision can be lost), so GHC doesn't perform them by default. The [fast-math](https://github.com/liyang/fast-math) library is needed to cause these optimizations. 417 | 418 | The plot below shows the resulting run times: 419 | 420 |

421 | 422 |

423 | 424 | The green values are the run times of the `lp_distance` function where `p` is specified using `Static`; the red for when `p` is specified using `RunTime`; and the blue for hand-optimized routines. Hashed columns indicate the test was run with the `Numeric.FastMath` import. All code was compiled using llvm and the optimization flags: `-optlo -O3 -optlo -enable-unsafe-fp-math`. Notice that there are some cases where the fast-math library is able to perform optimizations that llvm's `-enable-unsafe-fp-math` flag cannot. 425 | 426 | By using the generic `lp_distance` function, we get all the speed advantages of hand-optimized code, but we still have the flexibility of having users enter whatever `p` value they want to compute. We also avoid the need to manually write many hand-tuned distance functions. 427 | 428 | ##Thoughts for the road 429 | 430 | It is popular to think of these type level configurations as "lightweight dependent types." The traditional use for dependent types is to make programs safer... but maybe they can make our programs faster too!? Exploring both of these possibilities is the goal of `typeparams` library. 431 | 432 | There's still a couple of warts in the library: 433 | 434 | 1. The classes in the vector library were never meant to be abused in this way, and so there are a small number of edge cases where this framework does not work. For example, you cannot call `slice` on a `Static` length vector. This throws a run time error. Fixing this would require rewriting the vector library, which is a MAJOR undertaking. 435 | 436 | 2. The `mkParams` template haskell function currently only makes the necessary instances for `Static` and `RunTime` configurations. The infrastructure for `Automatic` configurations must be done manually. It is possible to automatically produce the required infrastructure for `Automatic` configurations as well, but I haven't figured out a way to do it without introducing overhead that's usually unnecessary. 437 | 438 | 3. For simplicity, this package only currently implements unboxed vectors in this framework. There is no reason, however, that boxed vectors and storable vectors could not be implemented as well. This would allow storable storable vectors using all the same techniques as above. 439 | 440 | **Please report any bugs/issues/feature requests!** 441 | -------------------------------------------------------------------------------- /examples/blog-applicative.lhs: -------------------------------------------------------------------------------- 1 | 2 | 3 | > {-# LANGUAGE TemplateHaskell #-} 4 | > {-# LANGUAGE ScopedTypeVariables #-} 5 | > {-# LANGUAGE KindSignatures #-} 6 | > {-# LANGUAGE TypeFamilies #-} 7 | > {-# LANGUAGE MultiParamTypeClasses #-} 8 | > {-# LANGUAGE UndecidableInstances #-} 9 | > {-# LANGUAGE FlexibleInstances #-} 10 | > {-# LANGUAGE RankNTypes #-} 11 | > {-# LANGUAGE OverloadedStrings #-} 12 | 13 | We've got a few more imports today to handle all our parsing needs: 14 | 15 | > import Control.Category 16 | > import Prelude hiding ((.), id, Functor(..), Applicative(..)) 17 | > import qualified Prelude as P 18 | > import Data.Params 19 | > import Data.Params.Functor 20 | 21 | > import qualified Control.Applicative as Ap 22 | > import qualified Data.Attoparsec.Text as A 23 | > import Data.Attoparsec.Text (parse,Parser,Result) 24 | > import Data.Monoid 25 | > import Data.Text (Text,pack) 26 | 27 | ------------------- 28 | -- Functor bonus 29 | 30 | > infixl 4 <$> 31 | > (<$>) :: 32 | > ( Functor lens tb 33 | > , b ~ GetParam lens tb 34 | > , ta ~ SetParam lens a tb 35 | > ) => (a -> b) 36 | > -> ta 37 | > -> TypeLens Base lens 38 | > -> tb 39 | > (f <$> t) lens = fmap lens f t 40 | 41 | ghci> length <$> (Left $ Right "test") $ _a._b 42 | Left (Right 4) 43 | 44 | We will find it useful to introduce a symbol just for specifying the type lens. Since a lens specifies the location "at" which we are operating, we call our new operator @@. It is defined as: 45 | 46 | > infixr 0 @@ 47 | > (@@) :: (TypeLens p q -> b) -> TypeLens p q -> b 48 | > (@@) = id 49 | 50 | Use it like: 51 | 52 | ghci> length <$> (Left $ Right "test") @@ _a._b 53 | Left (Right 4) 54 | 55 | Of course, one of the lens laws is that we must provide both prefix and infix versions of every combinator. Therefore we also introduce the function: 56 | 57 | > at :: TypeLens q p -> (TypeLens q p -> t) -> t 58 | > at lens f = f lens 59 | 60 | ghci> at (_a._b) $ length <$> (Left $ Right "test") 61 | Left (Right 4) 62 | 63 | ------------------- 64 | -- Applicative 65 | 66 | At last we're ready to see our new Applicative class: 67 | 68 | > class Functor lens tb => Applicative lens tb where 69 | > 70 | > pure :: GetParam lens tb -> TypeLens Base lens -> tb 71 | > 72 | > ap :: 73 | > ( tf ~ SetParam lens (a -> b) tb 74 | > , ta ~ SetParam lens a tb 75 | > , a ~ GetParam lens ta 76 | > , b ~ GetParam lens tb 77 | > ) 78 | > => TypeLens Base lens 79 | > -> tf 80 | > -> ta 81 | > -> tb 82 | 83 | The functions pure and ap have the exact same meaning and laws as their counterparts in the standard libraries. The only difference is the addition of the TypeLens parameter and corresponding constraints. 84 | 85 | The Left and Right Applicative instances for the Either class are defined as: 86 | 87 | > instance Applicative p a => Applicative (Param_a p) (Either a b) where 88 | > pure a lens = Left $ pure a (zoom lens) 89 | > ap lens (Right a) _ = Right a 90 | > ap lens (Left f) (Right a) = Right a 91 | > ap lens (Left f) (Left b) = Left $ ap (zoom lens) f b 92 | 93 | > instance Applicative p b => Applicative (Param_b p) (Either a b) where 94 | > pure b lens = Right $ pure b (zoom lens) 95 | > ap lens (Left a) _ = Left a 96 | > ap lens (Right f) (Left a) = Left a 97 | > ap lens (Right f) (Right b) = Right $ ap (zoom lens) f b 98 | 99 | And just like with Functors, we have to define the base case for our recusive definitions: 100 | 101 | > instance Applicative Base t where 102 | > pure a _ = a 103 | > ap _ f = f 104 | 105 | Now, to get the Applicative notation we all know and love, we redefine the <*> operator. It is just a thin wrapper around the ap function in the class that rearranges the parameters to be more convenient: 106 | 107 | > infixl 4 <*> 108 | > (<*>) :: 109 | > ( Applicative lens tb 110 | > , tf ~ SetParam lens (a -> b) tb 111 | > , ta ~ SetParam lens a tb 112 | > , a ~ GetParam lens ta 113 | > , b ~ GetParam lens tb 114 | > ) => (TypeLens Base lens -> tf) 115 | > -> ta 116 | > -> (TypeLens Base lens -> tb) 117 | > (<*>) tf ta lens = ap lens (tf lens) ta 118 | 119 | Whew! 120 | 121 | Now we're ready to test it out. 122 | 123 | We'll start with the doubly nested Either. For nested Eithers, the lens we use specifies what the success constructors are. Any other constructors will act as errors. 124 | 125 | Here's an example without an error: 126 | 127 | > fact1 :: Either (Either a String) b 128 | > fact1 = (++) <$> Left (Right "haskell") <*> Left (Right " rocks!") @@ _a._b 129 | 130 | ghci> fact1 131 | Left (Right "haskell rocks!") 132 | 133 | Here we have one possible way of signaling an error: 134 | 135 | > fact2 :: Either (Either a String) String 136 | > fact2 = (++) <$> Left (Right "python") <*> Right "error" @@ _a._b 137 | 138 | ghci> fact2 139 | Right "error" 140 | 141 | And here we have the other way: 142 | 143 | > fact3 :: Either (Either String String) b 144 | > fact3 = (++) <$> Left (Right "c++") <*> Left (Left "error") @@ _a._b 145 | 146 | ghci> fact3 147 | Left (Left "error") 148 | 149 | Of course, Applicatives are much more useful when our functions have many arguments. Let's create a function that concatenates four strings together into a phrase: 150 | 151 | > cat4 :: String -> String -> String -> String -> String 152 | > cat4 a b c d = a ++ " " ++ b ++ " "++ c ++ " " ++ d 153 | 154 | And create a phrase with no errors: 155 | 156 | > phrase1 :: Either (Either a String) b 157 | > phrase1 = cat4 158 | > <$> Left (Right "haskell") 159 | > <*> Left (Right "is") 160 | > <*> Left (Right "super") 161 | > <*> Left (Right "awesome") 162 | > @@ _a._b 163 | 164 | ghci> phrase1 165 | Left (Right "haskell is super awesome") 166 | 167 | And a phrase with two errors: 168 | 169 | > phrase2 :: Either (Either String String) String 170 | > phrase2 = cat4 171 | > <$> Left (Right "python") 172 | > <*> Right "error" 173 | > <*> Left (Right "is") 174 | > <*> Left (Left "error") 175 | > @@ _a._b 176 | 177 | ghci> phrase2 178 | Right "error" 179 | 180 | Notice that in phrase2 we had two different causes of errors. The error with the fewest number of terms will always win. 181 | 182 | > phrase3 :: Either (Either String String) String 183 | > phrase3 = cat4 184 | > <$> Left (Right "python") 185 | > <*> Left (Left "error") 186 | > <*> Left (Right "is") 187 | > <*> Right "error" 188 | > @@ _a._b 189 | 190 | ghci> phrase3 191 | Right "error" 192 | 193 | ------------------- 194 | -- making it pure 195 | 196 | This is cool, but it's not yet very generic. Everytime we want a success, we have to manually specify the constructors we want to use. We can avoid that using the pure function. It's type signature is: 197 | 198 | pure :: Applicative lens tb 199 | => GetParam lens tb -> TypeLens Base lens -> tb 200 | 201 | The important thing to notice is that the second to last parameter takes a TypeLens. We can substitute it into our phrase1 variable like: 202 | 203 | > phrase1' :: Either (Either a String) b 204 | > phrase1' = cat4 205 | > <$> (pure "haskell" @@ _a._b) 206 | > <*> (pure "is" @@ _a._b) 207 | > <*> (pure "super" @@ _a._b) 208 | > <*> (pure "awesome" @@ _a._b) 209 | > @@ _a._b 210 | 211 | But this is nasty! We have to specify the same TypeLens everywhere we want to use the pure function. 212 | 213 | Thankfully, we don't have to do this. The whole point of lenses is to create crazy new combinators that reduce boilerplate! So let's do that! The "ap minus" combinator will automatically apply the lens for us: 214 | 215 | > infixl 4 <*>- 216 | > (tf <*>- ta) lens = (tf <*> ta lens) lens 217 | 218 | The minus sign signifies that the right side is "minus a lens" and so we should give it one automtically. Using this combinator, we can rewrite our phrase to look like: 219 | 220 | > phrase1'' :: Either (Either a String) b 221 | > phrase1'' = cat4 222 | > <$> (pure "haskell" @@ _a._b) 223 | > <*>- pure "is" 224 | > <*>- pure "super" 225 | > <*>- pure "awesome" 226 | > @@ _a._b 227 | 228 | In order to get rid of the first lens application, we'll need to perform the same trick to <$>: 229 | 230 | > infixl 4 <$>- 231 | > (f <$>- t) lens = (f <$> t lens) lens 232 | 233 | And we get the beautiful: 234 | 235 | > phrase1''' :: Either (Either a String) b 236 | > phrase1''' = cat4 237 | > <$>- pure "haskell" 238 | > <*>- pure "is" 239 | > <*>- pure "super" 240 | > <*>- pure "awesome" 241 | > @@ _a._b 242 | 243 | ------------------- 244 | -- combinatorics with combinators 245 | 246 | > (<*) :: 247 | > ( Applicative lens ( SetParam lens ( b -> GetParam lens tf ) tf ) 248 | > , Applicative lens tf 249 | > , Applicative lens tb 250 | > , tf ~ SetParam lens (a -> b) tb 251 | > , ta ~ SetParam lens a tb 252 | > , a ~ GetParam lens ta 253 | > , b ~ GetParam lens tb 254 | > , b ~ GetParam lens (SetParam lens b tf) 255 | > , ( a -> b -> a ) ~ GetParam lens ( SetParam lens ( b -> GetParam lens tf ) tf ) 256 | > ) => SetParam lens b tf 257 | > -> ta 258 | > -> TypeLens Base lens 259 | > -> tb 260 | 261 | There's two more Applicative combinators needed for parsing: *> and <* . They use the same definition in the standard libraries, but with a third lens parameter: 262 | 263 | > infixl 4 <* 264 | > (u <* v) lens = pure const <*> u <*> v @@ lens 265 | 266 | > infixl 4 *> 267 | > (u *> v) lens = pure (const id) <*> u <*> v @@ lens 268 | 269 | Now we need to create all of the "minus" operators. Remember that the minus sign points to the variable that will have the lens automatically applied for us: 270 | 271 | > infixl 4 <*- 272 | > infixl 4 -<*- 273 | > infixl 4 -<* 274 | > (u <*- v) lens = ( u <* v lens ) lens 275 | > (u -<*- v) lens = ( u lens <* v lens ) lens 276 | > (u -<* v) lens = ( u lens <* v ) lens 277 | 278 | > infixl 4 *>- 279 | > infixl 4 -*>- 280 | > infixl 4 -*> 281 | > (u *>- v) lens = ( u *> v lens ) lens 282 | > (u -*>- v) lens = ( u lens *> v lens ) lens 283 | > (u -*> v) lens = ( u lens *> v ) lens 284 | 285 | Just remember the pattern, and you'll be fine! 286 | 287 | ------------------- 288 | -- Parse time 289 | 290 | Now for the really juicy bits. We've already imported the attoparsec library. We'll use the built-in "blind" Functor and Applicative instances to define our lensified ones as: 291 | 292 | > mkParams ''Parser 293 | 294 | > instance Functor p a => Functor (Param_a p) (Parser a) where 295 | > fmap' lens f parser = P.fmap (fmap' (zoom lens) f) parser 296 | 297 | > instance Applicative (Param_a Base) (Parser a) where 298 | > pure a lens = Ap.pure $ pure a (zoom lens) 299 | > ap lens tf ta = tf Ap.<*> ta 300 | 301 | And now we're ready to start parsing. We'll start simple. The attoparsec library provides a function called string that mathes a specified string. We'll use it to create a Parser that matches the phrase "haskell rocks": 302 | 303 | > chain1 :: TypeLens Base (Param_a Base) -> Parser Text 304 | > chain1 = A.string "haskell" *> A.string " rocks" 305 | 306 | ghci> parse (chain1 @@ _a) "haskell rocks" 307 | Done "" " rocks" 308 | 309 | In the above example, we chose to *not* specify the lens in the chain1 variable. This means that if we want to chain it with another parser, we should use the minus then operator like: 310 | 311 | > chain2 :: TypeLens Base (Param_a Base) -> Parser Text 312 | > chain2 = chain1 -*> A.string "!" 313 | 314 | ghci> parse (chain2 @@ _a) "haskell rocks!" 315 | Done "" "!" 316 | 317 | If we choose to compose on the right, then we'll need to move the minus sign to the right: 318 | 319 | > chain3 :: TypeLens Base (Param_a Base) -> Parser Text 320 | > chain3 = A.string "¡" *>- chain2 321 | 322 | ghci> parse (chain3 @@ _a) "¡haskell rocks!" 323 | Done "" "!" 324 | 325 | We have to use minus operators whenever we chain more than two parsers together. In the example below, the first *> takes three parameters (two parsers and a lens). It gets the lens from the minus of the first -*> operator. That operator also needs a lens, which it gets from the next -*>, and so on. 326 | 327 | > chain4 :: TypeLens Base (Param_a Base) -> Parser Text 328 | > chain4 = A.string "do" *> A.string " you" -*> A.string " get" -*> A.string " it" -*> A.string " yet?" 329 | 330 | ghci> parse (chain4 @@ _a) "do you get it yet?" 331 | Done "" " yet?" 332 | 333 | If we need to apply a lens to both sides, then we use the -*>- operator: 334 | 335 | > chain5 :: TypeLens Base (Param_a Base) -> Parser Text 336 | > chain5 = chain3 -*> A.string " ... " -*>- chain4 337 | 338 | ghci> parse (chain5 @@ _a) "¡haskell rocks! ... do you get it yet?" 339 | Done "" " yet?" 340 | 341 | ------------------- 342 | -- stacking parsers 343 | 344 | Everything in the last section we could have done without type lenses. But now we're going to lift the Parser into an arbitrary data type and work with it. 345 | 346 | As a concrete example, we'll put our Parser inside a Maybe. The Maybe Applicative instance is: 347 | 348 | > instance Applicative p a => Applicative (Param_a p) (Maybe a) where 349 | > pure a lens = Just $ pure a (zoom lens) 350 | > ap lens Nothing _ = Nothing 351 | > ap lens (Just f) Nothing = Nothing 352 | > ap lens (Just f) (Just b) = Just $ ap (zoom lens) f b 353 | 354 | And for convenience we'll use the following parseMaybe function. It has the same effect as the parse function provided by attoparsec, but does everything from within a Maybe. 355 | 356 | > parseMaybe :: Maybe (Parser a) -> Text -> Maybe (Result a) 357 | > parseMaybe parser str = flip parse str <$> parser @@ _a 358 | 359 | Next, we lensify our parser combinators. This string lifts the string function provided by the attoparsec library into an arbitrary parameter specified by our type lens: 360 | 361 | -- > string :: 362 | -- > ( Applicative (Zoom p) tb 363 | -- > , GetParam (Zoom p) tb ~ Parser Text 364 | -- > ) => Text -> TypeLens Base p -> tb 365 | 366 | > string c lens = pure (A.string c) (zoom lens) 367 | 368 | At last we can get back to parsing. 369 | 370 | Let's just repeat the same 5 parse chains from above, but now within the Maybe context. Notice two things; 371 | 372 | 1) The A.string function provided by the attoparsec library did not take a type parameter, but our new string function does. This means there's a lot more minus combinators! 373 | 374 | 2) Instead of specifying our lens to focus on the _a parameter, we must focus on the _a._a parameter to hit the parser. 375 | 376 | > chain1' :: TypeLens Base (Param_a (Param_a Base)) -> Maybe (Parser Text) 377 | > chain1' = string "haskell" -*>- string " rocks" 378 | 379 | ghci> parseMaybe (chain1' @@ _a._a) "haskell rocks" 380 | Just Done "" " rocks" 381 | 382 | > chain2' :: TypeLens Base (Param_a (Param_a Base)) -> Maybe (Parser Text) 383 | > chain2' = chain1' -*>- string "!" 384 | 385 | ghci> parse (chain2' @@ _a._a) "haskell rocks!" 386 | Done "" '!' 387 | 388 | > chain3' :: TypeLens Base (Param_a (Param_a Base)) -> Maybe (Parser Text) 389 | > chain3' = string "¡" -*>- chain2' 390 | 391 | ghci> parse (chain3' @@ _a._a) "¡haskell rocks!" 392 | Done "" '!' 393 | 394 | > chain4' :: TypeLens Base (Param_a (Param_a Base)) -> Maybe (Parser Text) 395 | > chain4' = string "do" -*>- string " you" -*>- string " get" -*>- string " it" -*>- string " yet?" 396 | 397 | ghci> parse (chain4' @@ _a._a) "do you get it yet?" 398 | Done "" " yet?" 399 | 400 | > chain5' :: TypeLens Base (Param_a (Param_a Base)) -> Maybe (Parser Text) 401 | > chain5' = chain3' -*>- string " ... " -*>- chain4' 402 | 403 | ghci> parse (chain5' @@ _a._a) "¡haskell rocks! ... do you get it yet?" 404 | Done "" " yet?" 405 | 406 | And now what happens if we add a Maybe into the chain? Nothing takes over and eats the whole Parser. It doesn't matter if the Parse was failing or succeeding, the answer is Nothing. 407 | 408 | > chain6 :: TypeLens Base (Param_a (Param_a Base)) -> Maybe (Parser Text) 409 | > chain6 = string "python" -*> Nothing 410 | 411 | ghci> parseMaybe (chain6 @@ _a._a) "python" 412 | Nothing 413 | 414 | ghci> parseMaybe (chain6 @@ _a._a) "haskell" 415 | Nothing 416 | 417 | ------------------- 418 | -- Alternative 419 | 420 | In order for our parser to really be useful, we need to make choices and branch. The Alternative class gives us this power. It is defined as: 421 | 422 | > class Applicative lens t => Alternative lens t where 423 | > empty :: TypeLens Base lens -> t 424 | > alt :: TypeLens Base lens -> t -> t -> t 425 | 426 | With a Parser instance taken directly from the standard alternative class: 427 | 428 | > instance Alternative (Param_a Base) (Parser a) where 429 | > empty _ = Ap.empty 430 | > alt _ = (Ap.<|>) 431 | 432 | Now, we must again redefine our operators to use lenses. Here is the <|> operator and its minus cousins: 433 | 434 | > infixl 3 <|> 435 | > (<|>) :: Alternative lens t => t -> t -> TypeLens Base lens -> t 436 | > (t1 <|> t2) lens = alt lens t1 t2 437 | 438 | > infixl 3 <|>- 439 | > infixl 3 -<|>- 440 | > infixl 3 -<|> 441 | > (t1 <|>- t2) lens = ( t1 <|> t2 lens ) lens 442 | > (t1 -<|>- t2) lens = ( t1 lens <|> t2 lens ) lens 443 | > (t1 -<|> t2) lens = ( t1 lens <|> t2 ) lens 444 | 445 | From this, we can derive the some and many combinators: 446 | 447 | > some v = (:) <$>- v <*>- many v 448 | > many v = some v -<|>- pure [] 449 | 450 | Which we can use like: 451 | 452 | > moto :: Parser [Text] 453 | > moto = string "give me " -*>- some (string "haskell") @@ _a 454 | 455 | ghci> parse moto "give me haskell!!!!!!!!!!!" 456 | Done "!!!!!!!!!!" ["haskell"] 457 | 458 | ---- 459 | 460 | -- > instance Alternative p a => Alternative (Param_a p) (Maybe a) where 461 | -- > empty _ = Nothing 462 | -- > alt lens (Just a) Nothing = trace "a" $ Nothing -- Just a 463 | -- > alt lens (Just a) (Just b) = trace "b" $ Just $ a <|> b @@ zoom lens 464 | -- > alt lens Nothing (Just a) = trace "c" $ Just a 465 | -- > alt lens Nothing Nothing = trace "d" $ Nothing 466 | -- 467 | -- > instance Alternative Base a => Alternative Base (Maybe a) where 468 | -- > empty _ = Nothing 469 | -- > alt _ (Just a) Nothing = trace "e" $ Nothing 470 | -- > alt _ (Just a) (Just b) = trace "f" $ Just $ a <|> b @@ _base 471 | -- > alt _ Nothing (Just a) = trace "g" $ Nothing 472 | -- > alt _ Nothing Nothing = trace "h" $ Nothing 473 | -- 474 | -- 475 | -- > ilove = string (pack "I love " ) @@ _a._a :: Maybe (Parser Text) 476 | -- > haskell = string (pack "haskell" ) @@ _a._a :: Maybe (Parser Text) 477 | -- > lenses = string (pack "lenses" ) @@ _a._a :: Maybe (Parser Text) 478 | -- > python = string (pack "python" ) @@ _a._a :: Maybe (Parser Text) 479 | -- 480 | -- > sentence :: Maybe (Parser Text) 481 | -- > sentence = haskell <|>- (python *> Nothing) -<|> lenses @@ _a._a -- -<|>- haskell -<|>- lenses @@ _a._a 482 | 483 | ------------------- 484 | -- parsers in parsers 485 | 486 | -- > instance Applicative p a => Applicative (Param_a p) (Parser a) where 487 | -- > pure a lens = Ap.pure $ pure a (zoom lens) 488 | -- > ap lens tf ta = ap (zoom lens) <$> tf <*> ta @@ _a 489 | 490 | ------------------- 491 | -- circuit parsing 492 | 493 | Now we're ready for some super coolness. We're going to design a parsing circuit that parses three unique Parse streams simultaneously! 494 | 495 | Here is our Circuit definition: 496 | 497 | > data Circuit x y z 498 | > = Circuit (Maybe x) (Maybe y) (Maybe z) 499 | > | CircuitFail 500 | > deriving (Show) 501 | > mkParams ''Circuit 502 | 503 | The x, y, and z type params will hold the Parsers. These Parsers are wrapped within a Maybe. A value of Nothing represents that that parser will not consume any input. A value if (Just parser) means that it will consume input. 504 | 505 | The Functor instances are rather interesting because of the Maybe wrapper. We must add a _a lens to the zoomed lens to make the types work out: 506 | 507 | > instance Functor p x => Functor (Param_x p) (Circuit x y z) where 508 | > fmap' lens f CircuitFail = CircuitFail 509 | > fmap' lens f (Circuit x y z) = Circuit (fmap' (_a . zoom lens) f x) y z 510 | 511 | > instance Functor p y => Functor (Param_y p) (Circuit x y z) where 512 | > fmap' lens f CircuitFail = CircuitFail 513 | > fmap' lens f (Circuit x y z) = Circuit x (fmap' (_a . zoom lens) f y) z 514 | 515 | > instance Functor p z => Functor (Param_z p) (Circuit x y z) where 516 | > fmap' lens f CircuitFail = CircuitFail 517 | > fmap' lens f (Circuit x y z) = Circuit x y (fmap' (_a . zoom lens) f z) 518 | 519 | The Applicative instances are where all the action is at. In each case, the pure function is fairly straightforward. It looks just like the other ones we've seen except that it applies the _a to the zoomed lens and gives default values of Nothing to the other parsers. 520 | 521 | The ap function is where the magic lies. 522 | 523 | > instance 524 | > ( Applicative p x 525 | > , Monoid y 526 | > , Monoid z 527 | > ) => Applicative (Param_x p) (Circuit x y z) 528 | > where 529 | > pure x lens = Circuit (pure x @@ (_a . zoom lens)) Nothing Nothing 530 | > ap lens CircuitFail _ = CircuitFail 531 | > ap lens _ CircuitFail = CircuitFail 532 | > ap lens (Circuit x1 y1 z1) (Circuit x2 y2 z2) = Circuit 533 | > (ap (_a . zoom lens) x1 x2) 534 | > (getFirst $ First y1 <> First y2) 535 | > (getFirst $ First z1 <> First z2) 536 | 537 | > instance (Monoid x, Applicative p y, Monoid z) => Applicative (Param_y p) (Circuit x y z) where 538 | > pure a lens = Circuit Nothing (pure a @@ _a . zoom lens) Nothing 539 | > ap lens CircuitFail _ = CircuitFail 540 | > ap lens _ CircuitFail = CircuitFail 541 | > ap lens (Circuit x1 y1 z1) (Circuit x2 y2 z2) = Circuit 542 | > (getFirst $ First x1 <> First x2) 543 | > (ap (_a . zoom lens) y1 y2) 544 | > (getFirst $ First z1 <> First z2) 545 | 546 | > instance (Monoid x, Monoid y, Applicative p z) => Applicative (Param_z p) (Circuit x y z) where 547 | > pure a lens = Circuit Nothing Nothing (pure a @@ _a . zoom lens) 548 | > ap lens CircuitFail _ = CircuitFail 549 | > ap lens _ CircuitFail = CircuitFail 550 | > ap lens (Circuit x1 y1 z1) (Circuit x2 y2 z2) = Circuit 551 | > (getFirst $ First x1 <> First x2) 552 | > (getFirst $ First y1 <> First y2) 553 | > (ap (_a . zoom lens) z1 z2) 554 | 555 | We write a nice wrapper so we can parse our circuits: 556 | 557 | > parseCircuit 558 | > :: Circuit (Parser x) (Parser y) (Parser z) 559 | > -> Text 560 | > -> Text 561 | > -> Text 562 | > -> Circuit (Result x) (Result y) (Result z) 563 | > parseCircuit CircuitFail _ _ _ = CircuitFail 564 | > parseCircuit (Circuit x y z) str1 str2 str3 = Circuit 565 | > ( parseMaybe x str1 ) 566 | > ( parseMaybe y str2 ) 567 | > ( parseMaybe z str3 ) 568 | 569 | And now here is a simple circuit for us: 570 | 571 | > circ1 :: Circuit (Parser Text) (Parser Text) (Parser Text) 572 | > circ1 = Circuit 573 | > (string (pack "haskell") @@ _a._a) 574 | > (string (pack "is" ) @@ _a._a) 575 | > (string (pack "fun" ) @@ _a._a) 576 | 577 | ghci> parseCircuit circ1 "haskell" "is" "fun" 578 | Circuit 579 | (Just Done "" "haskell") 580 | (Just Done "" "is") 581 | (Just Done "" "fun") 582 | 583 | ghci> parseCircuit (circ1 *> circ1 @@ _x._a) "haskell" "is" "fun" 584 | Circuit 585 | (Just Partial _) 586 | (Just Done "" "is") 587 | (Just Done "" "fun") 588 | 589 | ghci> parseCircuit (circ1 *> circ1 @@ _x._a) "haskellhaskell" "is" "fun" 590 | Circuit 591 | (Just Done "" "haskell") 592 | (Just Done "" "is") 593 | (Just Done "" "fun") 594 | 595 | > circ2 :: Circuit (Parser Text) (Parser y) (Parser z) 596 | > circ2 = Circuit 597 | > (string (pack " with lenses") @@ _a._a) 598 | > Nothing 599 | > Nothing 600 | 601 | ghci> parseCircuit (circ1 *> circ2 @@ _x._a) "haskell" "is" "fun" 602 | Circuit 603 | (Just Partial _) 604 | (Just Done "" "is") 605 | (Just Done "" "fun") 606 | 607 | ghci> parseCircuit (circ1 *> circ2 @@ _x._a) "haskell with lenses" "is" "fun" 608 | Circuit 609 | (Just Done "" " with lenses") 610 | (Just Done "" "is") 611 | (Just Done "" "fun") 612 | 613 | ghci> parseCircuit (circ1 *> circ2 @@ _x._a) "haskell without lenses" "is" "fun" 614 | Circuit 615 | (Just Fail " without lenses" [] "Failed reading: takeWith") 616 | (Just Done "" "is") 617 | (Just Done "" "fun") 618 | 619 | > circ3 :: Circuit (Parser Text) (Parser y) (Parser z) 620 | > circ3 = pure (string (pack " with lenses") @@ _a) @@ _x 621 | 622 | ghci> parseCircuit (circ1 *> circ3 @@ _x._a) "haskell with lenses" "is" "fun" 623 | Circuit 624 | (Just Done "" " with lenses") 625 | (Just Done "" "is") 626 | (Just Done "" "fun") 627 | 628 | 629 | Next time we'll discover why lensified monads are like burritos infused with 630 | fiber optic cables. 631 | 632 | -------------------------------------------------------------------------------- /examples/blog-constrainedmonad.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE TemplateHaskell #-} 2 | > {-# LANGUAGE ScopedTypeVariables #-} 3 | > {-# LANGUAGE KindSignatures #-} 4 | > {-# LANGUAGE TypeFamilies #-} 5 | > {-# LANGUAGE MultiParamTypeClasses #-} 6 | > {-# LANGUAGE UndecidableInstances #-} 7 | > {-# LANGUAGE FlexibleInstances #-} 8 | > {-# LANGUAGE RankNTypes #-} 9 | 10 | > {-# LANGUAGE RebindableSyntax #-} 11 | 12 | > import Control.Category 13 | > import Prelude hiding ((.), id, Functor(..), Applicative(..), Monad(..) ) 14 | > import qualified Data.Map as Map 15 | > import Data.Monoid 16 | 17 | > import Data.Params 18 | > import Data.Params.Applicative 19 | > import Data.Params.Functor 20 | > import Data.Params.Monad 21 | 22 | > import Debug.Trace 23 | 24 | ------------------- 25 | -- define the Map 26 | 27 | > mkParams ''Map.Map 28 | > instance (Ord k, Functor p k) => Functor (Param_k p) (Map.Map k a) where 29 | > fmap' lens f m = Map.mapKeys (fmap' (zoom lens) f) m 30 | 31 | > instance (Ord k, Applicative p k, Monoid a) => Applicative (Param_k p) (Map.Map k a) where 32 | > pure a lens = Map.singleton (pure a $ zoom lens) mempty 33 | > 34 | > -- ap function does not make sense because there is no Ord instance for (a -> b) 35 | > -- can someone explain to me categorically why this happens? 36 | 37 | > instance (Ord k, Monoid a) => Monad (Param_k Base) (Map.Map k a) where 38 | > join lens m 39 | > = foldr (Map.unionWith (<>)) mempty 40 | > $ map (\(k,v) -> Map.map (<>v) k) 41 | > $ Map.toList m 42 | 43 | > instance Functor p a => Functor (Param_a p) (Map.Map k a) where 44 | > fmap' lens f m = Map.map (fmap' (zoom lens) f) $ m 45 | 46 | > instance (Applicative p a, Monoid k) => Applicative (Param_a p) (Map.Map k a) where 47 | > pure a lens = Map.singleton mempty $ pure a $ zoom lens 48 | 49 | -- > instance Monoid k => Monad (Param_a Base) (Map.Map k a) where 50 | -- > join lens m = _ $ Map.toList m 51 | 52 | -- > q _ m = Map.fromList m 53 | 54 | ------------------- 55 | -- example 56 | 57 | > languages :: Map.Map String String 58 | > languages = Map.fromList 59 | > [ ( "agda" , "crazier than this blog?" ) 60 | > , ( "bash" , "quite handy" ) 61 | > , ( "c++" , "better than c?" ) 62 | > , ( "c" , "better than c++?" ) 63 | > , ( "haskell" , "awesome" ) 64 | > , ( "python" , "better than c++" ) 65 | > ] 66 | 67 | > key2value :: String -> Map.Map String String 68 | > key2value str = Map.singleton str str 69 | 70 | > stringToValue :: Ord k => String -> k -> Map.Map k String 71 | > stringToValue str k = Map.singleton k str 72 | 73 | > sentences :: Map.Map String String 74 | > sentences = at _k $ do 75 | > k <- const languages 76 | > const $ stringToValue " is " k 77 | > const $ key2value k 78 | > return $ k 79 | 80 | ghci> sentences 81 | fromList [("agda","agda is crazier than this blog?") 82 | ,("bash","bash is quite handy") 83 | ,("c++","c++ is better than c?") 84 | ,("c","c is better than c++?") 85 | ,("haskell","hakell is awesome") 86 | ,("python","python is better than c++") 87 | ] 88 | 89 | -------------------------------------------------------------------------------- /examples/blog-functors.lhs: -------------------------------------------------------------------------------- 1 | 2 | The typeparams package provides type lenses. 3 | Let's see what happens when we combine these type lenses with nested Functors. 4 | (If you haven't read through the tutorial on the linked github page, you should do that first!) 5 | 6 | First, enable GHC magic: 7 | 8 | > {-# LANGUAGE TemplateHaskell #-} 9 | > {-# LANGUAGE ScopedTypeVariables #-} 10 | > {-# LANGUAGE KindSignatures #-} 11 | > {-# LANGUAGE TypeFamilies #-} 12 | > {-# LANGUAGE MultiParamTypeClasses #-} 13 | > {-# LANGUAGE UndecidableInstances #-} 14 | > {-# LANGUAGE FlexibleInstances #-} 15 | > {-# LANGUAGE RankNTypes #-} 16 | > {-# LANGUAGE OverlappingInstances #-} 17 | 18 | and import our libraries: 19 | 20 | > import Control.Category 21 | > import Prelude hiding ((.),id,Functor(..)) 22 | > import Data.Params 23 | 24 | We'll use the Either type as our main example. 25 | It's defined as: 26 | 27 | data Either a b = Left a | Right b 28 | 29 | The Functor instance is pretty straightforward: 30 | 31 | class Functor f where 32 | fmap :: (a -> b) -> f a -> f b 33 | 34 | instance Functor (Either a) where 35 | fmap f (Left a) = Left a 36 | fmap f (Right b) = Right $ f b 37 | 38 | But this instance has a key limitation: We can map a function only over the the last type. 39 | 40 | Bifunctors are the current solution to this problem. 41 | A recent, popular proposal suggested adding them to base (http://web.archiveorange.com/archive/v/KAst18B9pJtb8MpLOJD1). 42 | But this is an ad hoc solution whose application does not extend far beyond the Either type. 43 | 44 | Type lenses will (kinda sort of) provide a cleaner solution. 45 | That is, they fix the problem about as well as regular old lenses fix the problems of record selectors. 46 | As a bonus, we'll get a convenient mechanism for mapping over nested Functors. 47 | 48 | ------------------- 49 | -- Defining the Functor 50 | 51 | Here is the alternative definition of the Functor class using type lenses: 52 | 53 | > class Functor lens t where 54 | > fmap' :: a ~ GetParam lens t 55 | > => TypeLens p lens 56 | > -> (a -> b) 57 | > -> t 58 | > -> SetParam lens b t 59 | 60 | It's okay if you don't understand the type signature at first glace. 61 | (That's how know your using lenses, afterall!) 62 | Let's step through it using the Either example. 63 | 64 | The first argument is the type lens. 65 | This indicates which parameter we will be mapping over the type t. 66 | In the Either data type, we could use the variable _a to map over the Left component or _b to map over the Right. 67 | 68 | Next, we encounter two type families, GetParam and SetParam. 69 | These act as getters and setters at the type level. 70 | In the above example, GetParam is used to extract arbitrary type params from a type. 71 | It is defined as: 72 | 73 | type family GetParam (p::k1) (t:: *) :: k3 74 | type instance GetParam Param_a (Either a b) = a 75 | type instance GetParam Param_b (Either a b) = b 76 | 77 | The SetParam type similarly sets the type of arbitrary params in a type. 78 | It is defined as: 79 | 80 | type family SetParam (p::k1) (a::k2) (t:: *) :: * 81 | type instance SetParam Param_a a' (Either a b) = Either a' b 82 | type instance SetParam Param_b b' (Either a b) = Either a b' 83 | 84 | These instances can be automatically provided for any type by calling the mkParams template haskell function like so: 85 | 86 | > mkParams ''Either 87 | 88 | Quick aside: With injective type families and a little sugar, we could make this definition of Functor a tad cleaner. https://ghc.haskell.org/trac/ghc/ticket/6018#comment:25 89 | 90 | ------------------- 91 | -- instances 92 | 93 | We can replicate the traditional Functor instance with the code: 94 | 95 | > instance Functor (Param_b Base) (Either a b) where 96 | > fmap' lens f (Left a) = Left a 97 | > fmap' lens f (Right b) = Right $ f b 98 | 99 | and create a "Left" Functor instance as: 100 | 101 | > instance Functor (Param_a Base) (Either a b) where 102 | > fmap' lens f (Left a) = Left $ f a 103 | > fmap' lens f (Right b) = Right b 104 | 105 | Together, these instances let us run the commands: 106 | 107 | ghci> fmap _b length $ Left "Roses are red," 108 | Left "Roses are red," 109 | 110 | ghci> fmap _b length $ Rightt "Violets are blue," 111 | Right 17 112 | 113 | ghci> fmap _a length $ Left "Haskell is fun," 114 | Left 15 115 | 116 | ghci> fmap _a length $ Right "Type lenses are cool." 117 | Right "Type lenses are cool." 118 | 119 | ------------------- 120 | -- nest those Functors 121 | 122 | But wait! There's more! 123 | 124 | With the above definitions, we can't combine our type lenses at all. 125 | Enter the funnily named and awkwardly typed zoom combinator: 126 | 127 | zoom :: TypeLens a p -> TypeLens a (Zoom p) 128 | 129 | This combinator lets us zoom into a composed type lens, removing the outer most layer. 130 | For example, given the composed type lens: 131 | 132 | ghci> :t _a._b._a._b 133 | _a._b._a._b :: TypeLens a (Param_a (Param_b (Param_a (Param_b a)))) 134 | 135 | Then zooming in removes the first _a: 136 | 137 | ghci> :t zoom (_a._b._a._b) 138 | zoom (_a._b._a._b) :: TypeLens a (Param_b (Param_a (Param_b a))) 139 | 140 | We will use this combinator to redefine our Functor instances. 141 | The new instances will recursively map over every Functor in our input lens: 142 | 143 | > instance Functor p b => Functor (Param_b p) (Either a b) where 144 | > fmap' lens f (Left a) = Left a 145 | > fmap' lens f (Right b) = Right $ fmap' (zoom lens) f b 146 | 147 | > instance Functor p a => Functor (Param_a p) (Either a b) where 148 | > fmap' lens f (Left a) = Left $ fmap' (zoom lens) f a 149 | > fmap' lens f (Right b) = Right b 150 | 151 | The type Base provides the base case of the recursion: 152 | 153 | > instance Functor Base t where 154 | > fmap' _ f a = f a 155 | 156 | Now, in order to call fmap', we must compose our lens with the type lens: 157 | 158 | _base :: TypeLens Base Base 159 | 160 | For example: 161 | 162 | ghci> :t _a._b._a._b._base 163 | deeplens :: TypeLens Base (Param_a (Param_b (Param_a (Param_b Base)))) 164 | 165 | And we call fmap' like: 166 | 167 | ghci> fmap' (_a._b._a._b._base) length $ Left $ Right $ Left $ Right "still simpler than the lens package ;)" 168 | Left (Right (Left (Right 42))) 169 | 170 | ghci> fmap' (_a._b._a._b._base) length $ Left $ Right $ Left $ Left "... for now ..." 171 | Left (Right (Left (Left "... for now ..."))) 172 | 173 | Composing all of our lenses with _base is tedious. 174 | So let's write a function that automates that task: 175 | 176 | > fmap :: 177 | > ( Functor lens t 178 | > ) => TypeLens Base lens 179 | > -> (GetParam lens t -> c) 180 | > -> t 181 | > -> SetParam lens c t 182 | > fmap lens = fmap' (lens._base) 183 | 184 | And we call fmap as: 185 | 186 | ghci> fmap (_a._b._a._b) length $ Left $ Right $ Left $ Left "mwahhahahaha" 187 | Left (Right (Left (Left "mwahhahahaha"))) 188 | 189 | ------------------- 190 | -- there's everywhere! 191 | 192 | We can easily define more of these new Functor instances. 193 | In fact, the procedure is exactly as mechanical for type lens based Functors as it is for the traditional Functors. 194 | All you have to do is replace every function application with a recursive Functor call: 195 | 196 | f x --> fmap' (zoom lens) f x 197 | 198 | Here are some examples using the list and Maybe functors: 199 | 200 | > mkParams ''[] 201 | > instance Functor p a => Functor (Param_a p) [a] where 202 | > fmap' lens f [] = [] 203 | > fmap' lens f (a:as) = fmap' (zoom lens) f a : fmap' lens f as 204 | 205 | > mkParams ''Maybe 206 | > instance Functor p a => Functor (Param_a p) (Maybe a) where 207 | > fmap' lens f Nothing = Nothing 208 | > fmap' lens f (Just a) = Just $ fmap' (zoom lens) f a 209 | 210 | Let's create a variable that uses all of our functors: 211 | 212 | > monster = 213 | > [ Nothing 214 | > , Just (Left "Hello!") 215 | > , Just (Right 42) 216 | > , Just (Left "World!") 217 | > ] 218 | 219 | And go to town: 220 | 221 | ghci> fmap (_a._a._a._a) succ monster 222 | [Nothing,Just (Left "Ifmmp\""),Just (Right 42),Just (Left "Xpsme\"")] 223 | 224 | ghci> fmap (_a._a._a) length monster 225 | [Nothing,Just (Left 6),Just (Right 42),Just (Left 6)] 226 | 227 | ghci> fmap (_a._a) (const 3.4) monster 228 | [Nothing,Just 3.4,Just 3.4,Just 3.4] 229 | 230 | ghci> fmap _a show monster 231 | ["Nothing","Just (Left \"Hello!\")","Just (Right 42)","Just (Left \"World!\")"] 232 | 233 | ------------------- 234 | -- Tune in next time... 235 | 236 | In our next installment, we'll tackle Applicative parsing with type lenses. 237 | Thought the lens package had too many operators??? 238 | You 'aint seen 'nothin yet. 239 | 240 | 241 | 242 | 243 | 244 | 245 | ------------------- 246 | -- Attempt 1 247 | 248 | 249 | > class Functor1 lens t where 250 | > fmap1 :: TypeLens p (lens p) -> (GetParam lens t -> b) -> t -> SetParam lens b t 251 | 252 | > instance Functor1 Param_b (Either a b) where 253 | > fmap1 lens f (Left a) = Left a 254 | > fmap1 lens f (Right b) = Right $ f b 255 | 256 | > instance Functor1 Param_a (Either a b) where 257 | > fmap1 lens f (Left a) = Left $ f a 258 | > fmap1 lens f (Right b) = Right b 259 | 260 | > testLeft = Left "hello world!" 261 | > strRight = Right "hello world!" 262 | 263 | ghci> fmap1 _b length strRight 264 | Right1 12 265 | 266 | ghci> fmap1 _a length strRight 267 | Right1 "hello world!" 268 | -------------------------------------------------------------------------------- /examples/blog-monad.lhs: -------------------------------------------------------------------------------- 1 | 2 | It's round 3 of typeparams versus GHC. We'll be extending our Functor and Applicative classes to define a new Monad class. It's all pretty simple if you just remember: lensified monads are like burritos where fiber optic cables tell you where to bite next. There also just monoids in the category of lens-enhanced endofunctors. Piece of cake. 3 | 4 | ------------------- 5 | -- our naughty extensions 6 | 7 | We'll be using all the same extensions as before: 8 | 9 | > {-# LANGUAGE TemplateHaskell #-} 10 | > {-# LANGUAGE ScopedTypeVariables #-} 11 | > {-# LANGUAGE KindSignatures #-} 12 | > {-# LANGUAGE TypeFamilies #-} 13 | > {-# LANGUAGE MultiParamTypeClasses #-} 14 | > {-# LANGUAGE UndecidableInstances #-} 15 | > {-# LANGUAGE FlexibleInstances #-} 16 | > {-# LANGUAGE RankNTypes #-} 17 | 18 | But we'll be adding some pretty nasty ones today: 19 | 20 | > {-# LANGUAGE OverlappingInstances #-} 21 | > {-# LANGUAGE RebindableSyntax #-} 22 | 23 | Oh well. We're so far down the rabbit hole this doesn't really bother me. What's a little overlapping instances compared to the rest of this nonsense? 24 | 25 | We'll be needing all of our previous work on Functors and Applicatives. It has been uploaded into hackage and is sitting in the appropriate modules: 26 | 27 | > import Control.Category 28 | > import Prelude hiding ( (.), id, Functor(..), Applicative(..), Monad(..) ) 29 | > import qualified Prelude as P 30 | > import GHC.Exts 31 | > 32 | > import Data.Params 33 | > import Data.Params.Applicative 34 | > import Data.Params.Functor 35 | 36 | And we're off! 37 | 38 | ------------------- 39 | -- joins and cojoins 40 | 41 | We will define our monads in terms of their join function. In the standard libraries, join has the type: 42 | 43 | join :: m (m a) -> m a 44 | 45 | The input has the same type as the output, except that the Monad m is repeated twice. There are two differences in the lensified join function: First, the monad we're working with might be nested arbitrarily deeply in other data types. Second, the argument it is monadic in might not be the last one. Here is an example of what the join type signature would look like for the Left Either monad sitting within a Maybe Monad: 46 | 47 | join :: TypeLens Base (Param_a (Param_a Base)) 48 | -> Maybe (Either (Either String Int) Int) 49 | -> Maybe (Either String Int) 50 | 51 | Since we're all wannabe category theorists here, we'll create a CoJoin type family that transforms the output of the join function by duplicating the type at location specified by the lens: 52 | 53 | > type family CoJoin (lens :: * -> Constraint) t 54 | > type instance CoJoin lens t 55 | > = SetParam' 56 | > lens 57 | > ( SetParam' 58 | > ( Objective lens ) 59 | > ( GetParam lens t ) 60 | > ( GetParam (RemoveObjective lens) t ) 61 | > ) 62 | > t 63 | 64 | (Remember that the Objective family returns the innermost type lens from our input, and the RemoveObjective familyreturns the lens that results when the innermost lens is taken away.) 65 | 66 | CoJoin only has one instance, so we could have just used a type synonym. That would make debugging harder, however. The advantage of a type family is that when we ask GHCi what the type is, it will perform the substitutions for us. For example: 67 | 68 | ghci> :t undefined :: CoJoin (Param_a Base) (Maybe (Either String Int)) 69 | :: Maybe (Maybe (Either String Int)) 70 | 71 | ghci> :t undefined :: CoJoin (Param_a (Param_a Base)) (Maybe (Either String Int)) 72 | :: Maybe (Either (Either String Int) Int) 73 | 74 | ------------------- 75 | -- monad 76 | 77 | Now we're ready to see our new Monad class: 78 | 79 | > class Applicative lens tfb => Monad lens tfb where 80 | > join :: 81 | > ( tffb ~ CoJoin lens tfb 82 | > ) => TypeLens Base lens 83 | > -> tffb -> tfb 84 | 85 | The Left and Right Either instances are: 86 | 87 | > instance Monad (Param_a Base) (Either a b) where 88 | > join lens (Left (Left a)) = Left a 89 | > join lens (Left (Right b)) = Right b 90 | > join lens (Right b) = Right b 91 | 92 | > instance Monad (Param_b Base) (Either a b) where 93 | > join lens (Right (Right b)) = Right b 94 | > join lens (Right (Left a)) = Left a 95 | > join lens (Left a) = Left a 96 | 97 | And here are some examples of join in action: 98 | 99 | ghci> join _b (Right $ Right "monads") :: Either String String 100 | Right "monads" 101 | 102 | ghci> join _b (Right $ Left "are") :: Either String String 103 | Left "are" 104 | 105 | ghci> join _a (Left $ Left "so") :: Either String String 106 | Left "so" 107 | 108 | ghci> join _a (Right "awesome") :: Either String String 109 | Right "awesome" 110 | 111 | The instances above don't consider the case when our lenses point inside of the Either type. We'll need to define two new recirsive instances to handle this case. These instances are the reason we needed the OverlappingInstances language extension: 112 | 113 | > instance 114 | > ( Monad p a 115 | > , Either (CoJoin p a) b ~ CoJoin (Param_a p) (Either a b) -- follows from the lens laws 116 | > ) => Monad (Param_a p) (Either a b) 117 | > where 118 | > 119 | > join lens (Left a) = Left $ join (zoom lens) a 120 | > join lens (Right b) = Right b 121 | 122 | > instance 123 | > ( Monad p b 124 | > , Either a (CoJoin p b) ~ CoJoin (Param_b p) (Either a b) -- follows from the lens laws 125 | > ) => Monad (Param_b p) (Either a b) 126 | > where 127 | > 128 | > join lens (Left a) = Left a 129 | > join lens (Right b) = Right $ join (zoom lens) b 130 | 131 | The equality constraints in the instances above are implied by the lens laws. As we discussed yesterday, with the type rules language extension, those constraints could be removed completely, making the code a bit nicer. 132 | 133 | Here are some examples of using join in the nested case: 134 | 135 | ghci> join (_a._b) (Left $ Right $ Right "lenses") :: Either (Either a String) b 136 | Left (Right "lenses") 137 | 138 | ghci> join (_a._b) (Left $ Right $ Left "are") :: Either (Either String b) b 139 | Left (Left "are") 140 | 141 | ghci> join (_b._b) (Left "neat") :: Either String (Either a String) 142 | Left "neat" 143 | 144 | Sometimes we will get the same answer if we join in two separate locations. In the first example below, we join the second two Right constructors, whereas in the second example, we join the first two Right constructors. The results are the same: 145 | 146 | ghci> join (_b._b) (Right $ Right $ Right "mind") :: Either a (Either a String) 147 | Right (Right "mind") 148 | 149 | ghci> join _b (Right $ Right $ Right "blowing") :: Either a (Either a String) 150 | Right (Right "blowing") 151 | 152 | We'll also be needing a Monad instance for Maybe, so here it is: 153 | 154 | > instance Monad (Param_a Base) (Maybe a) where 155 | > join lens Nothing = Nothing 156 | > join lens (Just Nothing) = Nothing 157 | > join lens (Just (Just a)) = Just a 158 | 159 | > instance 160 | > ( Monad p a 161 | > , Maybe (CoJoin p a) ~ CoJoin (Param_a p) (Maybe a) -- follows from the lens laws 162 | > ) => Monad (Param_a p) (Maybe a) 163 | > where 164 | > join lens Nothing = Nothing 165 | > join lens (Just a) = Just $ join (zoom lens) a 166 | 167 | ------------------- 168 | -- bind 169 | 170 | From join and our Applicative instance, we can derive our monadic bind function. We don't want to use the traditional (>>=) operator for bind just yet. We will need to do something fancy with it to make do notation work out. So instead, we will use the (\\=) operator for bind. Its definition is: 171 | 172 | (\\=) :: 173 | ( Monad lens tb 174 | , a ~ GetParam lens tfa 175 | , {- ... lens laws go here ... -} 176 | ) => ta -> (a -> tb) -> TypeLens Base lens -> tb 177 | 178 | > infixl 1 \\= 179 | > (m \\= f) lens = join lens $ fmap lens f m 180 | 181 | We will to create the "minus bind operators" in the same way we created minus operators for the Applicative class. Remember, the minus sign points to the parameters that will get a lens applied to them because they are "minus a lens". These minus operators are defined as: 182 | 183 | > infixl 1 \\=- 184 | > infixl 1 -\\=- 185 | > infixl 1 -\\= 186 | > (m \\=- f) lens = ( m \\= \a -> f a $ objective lens ) lens 187 | > (m -\\=- f) lens = ( m lens \\= \a -> f a $ objective lens ) lens 188 | > (m -\\= f) lens = ( m lens \\= \a -> f a ) lens 189 | 190 | ------------------- 191 | -- example time 192 | 193 | For our example, we'll build a simple monadic filter. The filterSmall function below sits in the Either Monad, but we'll be using Left to represent successes (the input passes through the filter), and Right to represent failure (the input doesn't pass through). 194 | 195 | > filterSmall :: (Show a, Ord a) => a -> a -> Either a String 196 | > filterSmall k x = if x > k 197 | > then Left x 198 | > else Right $ show x ++ " is too small" 199 | 200 | We can call our function using the monadic bind by: 201 | 202 | > chain1 :: Either Int String 203 | > chain1 = at _a $ Left 20 \\= filterSmall 10 204 | 205 | ghci> chain1 206 | Left 20 207 | 208 | Instead of using the Left constructor, we can make things a little more generic by using the return function. As usual, it is equivalent to pure: 209 | 210 | > return :: Monad lens t 211 | > => GetParam lens t 212 | > -> TypeLens Base lens 213 | > -> t 214 | > return = pure 215 | 216 | Sine pure's last parameter is a type lens, we must use the left-minus (-\\=) variant of bind to sequence the computation: 217 | 218 | > chain2 :: Either Int String 219 | > chain2 = at _a $ return 20 -\\= filterSmall 10 220 | 221 | ghci> chain2 222 | Left 20 223 | 224 | Similarly, all the bind operators take a type lens as their last parameter. So any future binds must also use left-minus bind: 225 | 226 | > chain3 :: Either Int String 227 | > chain3 = at _a $ return 20 -\\= filterSmall 10 -\\= filterSmall 15 228 | 229 | ghci> chain3 230 | Left 20 231 | 232 | And so on: 233 | 234 | > chain4 :: Either Int String 235 | > chain4 = at _a $ return 20 -\\= filterSmall 10 -\\= filterSmall 15 -\\= filterSmall 25 236 | 237 | ghci> chain4 238 | Right "20 is too small" 239 | 240 | We can easily nest our monads. Let's put all of the computations above inside a Maybe wrapper. All we have to do is change the type signature and the lens: 241 | 242 | > chain2' :: Maybe (Either Int String) 243 | > chain2' = at (_a._a) $ return 20 -\\= filterSmall 10 244 | 245 | > chain3' :: Maybe (Either Int String) 246 | > chain3' = at (_a._a) $ return 20 -\\= filterSmall 10 -\\= filterSmall 15 247 | 248 | > chain4' :: Maybe (Either Int String) 249 | > chain4' = at (_a._a) $ return 20 -\\= filterSmall 10 -\\= filterSmall 15 -\\= filterSmall 25 250 | 251 | ------------------- 252 | -- do notation 253 | 254 | We're using the RebindableSyntax language extension to construct a custom do notation. We do this by defining our own (>>=) operator. The most generic bind operator we have is the double minus bind (-\\=-). Sometimes we will want to feed a lens to both sides of the bind, so that's what we'll use: 255 | 256 | > infixl 1 >>= 257 | > (m >>= f) lens = (m -\\=- f) lens 258 | 259 | Notice that our (>>=) operator and the one from Prelude take different numbers of arguments! GHC is awesome enough that this is not a problem. 260 | 261 | RebindableSyntax also requires us to define functions for failed pattern matching and if statements. Our definitions will be pretty simple: 262 | 263 | > fail = error 264 | 265 | > ifThenElse False _ f = f 266 | > ifThenElse True t _ = t 267 | 268 | Now, we can take our chain2' function above and rewrite it in do notation. Here it is again for easy reference: 269 | 270 | chain2' :: Maybe (Either Int String) 271 | chain2' = at (_a._a) $ return 20 -\\= filterSmall 10 272 | 273 | First, rewrite it to use (-\\=-) instead of (-\\=) by causing the right hand side to take a lens parameter even though it won't use it: 274 | 275 | > chain2'' :: Maybe (Either Int String) 276 | > chain2'' = at (_a._a) $ return 20 -\\=- (\x lens -> filterSmall 10 x) 277 | 278 | Then, rewrite it using do notation: 279 | 280 | > chain2''' :: Maybe (Either Int String) 281 | > chain2''' = at (_a._a) $ do 282 | > x <- return 20 283 | > \lens -> filterSmall 10 x 284 | 285 | It looks a little bit nicer if we use const to absorb the lens parameter: 286 | 287 | > chain2'''' :: Maybe (Either Int String) 288 | > chain2'''' = at (_a._a) $ do 289 | > x <- return 20 290 | > const $ filterSmall 10 x 291 | 292 | Here is our other examples converted into do notation using the same technique: 293 | 294 | > chain3''' :: Maybe (Either Int String) 295 | > chain3''' = at (_a._a) $ do 296 | > x <- return 20 297 | > y <- const $ filterSmall 10 x 298 | > const $ filterSmall 15 y 299 | 300 | > chain4'' :: Maybe (Either Int String) 301 | > chain4'' = at (_a._a) $ do 302 | > x <- return 20 303 | > y <- const $ filterSmall 10 x 304 | > z <- const $ filterSmall 15 y 305 | > const $ filterSmall 25 z 306 | 307 | And here is a more complicated expression with a nested do: 308 | 309 | > chain5 :: Either a (Either a (Maybe (Either Int String))) 310 | > chain5 = at (_b._b._a._a) $ do 311 | > x <- return 20 312 | > y <- do 313 | > a <- const $ filterSmall x 10 314 | > b <- const $ filterSmall 1 3 315 | > return $ a+b 316 | > z <- const $ filterSmall y x 317 | > return $ z-x 318 | 319 | But there is still a limitation. Due to the way the types work out, the first line of a do block must always be a return statement when using the at function to specify our lens. This is a by product of the extra lens parameter our (>>=) operator is passing around. Fortunately, we can automate this construction with the following function: 320 | 321 | > atM lens m = at (removeObjective lens) $ do 322 | > return $ at (objective lens) $ m 323 | 324 | This lets us rewrite chain5 as: 325 | 326 | > chain5' :: Either a (Either a (Maybe (Either Int String))) 327 | > chain5' = atM (_b._b._a._a) $ do 328 | > let x = 20 329 | > y <- do 330 | > a <- const $ filterSmall x 10 331 | > b <- const $ filterSmall 1 3 332 | > return $ a+b 333 | > z <- const $ filterSmall y x 334 | > return $ z-x 335 | 336 | Now we fully support do notation! 337 | 338 | Hooray!! 339 | 340 | ------------------- 341 | -- 342 | 343 | 344 | We're almost done with this craziness... 345 | -------------------------------------------------------------------------------- /examples/blog-partiallyclosed.lhs: -------------------------------------------------------------------------------- 1 | This post covers a pretty neat trick with closed type families. Normally, closed type families must be defined all in a single file. This trick, however, will let us define certain closed type families over many files. 2 | 3 | We only need these two language extensions for the technique: 4 | 5 | > {-# LANGUAGE TypeFamilies #-} 6 | > {-# LANGUAGE UndecidableInstances #-} 7 | 8 | But for our motivating example, we'll also use these extensions and some basic imports: 9 | 10 | > {-# LANGUAGE KindSignatures #-} 11 | > {-# LANGUAGE MultiParamTypeClasses #-} 12 | > {-# LANGUAGE ConstraintKinds #-} 13 | 14 | > import Data.Proxy 15 | > import GHC.Exts 16 | 17 | Consider the classes: 18 | 19 | > class Param_a (p :: * -> Constraint) t 20 | > class Param_b (p :: * -> Constraint) t 21 | > class Param_c (p :: * -> Constraint) t 22 | > class Base t 23 | 24 | These classes can be chained together like so: 25 | 26 | > type Telescope_abc = Param_a (Param_b (Param_c Base)) 27 | 28 | It is easy to write a type family that returns the "head" of this list. We'll call this the EyePiece of the Telescope: 29 | 30 | > type family EyePiece ( p :: * -> Constraint ) :: * -> Constraint 31 | 32 | > type instance EyePiece (Param_a p) = Param_a Base 33 | > type instance EyePiece (Param_b p) = Param_b Base 34 | > type instance EyePiece (Param_c p) = Param_c Base 35 | 36 | We might use this EyePiece type class as: 37 | 38 | ghci> :t Proxy :: Proxy (EyePiece Telescope_abc) 39 | :: Proxy (Param_a Base) 40 | 41 | Now, let's try to write a type class that does the opposite. Instead of extracting the first element in the chain, it will extract the last. On a telescope the lens farthest away from you is called the objective, so that's what we'll call our type family. 42 | 43 | type family Objective (lens :: * -> Constraint) :: * -> Constraint where 44 | Objective (Param_a p) = Objective p 45 | Objective (Param_b p) = Objective p 46 | Objective (Param_c p) = Objective p 47 | Objective (Param_a Base) = Param_a Base 48 | Objective (Param_b Base) = Param_b Base 49 | Objective (Param_c Base) = Param_c Base 50 | 51 | And we can use the Objective family like: 52 | 53 | ghci> :t Proxy :: Proxy (Objective Telescope_abc) 54 | :: Proxy (Param_c Base) 55 | 56 | The Objective family must be closed. This is because the only way to identify when we are at the end of the telescope is by checking if the p parmaeter is the Base class. If it is, then we're done. If not, we must keep moving down the telescope recusively. Without a closed type family, we would have to explicitly list all of the recursive paths. This means $O(n^2)$ type instances whenever we want to add a new Param_xxx class. 57 | 58 | Again, the downside of closed type families is that they must be defined all in one place. We can work around this limitation by "factoring" the closed type family into a collection of closed and open type families. In the example above, this works out to be: 59 | 60 | > type family Objective (lens :: * -> Constraint) :: * -> Constraint 61 | > type instance Objective (Param_a p) = Objective_Param_a (Param_a p) 62 | > type instance Objective (Param_b p) = Objective_Param_b (Param_b p) 63 | > type instance Objective (Param_c p) = Objective_Param_c (Param_c p) 64 | > type instance Objective Base = Base 65 | 66 | > type family Objective_Param_a (lens :: * -> Constraint) :: * -> Constraint where 67 | > Objective_Param_a (Param_a Base) = Param_a Base 68 | > Objective_Param_a (Param_a p) = Objective p 69 | 70 | > type family Objective_Param_b (lens :: * -> Constraint) :: * -> Constraint where 71 | > Objective_Param_b (Param_b Base) = Param_b Base 72 | > Objective_Param_b (Param_b p) = Objective p 73 | 74 | > type family Objective_Param_c (lens :: * -> Constraint) :: * -> Constraint where 75 | > Objective_Param_c (Param_c Base) = Param_c Base 76 | > Objective_Param_c (Param_c p) = Objective p 77 | 78 | ghci> :t Proxy :: Proxy (Objective Telescope_abc) 79 | :: Proxy (Param_c Base) 80 | 81 | With this factoring, we are able to define the Objective instance for each Param_xxx in separate files and retain the benefits of closed type families. 82 | 83 | Here is another example. The RemoveObjective family acts like the init function from the Prelude: 84 | 85 | > type family RemoveObjective (lens :: * -> Constraint) :: * -> Constraint 86 | > type instance RemoveObjective (Param_a p) = RemoveObjective_Param_a (Param_a p) 87 | > type instance RemoveObjective (Param_b p) = RemoveObjective_Param_b (Param_b p) 88 | > type instance RemoveObjective (Param_c p) = RemoveObjective_Param_c (Param_c p) 89 | 90 | > type family RemoveObjective_Param_a (lens :: * -> Constraint) :: * -> Constraint where 91 | > RemoveObjective_Param_a (Param_a Base) = Base 92 | > RemoveObjective_Param_a (Param_a p) = Param_a (RemoveObjective p) 93 | 94 | > type family RemoveObjective_Param_b (lens :: * -> Constraint) :: * -> Constraint where 95 | > RemoveObjective_Param_b (Param_b Base) = Base 96 | > RemoveObjective_Param_b (Param_b p) = Param_b (RemoveObjective p) 97 | 98 | > type family RemoveObjective_Param_c (lens :: * -> Constraint) :: * -> Constraint where 99 | > RemoveObjective_Param_c (Param_c Base) = Base 100 | > RemoveObjective_Param_c (Param_c p) = Param_b (RemoveObjective p) 101 | 102 | ghci> :t Proxy :: Proxy (RemoveObjective Telescope_abc) 103 | :: Proxy (Param_a (Param_b Base)) 104 | 105 | Tomorrow, I'll be using these type families and the typeparams package to lensify the Monad class. 106 | -------------------------------------------------------------------------------- /examples/blog-rewrite.lhs: -------------------------------------------------------------------------------- 1 | We've seen how to use the typeparams library to soup up our Functor and Applicative type classes. But we've been naughty little haskellers---we've been using type lenses without discussing their laws. That's the subject of today's post. **Don't worry if you didn't read/understand the previous posts.** This post is much simpler and does not require any background. 2 | 3 | First, we'll translate the standard lens laws to the type level. Then we'll see how these laws can greatly simplify the type signatures of our functions. Finally, I'll propose a very simple (yes, I promise!) GHC extension that promotes rewrite rules to the type level. These type level rewrite rules would automatically simplify our type signatures for us. It's pretty freakin awesome. 4 | 5 | Today, we won't actually import anything from the typeparams library. Instead, we'll be building up everything from scratch. 6 | 7 | > {-# LANGUAGE TypeFamilies #-} 8 | > {-# LANGUAGE MultiParamTypeClasses #-} 9 | > {-# LANGUAGE PolyKinds #-} 10 | > {-# LANGUAGE RankNTypes #-} 11 | > {-# LANGUAGE ConstraintKinds #-} 12 | > {-# LANGUAGE FlexibleContexts #-} 13 | 14 | > import Control.Category 15 | > import Prelude hiding ( (.), id ) 16 | > import Data.Proxy 17 | > import GHC.Exts 18 | 19 | ------------------- 20 | -- what, exactly is a type lens? 21 | 22 | Given a data type: 23 | 24 | > data Example a b c = Example a b c 25 | 26 | We construct the following empty classes: 27 | 28 | > class Param_a (p :: * -> Constraint) t -- has kind :: * -> Constraint 29 | > class Param_b (p :: * -> Constraint) t 30 | > class Param_c (p :: * -> Constraint) t 31 | 32 | Each of these classes uniquely identifies one of the parameters of the Example data type. To use these lenses, we create the singleton type: 33 | 34 | > data TypeLens p q = TypeLens 35 | 36 | Now, we can create three values that uinquely identify the three type parameters: 37 | 38 | > _a = TypeLens :: TypeLens p (Param_a p) 39 | > _b = TypeLens :: TypeLens p (Param_b p) 40 | > _c = TypeLens :: TypeLens p (Param_c p) 41 | 42 | We're calling these things lenses, so they must be composable. In fact, they compose really easy. Check out their Category instance: 43 | 44 | > instance Category TypeLens where 45 | > id = TypeLens 46 | > t1.t2 = TypeLens 47 | 48 | When we chain values together using the (.) composition operator, we create a chain of classes at the type level. For example: 49 | 50 | ghci> :t _a._b 51 | _a._b :: TypeLens p (Param_a (Param_b p)) 52 | 53 | ghci> :t _a._b._c 54 | _a._b._c :: TypeLens p (Param_a (Param_b (Param_c p))) 55 | 56 | ghci> > :t _a._a._b._c._a._b 57 | _a._a._b._c._a._b :: TypeLens p (Param_a (Param_a (Param_b (Param_c (Param_a (Param_b p)))))) 58 | 59 | These chains of classes correspond to a nesting of data types. For the Example type we created above, _a._b would refer to the type param b1 in the type: 60 | 61 | Example (Example a1 b1 c1) b2 c2 62 | 63 | _a._b._c would refer to b2 in the type: 64 | 65 | Example (Example a1 b1 (Example a2 b2 c2)) b0 c0 66 | 67 | and _a._a._b._c._a._b would refer to the parameter b6 in the monster type: 68 | 69 | Example 70 | ( Example 71 | ( Example 72 | a2 73 | ( Example 74 | a3 75 | b3 76 | ( Example 77 | ( Example 78 | a5 79 | ( Example 80 | a6 81 | b6 82 | c6 83 | ) 84 | c5 85 | ) 86 | b4 87 | c4 88 | ) 89 | ) 90 | c2 91 | ) 92 | b1 93 | c1 94 | ) 95 | b0 96 | c0 97 | 98 | ------------------- 99 | -- getters and setters 100 | 101 | The whole point of lenses is they give us an easy way to get and set parameters. At the type level, we do that with these type families: 102 | 103 | > type family GetParam (p :: * -> Constraint) (t :: *) :: * 104 | > type family SetParam (p :: * -> Constraint) (a :: *) (t :: *) :: * 105 | 106 | For our Example data type, the implementations look like: 107 | 108 | > type instance GetParam (Param_a p) (Example a b c) = GetParam p a 109 | > type instance GetParam (Param_b p) (Example a b c) = GetParam p b 110 | > type instance GetParam (Param_c p) (Example a b c) = GetParam p c 111 | 112 | > type instance SetParam (Param_a p) a' (Example a b c) = Example (SetParam p a' a) b c 113 | > type instance SetParam (Param_b p) b' (Example a b c) = Example a (SetParam p b' b) c 114 | > type instance SetParam (Param_c p) c' (Example a b c) = Example a b (SetParam p c' c) 115 | 116 | These definitions are recursive, so we need a base case to halt the recursion: 117 | 118 | > class Base t 119 | > type instance GetParam Base t = t 120 | > type instance SetParam Base t' t = t' 121 | 122 | Here are two example usages of the GetParam family: 123 | 124 | ghci> :t undefined :: GetParam (Param_a Base) (Example Int Float c) 125 | :: Int 126 | 127 | ghci> :t undefined :: GetParam (Param_b Base) (Example Int Float c) 128 | :: Float 129 | 130 | ghci> :t undefined :: GetParam (Param_a (Param_b Base)) (Example (Example a1 Int c1) b2 Float) 131 | :: Int 132 | 133 | ghci> :t undefined :: GetParam (Param_c Base) (Example (Example a1 Int c1) b2 Float) 134 | :: Float 135 | 136 | And corresponding uses of the SetParam family: 137 | 138 | ghci> :t undefined :: SetParam (Param_a Base) Float (Example Int b c) 139 | :: Example Float b c 140 | 141 | ghci> :t undefined :: SetParam (Param_a (Param_b Base)) Float (Example (Example a1 Int c1) b2 c2) 142 | :: Example (Example a1 Float c1) b2 c2 143 | 144 | ------------------- 145 | -- the lens laws 146 | 147 | The first lens law is that if we set a type parameter to its current value, then the overall type does not change. In code, this looks like: 148 | 149 | > type LensLaw1 lens t = t ~ SetParam lens (GetParam lens t) t 150 | 151 | The second lens law states that if we set a type parameter to a certain value, then get the value at the location of the lens, then we should get back our original type. In code: 152 | 153 | > type LensLaw2 lens a t = a ~ GetParam lens (SetParam lens a t) 154 | 155 | And lastly, if we set the same parameter twice, then the last setter wins. In code: 156 | 157 | > type LensLaw3 lens a b t = a ~ GetParam lens (SetParam lens a (SetParam lens b t)) 158 | 159 | There are many other laws that can be derived from these three simple laws. For example, we can derive this fourth lens law from laws 1 and 3: 160 | 161 | > type LensLaw4 lens a b t = SetParam lens a (SetParam lens b t) ~ SetParam lens a t 162 | 163 | We're glossing over some technicalities involving injective type families, here, buy we'll return to this later in the post. 164 | 165 | ------------------- 166 | -- promoting quick check to the type level 167 | 168 | Any time we have laws in Haskell, we've got to prove that they hold. Sometimes, parametricity does this for us automatically (as in the case of the Functor laws). But usually, we rely on test frameworks like QuickCheck. Therefore, we need these frameworks at the type level. 169 | 170 | This turns out to be straightforward. We can use these functions to verify our laws: 171 | 172 | > property_lensLaw1 :: LensLaw1 lens t => TypeLens Base lens -> t -> () 173 | > property_lensLaw1 _ _ = () 174 | 175 | > property_lensLaw2 :: LensLaw2 lens a t => TypeLens Base lens -> a -> t -> () 176 | > property_lensLaw2 _ _ _ = () 177 | 178 | > property_lensLaw3 :: LensLaw3 lens a b t => TypeLens Base lens -> a -> b -> t -> () 179 | > property_lensLaw3 _ _ _ _ = () 180 | 181 | We test the laws as follows. First, specialize all the type variables in the function. Then, ask the type checker if the function is valid. If it is, then the law holds for the type variables we chose. 182 | 183 | Here is an example: 184 | 185 | ghci> property_lensLaw1 _a (undefined :: Example Int Float String) 186 | () 187 | 188 | ghci> property_lensLaw2 _a (undefined :: String) (undefined :: Example Int Float String) 189 | () 190 | 191 | ghci> property_lensLaw3 _a (undefined :: String) (undefined :: [a]) (undefined :: Example Int Float String) 192 | () 193 | 194 | Now, let's write some GetParam/SetParam instances that do not obey the laws and see what happens. In the NationalSecurityAgency type below, the Getter works just fine, but the Setter is broken. 195 | 196 | > data NationalSecurityAgency x = LawBreaker 197 | 198 | > class Param_x (p :: * -> Constraint) t 199 | > _x = TypeLens :: TypeLens p (Param_x p) 200 | 201 | > type instance GetParam (Param_x p) (NationalSecurityAgency x) = x 202 | > type instance SetParam (Param_x p) x' (NationalSecurityAgency x) = NationalSecurityAgency String 203 | 204 | When we test the first lens law using a String, everything works fine: 205 | 206 | ghci> lensLaw1 _x (undefined :: NationalSecurityAgency String) 207 | () 208 | 209 | But when we test it using an Int, the type checker explodes: 210 | 211 | ghci> lensLaw1 _x (undefined :: NationalSecurityAgency Int) 212 | 213 | :73:1: 214 | Couldn't match type ‘[Char]’ with ‘Int’ 215 | Expected type: SetParam 216 | (Param_x Base) 217 | (GetParam (Param_x Base) (NationalSecurityAgency Int)) 218 | (NationalSecurityAgency Int) 219 | Actual type: NationalSecurityAgency Int 220 | In the expression: lensLaw1 _x (undefined :: NationalSecurityAgency Int) 221 | In an equation for ‘it’: 222 | it = lensLaw1 _x (undefined :: NationalSecurityAgency Int) 223 | 224 | You can imagine a template haskell quickcheck that calls these property functions many times on random types to give a probabalistic test our type laws hold. 225 | 226 | ------------------- 227 | -- using the laws 228 | 229 | These laws will greatly simplify inferred types in our programs. We'll see why using an example. 230 | 231 | Consider the beloved Applicative sequencing operator (*>) . In the standard libraries, it has the type: 232 | 233 | (*>) :: Applicative f => f a -> f b -> f b 234 | 235 | Sweet and simple. 236 | 237 | In the applicative class we generated yesterday, however, the sequencing operator is pretty nasty looking. GHCi reports it has the type of: 238 | 239 | > (*>) :: 240 | > ( Applicative lens 241 | > ( SetParam 242 | > lens 243 | > (a1 -> GetParam lens (SetParam lens (a -> GetParam lens tb1) tb1)) 244 | > (SetParam lens (a -> GetParam lens tb1) tb1) 245 | > ) 246 | > , Applicative lens (SetParam lens (a -> GetParam lens tb1) tb1) 247 | > , Applicative lens tb1 248 | > , (b1 -> a2 -> a2) ~ GetParam 249 | > lens 250 | > (SetParam 251 | > lens 252 | > (a1 -> GetParam lens (SetParam lens (a -> GetParam lens tb1) tb1)) 253 | > (SetParam lens (a -> GetParam lens tb1) tb1)) 254 | > , a1 ~ GetParam lens (SetParam lens a1 (SetParam lens (a -> GetParam lens tb1) tb1)) 255 | > , tb0 ~ SetParam lens a tb1 256 | > , ta ~ SetParam lens a1 (SetParam lens (a -> GetParam lens tb1) tb1) 257 | > , a ~ GetParam lens (SetParam lens a tb1) 258 | > ) => ta 259 | > -> tb0 260 | > -> TypeLens Base lens 261 | > -> tb1 262 | 263 | > (*>) = undefined 264 | > class Applicative lens t 265 | 266 | Yikes! What the hell does that beast do?! 267 | 268 | Somehow, we need to simplify this type signature, and the type lens laws are what lets us do this. For example, one of the constraints above is: 269 | 270 | a1 ~ GetParam lens (SetParam lens a1 (SetParam lens (a -> GetParam lens tb1) tb1)) 271 | 272 | We can use the third lens law to simplify this to: 273 | 274 | a1 ~ GetParam lens (SetParam lens a1 tb1) 275 | 276 | If we repeat this process many times, we get a type signature that looks like: 277 | 278 | > newop :: 279 | > ( Applicative lens ( SetParam lens ( a -> b -> b ) tb ) 280 | > , Applicative lens ( SetParam lens ( b -> b ) tb ) 281 | > , Applicative lens tb 282 | 283 | > , tb ~ SetParam lens b tb 284 | 285 | > , LensLaw2 lens (b->b) tb 286 | > , LensLaw2 lens b tb 287 | > , LensLaw3 lens (a -> b -> b) (b -> b) tb 288 | > , LensLaw3 lens a (b->b) tb 289 | > , LensLaw4 lens (a->b->b) (b->b) tb 290 | > , LensLaw4 lens a (b->b) tb 291 | > ) => SetParam lens a tb 292 | > -> tb 293 | > -> TypeLens Base lens 294 | > -> tb 295 | > newop = (*>) 296 | 297 | This looks quite a bit better, but is still less than ideal. Actually, this is as far as you can get with the lens laws in GHC 7.8. You need injective types to go further. So the rest of this post will be a bit more theoretical about what we might be able to do in a future GHC. 298 | 299 | ------------------- 300 | -- injecting power into the lens laws 301 | 302 | Let's take another look at the type synonyms for the lens laws: 303 | 304 | type LensLaw1 lens t = t ~ SetParam lens (GetParam lens t) t 305 | type LensLaw2 lens a t = a ~ GetParam lens (SetParam lens a t) 306 | type LensLaw3 lens a b t = a ~ GetParam lens (SetParam lens a (SetParam lens b t)) 307 | 308 | This code only enforces that the laws hold for certain parameters. But that's not what we want! All types are equal in the eyes of the law, so what we really want is type synonyms that look like: 309 | 310 | type LensLaw1' = forall lens t. t ~ SetParam lens (GetParam lens t) t 311 | type LensLaw2' = forall lens a t. a ~ GetParam lens (SetParam lens a t) 312 | type LensLaw3' = forall lens a b t. a ~ GetParam lens (SetParam lens a (SetParam lens b t)) 313 | 314 | Unfortunately, sticking this into GHC yields the dreaded "type families may not be injective" error message. With injective type families, we would be able to write these laws, and then our code would simplify further to: 315 | 316 | newop' :: 317 | ( Applicative lens ( SetParam lens ( a -> b -> b ) tb ) 318 | , Applicative lens ( SetParam lens ( b -> b ) tb ) 319 | , Applicative lens tb 320 | 321 | , tb ~ SetParam lens b tb 322 | 323 | , LensLaw1' 324 | , LensLaw2' 325 | , LensLaw3' 326 | ) => SetParam lens a tb 327 | -> tb 328 | -> TypeLens Base lens 329 | -> tb 330 | newop' = (*>) 331 | 332 | ------------------- 333 | -- a proposal for new syntax 334 | 335 | We can still do better. The lens laws are not something that applies only to specific functions. They are global properties of the type families, and they apply everywhere. Therefore, they should be implicitly added as constraints into every type signature. 336 | 337 | We could make this happen by adding a new syntax called "type rules". (The name comes from analogy with the rewrite rules at the value level.) The syntax could look something like: 338 | 339 | type rule LensLaw1' = forall lens t. t ~ SetParam lens (GetParam lens t) t 340 | type rule LensLaw2' = forall lens a t. a ~ GetParam lens (SetParam lens a t) 341 | type rule LensLaw3' = forall lens a b t. a ~ GetParam lens (SetParam lens a (SetParam lens b t)) 342 | 343 | And would allow us to write our function as: 344 | 345 | newop'' :: 346 | ( Applicative lens ( SetParam lens ( a -> b -> b ) tb ) 347 | , Applicative lens ( SetParam lens ( b -> b ) tb ) 348 | , Applicative lens tb 349 | 350 | , tb ~ SetParam lens b tb 351 | 352 | ) => SetParam lens a tb 353 | -> tb 354 | -> TypeLens Base lens 355 | -> tb 356 | newop'' = (*>) 357 | 358 | That is soooo much nicer! 359 | 360 | ------------------- 361 | -- Stay tuned 362 | 363 | We still have some work to go to get our newop function's type signature as simple as (*>) from the standard library. But I think we've got a realistic shot at it. In a coming post I'll be proposing a way to combine the multiple Applicative constraints into a single constraint, and a nice looking sugar over the SetParam/GetParam type families. 364 | 365 | -------------------------------------------------------------------------------- /examples/coretest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O2 -fllvm -mavx512f #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE UnboxedTuples #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ConstraintKinds #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | -- | This module is intentionally simple so that the core and assembly will 18 | -- be easy to inspect. This demonstrates that the generated machine code 19 | -- is slightly nicer when parameters are known at compile time. 20 | module Main 21 | where 22 | 23 | import GHC.Float 24 | import GHC.Prim 25 | 26 | import Data.Params 27 | 28 | data Test (p::Config Nat) = Test Int 29 | mkParams ''Test 30 | 31 | {-# INLINE doSomething #-} 32 | doSomething :: forall p. 33 | ( ViewParam Param_p (Test p) 34 | ) => Test p -> Int 35 | doSomething t@(Test i) = i*viewParam _p t 36 | 37 | {-# INLINE doStatic #-} 38 | doStatic :: Int -> Int 39 | doStatic i = doSomething (Test i::Test (Static 123456)) 40 | -- resulting core: 41 | -- 42 | -- doStatic :: Int -> Int 43 | -- doStatic = 44 | -- \ (i :: Int) -> case i of _ [Occ=Dead] { I# x -> I# (*# x 10) } 45 | 46 | {-# INLINE doRuntime #-} 47 | doRuntime :: Int -> Int 48 | doRuntime i = mkApWith1Param 49 | (Proxy::Proxy (Test RunTime)) 50 | (Proxy::Proxy Int) 51 | _p 52 | 123455 53 | doSomething 54 | (Test i) 55 | -- resulting core: 56 | -- 57 | -- doRuntime :: Int -> Int 58 | -- doRuntime = 59 | -- doRuntime1 60 | -- `cast` (_R -> UnivCo representational Any Int 61 | -- :: (Int -> Any) ~# (Int -> Int)) 62 | -- 63 | 64 | 65 | main = do 66 | print $ doStatic 1234 67 | print $ doRuntime 1233 68 | 69 | print (rationalToFloat 2 1) 70 | 71 | 72 | {-# RULES 73 | 74 | "rationalToFloat 2 1" rationalToFloat 2 1 = 2 :: Float 75 | 76 | #-} 77 | 78 | {-# NOINLINE x #-} 79 | x=2::Rational 80 | 81 | -------------------------------------------------------------------------------- /examples/criterion.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O2 -fllvm -mavx512f #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE UnboxedTuples #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | 9 | import Control.Category 10 | import Control.DeepSeq 11 | import Control.Monad 12 | import Control.Monad.Random 13 | import Control.Monad.ST 14 | import Criterion.Config 15 | import Criterion.Main 16 | import Data.Primitive.ByteArray 17 | import qualified Data.Vector.Generic as VG 18 | import qualified Data.Params.Vector.Unboxed as VPU 19 | import qualified Data.Params.Vector.UnboxedRaw as VPUR 20 | import qualified Data.Params.Vector.Storable as VPS 21 | import qualified Data.Params.Vector.Storable as VPSR 22 | import qualified Data.Vector.Unboxed as VU 23 | import qualified Data.Vector as V 24 | import Prelude hiding ((.),id) 25 | 26 | import GHC.Float 27 | import GHC.Int 28 | import GHC.Base (Int (..)) 29 | import GHC.Prim 30 | 31 | import Data.Params 32 | import Data.Params.Vector 33 | 34 | ------------------------------------------------------------------------------- 35 | -- criterion tests 36 | 37 | -- | size of each vector to test; must be divisible by 4 38 | type Veclen = 16 39 | veclen = intparam (Proxy::Proxy Veclen) 40 | -- veclen = fromIntegral $ natVal (Proxy::Proxy Veclen) 41 | 42 | -- | number of vectors in 2d tests 43 | type Numvec = 11000 44 | numvec = intparam (Proxy::Proxy Numvec) 45 | -- numvec = fromIntegral $ natVal (Proxy::Proxy Numvec) 46 | 47 | -- | numeric type to test against 48 | type NumType = Float 49 | 50 | -- | criterion configuration parameters 51 | critConfig = defaultConfig 52 | { cfgPerformGC = ljust True 53 | , cfgSamples = ljust 1 54 | -- , cfgSummaryFile = ljust $ "results/summary-"++show veclen++"-"++show numvec++".csv" 55 | -- , cfgReport = ljust "report.html" 56 | } 57 | 58 | ------------------------------------------------------------------------------- 59 | -- main function 60 | 61 | main = do 62 | 63 | ----------------------------------- 64 | -- initialize single vectors 65 | 66 | putStrLn "constructing single vectors" 67 | 68 | let dimL1 :: [NumType] = evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 1) 69 | dimL2 :: [NumType] = evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 2) 70 | 71 | let vu1 = VU.fromList dimL1 72 | vu2 = VU.fromList dimL2 73 | 74 | let vpua1 = VG.fromList dimL1 :: VPU.Vector Automatic NumType 75 | vpua2 = VG.fromList dimL2 :: VPU.Vector Automatic NumType 76 | 77 | let vpus1 = VG.fromList dimL1 :: VPU.Vector (Static Veclen) NumType 78 | vpus2 = VG.fromList dimL2 :: VPU.Vector (Static Veclen) NumType 79 | 80 | -- let vpur1 = withParam (VPU.len veclen) $ VG.fromList dimL1 :: VPU.Vector Automatic NumType 81 | -- vpur2 = withParam (VPU.len veclen) $ VG.fromList dimL2 :: VPU.Vector Automatic NumType 82 | 83 | let vprs1 = VG.fromList dimL1 :: VPUR.Vector (Static Veclen) NumType 84 | vprs2 = VG.fromList dimL2 :: VPUR.Vector (Static Veclen) NumType 85 | 86 | let vpss1 = VG.fromList dimL1 :: VPS.Vector (Static Veclen) NumType 87 | vpss2 = VG.fromList dimL2 :: VPS.Vector (Static Veclen) NumType 88 | 89 | let vpsr1 = VG.fromList dimL1 :: VPSR.Vector (Static Veclen) NumType 90 | vpsr2 = VG.fromList dimL2 :: VPSR.Vector (Static Veclen) NumType 91 | 92 | let ba1 = list2ByteArray dimL1 93 | ba2 = list2ByteArray dimL2 94 | 95 | deepseq vu1 $ deepseq vu2 $ return () 96 | deepseq vpua1 $ deepseq vpua2 $ return () 97 | deepseq vpus1 $ deepseq vpus2 $ return () 98 | deepseq vprs1 $ deepseq vprs2 $ return () 99 | deepseq vpss1 $ deepseq vpss2 $ return () 100 | deepseq vpsr1 $ deepseq vpsr2 $ return () 101 | seq ba1 $ seq ba2 $ return () 102 | 103 | ----------------------------------- 104 | -- initialize 2d vectors 105 | 106 | putStrLn "constructing 2d vectors of vectors" 107 | 108 | let dimLL1 :: [[NumType]] = 109 | [ evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen i) | i <- [1..numvec]] 110 | 111 | let dimLL2 :: [[NumType]] = 112 | [ evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen i) | i <- [2..numvec+1]] 113 | 114 | putStrLn " generating random numbers" 115 | deepseq dimLL1 $ deepseq dimLL2 $ return () 116 | 117 | let vpuavpus1 = VG.fromList $ map VG.fromList dimLL1 118 | :: VPU.Vector Automatic (VPU.Vector (Static Veclen) NumType) 119 | let vpuavpus2 = VG.fromList $ map VG.fromList dimLL2 120 | :: VPU.Vector Automatic (VPU.Vector (Static Veclen) NumType) 121 | 122 | let vpuavpur1 = with1Param (_elem . _len) veclen $ VG.fromList $ map VG.fromList dimLL1 123 | :: VPU.Vector Automatic (VPU.Vector RunTime NumType) 124 | let vpuavpur2 = with1Param (_elem . _len) veclen $ VG.fromList $ map VG.fromList dimLL2 125 | :: VPU.Vector Automatic (VPU.Vector RunTime NumType) 126 | 127 | let vpusvpus1 = VG.fromList $ map VG.fromList dimLL1 128 | :: VPU.Vector (Static Numvec) (VPU.Vector (Static Veclen) NumType) 129 | let vpusvpus2 = VG.fromList $ map VG.fromList dimLL2 130 | :: VPU.Vector (Static Numvec) (VPU.Vector (Static Veclen) NumType) 131 | 132 | let vprsvpus1 = VG.fromList $ map VG.fromList dimLL1 133 | :: VPUR.Vector (Static Numvec) (VPU.Vector (Static Veclen) NumType) 134 | let vprsvpus2 = VG.fromList $ map VG.fromList dimLL2 135 | :: VPUR.Vector (Static Numvec) (VPU.Vector (Static Veclen) NumType) 136 | 137 | let vpssvpss1 = VG.fromList $ map VG.fromList dimLL1 138 | :: VPS.Vector (Static Numvec) (VPS.Vector (Static Veclen) NumType) 139 | let vpssvpss2 = VG.fromList $ map VG.fromList dimLL2 140 | :: VPS.Vector (Static Numvec) (VPS.Vector (Static Veclen) NumType) 141 | 142 | let vpsrvpsr1 = VG.fromList $ map VG.fromList dimLL1 143 | :: VPSR.Vector (Static Numvec) (VPSR.Vector (Static Veclen) NumType) 144 | let vpsrvpsr2 = VG.fromList $ map VG.fromList dimLL2 145 | :: VPSR.Vector (Static Numvec) (VPSR.Vector (Static Veclen) NumType) 146 | 147 | let vpusvpua1 = VPU.staticToAutomatic (_elem._len) vpusvpus1 148 | vpusvpua2 = VPU.staticToAutomatic (_elem._len) vpusvpus2 149 | 150 | let vpuavpua1 = VPU.staticToAutomatic _len vpusvpua1 151 | vpuavpua2 = VPU.staticToAutomatic _len vpusvpua2 152 | 153 | let vvpus1 = VG.fromList $ map VG.fromList dimLL1 154 | :: V.Vector (VPU.Vector (Static Veclen) NumType) 155 | let vvpus2 = VG.fromList $ map VG.fromList dimLL2 156 | :: V.Vector (VPU.Vector (Static Veclen) NumType) 157 | 158 | let vvu1 = VG.fromList $ map VG.fromList dimLL1 159 | :: V.Vector (VU.Vector NumType) 160 | vvu2 = VG.fromList $ map VG.fromList dimLL2 161 | :: V.Vector (VU.Vector NumType) 162 | 163 | putStrLn " vpuavpus"; deepseq vpuavpus1 $ deepseq vpuavpus2 $ return () 164 | putStrLn " vpusvpus"; deepseq vpusvpus1 $ deepseq vpusvpus2 $ return () 165 | putStrLn " vpssvpss"; deepseq vpssvpss1 $ deepseq vpssvpss2 $ return () 166 | putStrLn " vpsrvpsr"; deepseq vpsrvpsr1 $ deepseq vpsrvpsr2 $ return () 167 | putStrLn " vpusvpua"; deepseq vpusvpua1 $ deepseq vpusvpua2 $ return () 168 | putStrLn " vpuavpua"; deepseq vpuavpua1 $ deepseq vpuavpua2 $ return () 169 | putStrLn " vprsvpus"; deepseq vprsvpus1 $ deepseq vprsvpus2 $ return () 170 | putStrLn " vpuavpus"; deepseq vpssvpss1 $ deepseq vpssvpss2 $ return () 171 | putStrLn " vvpus"; deepseq vvpus1 $ deepseq vvpus2 $ return () 172 | putStrLn " vvu"; deepseq vvu1 $ deepseq vvu2 $ return () 173 | 174 | ----------------------------------- 175 | -- tests 176 | 177 | putStrLn "starting criterion" 178 | 179 | defaultMainWith critConfig (return ()) 180 | [ bgroup "1d" 181 | [ bgroup "diff1" 182 | [ bench "VU.Vector" $ nf (distance_Vector_diff1 vu1) vu2 183 | , bench "VPU.Vector Automatic" $ nf (distance_Vector_diff1 vpua1) vpua2 184 | , bench "VPU.Vector (Static Veclen)" $ nf (distance_Vector_diff1 vpus1) vpus2 185 | , bench "VPUR.Vector (Static Veclen)" $ nf (distance_Vector_diff1 vprs1) vprs2 186 | , bench "VPS.Vector (Static Veclen)" $ nf (distance_Vector_diff1 vpss1) vpss2 187 | , bench "VPSR.Vector (Static Veclen)" $ nf (distance_Vector_diff1 vpsr1) vpsr2 188 | , bench "ByteArray" $ nf (distance_ByteArray_diff1 ba1) ba2 189 | ] 190 | , bgroup "diff4" 191 | [ bench "VU.Vector" $ nf (distance_Vector_diff4 vu1) vu2 192 | , bench "VPU.Vector Automatic" $ nf (distance_Vector_diff4 vpua1) vpua2 193 | , bench "VPU.Vector (Static Veclen)" $ nf (distance_Vector_diff4 vpus1) vpus2 194 | , bench "VPUR.Vector (Static Veclen)" $ nf (distance_Vector_diff4 vprs1) vprs2 195 | , bench "VPS.Vector (Static Veclen)" $ nf (distance_Vector_diff4 vpss1) vpss2 196 | , bench "VPSR.Vector (Static Veclen)" $ nf (distance_Vector_diff4 vpsr1) vpsr2 197 | , bench "ByteArray" $ nf (distance_ByteArray_diff4 ba1) ba2 198 | ] 199 | , bgroup "simd" 200 | [ bgroup "ByteArray" 201 | [ bench "diff1-ByteArray" $ nf (distance_ByteArray_diff1 ba1) ba2 202 | , bench "simd4-ByteArray" $ nf (distance_ByteArray_simd4 ba1) ba2 203 | , bench "simd8-ByteArray" $ nf (distance_ByteArray_simd8 ba1) ba2 204 | , bench "simd8'-ByteArray" $ nf (distance_ByteArray_simd8' ba1) ba2 205 | , bench "simd16-ByteArray" $ nf (distance_ByteArray_simd16 ba1) ba2 206 | , bench "simd16'-ByteArray" $ nf (distance_ByteArray_simd16' ba1) ba2 207 | ] 208 | , bgroup "VU.Vector" 209 | [ bench "diff4-VU.Vector" $ nf (distance_Vector_diff4 vu1) vu2 210 | , bench "simd4-VU.Vector" $ nf (distance_Vector_simd4 vu1) vu2 211 | , bench "simd8-VU.Vector" $ nf (distance_Vector_simd8 vu1) vu2 212 | , bench "simd16-VU.Vector" $ nf (distance_Vector_simd16 vu1) vu2 213 | ] 214 | ] 215 | ] 216 | , bgroup "pairwise" 217 | [ bgroup "diff4" 218 | [ bench "VPU.Vector Automatic (VPU.Vector (Static Veclen))" 219 | $ nf (distance_pairwise distance_Vector_diff4 vpuavpus1) vpuavpus2 220 | , bench "VPU.Vector (Static Numvec) (VPU.Vector (Static Veclen))" 221 | $ nf (distance_pairwise distance_Vector_diff4 vpusvpus1) vpusvpus2 222 | , bench "VPU.Vector (Static Numvec) (VPU.Vector Automatic)" 223 | $ nf (distance_pairwise distance_Vector_diff4 vpusvpua1) vpusvpua2 224 | , bench "VPU.Vector Automatic (VPU.Vector Automatic)" 225 | $ nf (distance_pairwise distance_Vector_diff4 vpuavpua1) vpuavpua2 226 | , bench "VPUR.Vector (Static Numvec) (VPU.Vector (Static Veclen))" 227 | $ nf (distance_pairwise distance_Vector_diff4 vprsvpus1) vprsvpus2 228 | , bench "VPS.Vector (Static Numvec) (VPS.Vector (Static Veclen))" 229 | $ nf (distance_pairwise distance_Vector_diff4 vpssvpss1) vpssvpss2 230 | , bench "VPSR.Vector (Static Numvec) (VPSR.Vector (Static Veclen))" 231 | $ nf (distance_pairwise distance_Vector_diff4 vpsrvpsr1) vpsrvpsr2 232 | , bench "V.Vector (VPU.Vector (Static Veclen))" 233 | $ nf (distance_pairwise distance_Vector_diff4 vvpus1) vvpus2 234 | , bench "V.Vector VU.Vector" 235 | $ nf (distance_pairwise distance_Vector_diff4 vvu1) vvu2 236 | ] 237 | ] 238 | , bgroup "allToAll" 239 | [ bgroup "diff4" 240 | -- [ bench "VPU.Vector (Static Numvec) (VPU.Vector (Static Veclen))" 241 | -- $ nf (distance_allToAll distance_Vector_diff4 vpusvpus1) vpusvpus2 242 | -- , bench "VPU.Vector Automatic (VPU.Vector (Static Veclen))" 243 | -- $ nf (distance_allToAll distance_Vector_diff4 vpuavpus1) vpuavpus2 244 | -- , bench "VPU.Vector (Static Numvec) (VPU.Vector Automatic)" 245 | -- $ nf (distance_allToAll distance_Vector_diff4 vpusvpua1) vpusvpua2 246 | -- , bench "VPS.Vector (Static Numvec) (VPS.Vector (Static Veclen))" 247 | -- $ nf (distance_allToAll distance_Vector_diff4 vpssvpss1) vpssvpss2 248 | -- , bench "VPSR.Vector (Static Numvec) (VPSR.Vector (Static Veclen))" 249 | -- $ nf (distance_allToAll distance_Vector_diff4 vpsrvpsr1) vpsrvpsr2 250 | -- , bench "V.Vector (VPU.Vector (Static Veclen))" 251 | -- $ nf (distance_allToAll distance_Vector_diff4 vvpus1) vvpus2 252 | [ bench "VPU.Vector Automatic (VPU.Vector Automatic)" 253 | $ nf (distance_allToAll distance_Vector_diff4 vpuavpua1) vpuavpua2 254 | , bench "V.Vector VU.Vector" 255 | $ nf (distance_allToAll distance_Vector_diff4 vvu1) vvu2 256 | ] 257 | ] 258 | ] 259 | 260 | ------------------------------------------------------------------------------- 261 | -- test functions 262 | 263 | -- | sums the pairwise distance between elements in the two vectors in time O(n) 264 | distance_pairwise :: 265 | ( VG.Vector v1 (v2 f) 266 | , VG.Vector v2 f 267 | , Floating f 268 | ) => (v2 f -> v2 f -> f) -> v1 (v2 f) -> v1 (v2 f) -> f 269 | distance_pairwise dist vv1 vv2 = go 0 (VG.length vv1-1) 270 | where 271 | go tot (-1) = tot 272 | go tot i = dist (vv1 `VG.unsafeIndex` i) (vv2 `VG.unsafeIndex` i) 273 | + go tot (i-1) 274 | 275 | -- | sums the distance between a point and every point in a vector in time O(n) 276 | distance_oneToAll :: 277 | ( VG.Vector v1 (v2 f) 278 | , VG.Vector v2 f 279 | , Floating f 280 | ) => (v2 f -> v2 f -> f) -> v2 f -> v1 (v2 f) -> f 281 | distance_oneToAll dist v vv = go 0 (VG.length vv-1) 282 | where 283 | go tot (-1) = tot 284 | go tot i = go tot' (i-1) 285 | where 286 | tot' = tot + dist v (vv `VG.unsafeIndex` i) 287 | 288 | -- | sums the distance between every point in vv1 and every point in vv2 in time O(n^2) 289 | distance_allToAll :: 290 | ( VG.Vector v1 (v2 f) 291 | , VG.Vector v2 f 292 | , Floating f 293 | ) => (v2 f -> v2 f -> f) -> v1 (v2 f) -> v1 (v2 f) -> f 294 | distance_allToAll dist vv1 vv2 = go 0 (VG.length vv1-1) 295 | where 296 | go tot (-1) = tot 297 | go tot i = go tot' (i-1) 298 | where 299 | tot' = tot + distance_oneToAll dist (vv1 `VG.unsafeIndex` i) vv2 300 | 301 | --------------------------------------- 302 | 303 | {-# INLINE distance_Vector_diff1 #-} 304 | distance_Vector_diff1 :: (VG.Vector v f, Floating f) => v f -> v f -> f 305 | distance_Vector_diff1 !v1 !v2 = sqrt $ go 0 (VG.length v1-1) 306 | where 307 | go tot (-1) = tot 308 | go tot i = go (tot+diff1*diff1 309 | ) (i-1) 310 | where 311 | diff1 = v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 312 | 313 | {-# INLINE distance_Vector_diff4 #-} 314 | distance_Vector_diff4 :: (VG.Vector v f, Floating f) => v f -> v f -> f 315 | distance_Vector_diff4 !v1 !v2 = sqrt $ go 0 (VG.length v1-1) 316 | where 317 | go tot (-1) = tot 318 | go tot i = go (tot+diff1*diff1 319 | +diff2*diff2 320 | +diff3*diff3 321 | +diff4*diff4 322 | ) (i-4) 323 | where 324 | diff1 = v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 325 | diff2 = v1 `VG.unsafeIndex` (i-1)-v2 `VG.unsafeIndex` (i-1) 326 | diff3 = v1 `VG.unsafeIndex` (i-2)-v2 `VG.unsafeIndex` (i-2) 327 | diff4 = v1 `VG.unsafeIndex` (i-3)-v2 `VG.unsafeIndex` (i-3) 328 | 329 | {-# INLINE distance_Vector_simd4 #-} 330 | distance_Vector_simd4 :: (VG.Vector v Float) => v Float -> v Float -> Float 331 | distance_Vector_simd4 !v1 !v2 = sqrt $ sum4 (go zeros (VG.length v1-1)) 332 | where 333 | zeros = broadcastFloatX4# (unFloat 0) 334 | 335 | go tot (-1) = tot 336 | go tot i = go tot' (i-4) 337 | where 338 | tot' = plusFloatX4# tot sqrarr 339 | sqrarr = timesFloatX4# minarr minarr 340 | minarr = minusFloatX4# arr1 arr2 341 | 342 | arr1 = packFloatX4# (# e1_1, e1_2, e1_3, e1_4 #) 343 | arr2 = packFloatX4# (# e2_1, e2_2, e2_3, e2_4 #) 344 | 345 | e1_1 = unFloat $ v1 `VG.unsafeIndex` i 346 | e1_2 = unFloat $ v1 `VG.unsafeIndex` (i-1) 347 | e1_3 = unFloat $ v1 `VG.unsafeIndex` (i-2) 348 | e1_4 = unFloat $ v1 `VG.unsafeIndex` (i-3) 349 | e2_1 = unFloat $ v1 `VG.unsafeIndex` i 350 | e2_2 = unFloat $ v1 `VG.unsafeIndex` (i-1) 351 | e2_3 = unFloat $ v1 `VG.unsafeIndex` (i-2) 352 | e2_4 = unFloat $ v1 `VG.unsafeIndex` (i-3) 353 | 354 | {-# INLINE distance_Vector_simd8 #-} 355 | distance_Vector_simd8 :: (VG.Vector v Float) => v Float -> v Float -> Float 356 | distance_Vector_simd8 !v1 !v2 = sqrt $ sum8 (go zeros (VG.length v1-1)) 357 | where 358 | zeros = broadcastFloatX8# (unFloat 0) 359 | 360 | go tot (-1) = tot 361 | go tot i = go tot' (i-8) 362 | where 363 | tot' = plusFloatX8# tot sqrarr 364 | sqrarr = timesFloatX8# minarr minarr 365 | minarr = minusFloatX8# arr1 arr2 366 | 367 | arr1 = packFloatX8# (# e1_1, e1_2, e1_3, e1_4 368 | , e1_5, e1_6, e1_7, e1_8 #) 369 | arr2 = packFloatX8# (# e2_1, e2_2, e2_3, e2_4 370 | , e2_5, e2_6, e2_7, e2_8 #) 371 | 372 | e1_1 = unFloat $ v1 `VG.unsafeIndex` i 373 | e1_2 = unFloat $ v1 `VG.unsafeIndex` (i-1) 374 | e1_3 = unFloat $ v1 `VG.unsafeIndex` (i-2) 375 | e1_4 = unFloat $ v1 `VG.unsafeIndex` (i-3) 376 | e1_5 = unFloat $ v1 `VG.unsafeIndex` (i-4) 377 | e1_6 = unFloat $ v1 `VG.unsafeIndex` (i-5) 378 | e1_7 = unFloat $ v1 `VG.unsafeIndex` (i-6) 379 | e1_8 = unFloat $ v1 `VG.unsafeIndex` (i-7) 380 | 381 | e2_1 = unFloat $ v2 `VG.unsafeIndex` i 382 | e2_2 = unFloat $ v2 `VG.unsafeIndex` (i-1) 383 | e2_3 = unFloat $ v2 `VG.unsafeIndex` (i-2) 384 | e2_4 = unFloat $ v2 `VG.unsafeIndex` (i-3) 385 | e2_5 = unFloat $ v2 `VG.unsafeIndex` (i-4) 386 | e2_6 = unFloat $ v2 `VG.unsafeIndex` (i-5) 387 | e2_7 = unFloat $ v2 `VG.unsafeIndex` (i-6) 388 | e2_8 = unFloat $ v2 `VG.unsafeIndex` (i-7) 389 | 390 | {-# INLINE distance_Vector_simd16 #-} 391 | distance_Vector_simd16 :: (VG.Vector v Float) => v Float -> v Float -> Float 392 | distance_Vector_simd16 !v1 !v2 = sqrt $ sum16 (go zeros (VG.length v1-1)) 393 | where 394 | zeros = broadcastFloatX16# (unFloat 0) 395 | 396 | go tot (-1) = tot 397 | go tot i = go tot' (i-16) 398 | where 399 | tot' = plusFloatX16# tot sqrarr 400 | sqrarr = timesFloatX16# minarr minarr 401 | minarr = minusFloatX16# arr1 arr2 402 | 403 | arr1 = packFloatX16# (# e1_1, e1_2, e1_3, e1_4 404 | , e1_5, e1_6, e1_7, e1_8 405 | , e1_9, e1_10, e1_11, e1_12 406 | , e1_13, e1_14, e1_15, e1_16 #) 407 | arr2 = packFloatX16# (# e2_1, e2_2, e2_3, e2_4 408 | , e2_5, e2_6, e2_7, e2_8 409 | , e2_9, e2_10, e2_11, e2_12 410 | , e2_13, e2_14, e2_15, e2_16 #) 411 | 412 | e1_1 = unFloat $ v1 `VG.unsafeIndex` i 413 | e1_2 = unFloat $ v1 `VG.unsafeIndex` (i-1) 414 | e1_3 = unFloat $ v1 `VG.unsafeIndex` (i-2) 415 | e1_4 = unFloat $ v1 `VG.unsafeIndex` (i-3) 416 | e1_5 = unFloat $ v1 `VG.unsafeIndex` (i-4) 417 | e1_6 = unFloat $ v1 `VG.unsafeIndex` (i-5) 418 | e1_7 = unFloat $ v1 `VG.unsafeIndex` (i-6) 419 | e1_8 = unFloat $ v1 `VG.unsafeIndex` (i-7) 420 | e1_9 = unFloat $ v1 `VG.unsafeIndex` (i-8) 421 | e1_10 = unFloat $ v1 `VG.unsafeIndex` (i-9) 422 | e1_11 = unFloat $ v1 `VG.unsafeIndex` (i-10) 423 | e1_12 = unFloat $ v1 `VG.unsafeIndex` (i-11) 424 | e1_13 = unFloat $ v1 `VG.unsafeIndex` (i-12) 425 | e1_14 = unFloat $ v1 `VG.unsafeIndex` (i-13) 426 | e1_15 = unFloat $ v1 `VG.unsafeIndex` (i-14) 427 | e1_16 = unFloat $ v1 `VG.unsafeIndex` (i-15) 428 | 429 | e2_1 = unFloat $ v2 `VG.unsafeIndex` i 430 | e2_2 = unFloat $ v2 `VG.unsafeIndex` (i-1) 431 | e2_3 = unFloat $ v2 `VG.unsafeIndex` (i-2) 432 | e2_4 = unFloat $ v2 `VG.unsafeIndex` (i-3) 433 | e2_5 = unFloat $ v2 `VG.unsafeIndex` (i-4) 434 | e2_6 = unFloat $ v2 `VG.unsafeIndex` (i-5) 435 | e2_7 = unFloat $ v2 `VG.unsafeIndex` (i-6) 436 | e2_8 = unFloat $ v2 `VG.unsafeIndex` (i-7) 437 | e2_9 = unFloat $ v2 `VG.unsafeIndex` (i-8) 438 | e2_10 = unFloat $ v2 `VG.unsafeIndex` (i-9) 439 | e2_11 = unFloat $ v2 `VG.unsafeIndex` (i-10) 440 | e2_12 = unFloat $ v2 `VG.unsafeIndex` (i-11) 441 | e2_13 = unFloat $ v2 `VG.unsafeIndex` (i-12) 442 | e2_14 = unFloat $ v2 `VG.unsafeIndex` (i-13) 443 | e2_15 = unFloat $ v2 `VG.unsafeIndex` (i-14) 444 | e2_16 = unFloat $ v2 `VG.unsafeIndex` (i-15) 445 | 446 | --------------------------------------- 447 | 448 | list2ByteArray xs = runST $ do 449 | arr <- newAlignedPinnedByteArray (2^(16::Int)) (veclen*4) 450 | forM (zip [0..] xs) $ \(i,x) -> do 451 | writeByteArray arr i x 452 | unsafeFreezeByteArray arr 453 | 454 | {-# INLINE distance_ByteArray_diff1 #-} 455 | distance_ByteArray_diff1 :: ByteArray -> ByteArray -> NumType 456 | distance_ByteArray_diff1 !a1 !a2 = sqrt $ go 0 (veclen-1) 457 | where 458 | go tot (-1) = tot 459 | go tot i = go (tot+diff1*diff1 460 | ) (i-1) 461 | where 462 | diff1 = (a1 `indexByteArray` i)-(a2 `indexByteArray` i) 463 | 464 | {-# INLINE distance_ByteArray_diff4 #-} 465 | distance_ByteArray_diff4 :: ByteArray -> ByteArray -> NumType 466 | distance_ByteArray_diff4 !a1 !a2 = sqrt $ go 0 (veclen-1) 467 | where 468 | go tot (-1) = tot 469 | go tot i = go (tot+diff1*diff1 470 | +diff2*diff2 471 | +diff3*diff3 472 | +diff4*diff4 473 | ) (i-4) 474 | where 475 | diff1 = (a1 `indexByteArray` i)-(a2 `indexByteArray` i) 476 | diff2 = (a1 `indexByteArray` (i-1))-(a2 `indexByteArray` (i-1)) 477 | diff3 = (a1 `indexByteArray` (i-3))-(a2 `indexByteArray` (i-3)) 478 | diff4 = (a1 `indexByteArray` (i-4))-(a2 `indexByteArray` (i-4)) 479 | 480 | {-# INLINE distance_ByteArray_simd4 #-} 481 | distance_ByteArray_simd4 :: ByteArray -> ByteArray -> Float 482 | distance_ByteArray_simd4 !(ByteArray ba1#) !(ByteArray ba2#) = sqrt $ sum4 (go zeros (veclen-1)) 483 | where 484 | zeros = broadcastFloatX4# (unFloat 0) 485 | 486 | go tot (-1) = tot 487 | go tot i = go tot' (i-4) 488 | where 489 | tot' = plusFloatX4# tot sqrarr 490 | sqrarr = timesFloatX4# minarr minarr 491 | minarr = minusFloatX4# arr1 arr2 492 | 493 | arr1 = indexFloatArrayAsFloatX4# ba1# (unInt i) 494 | arr2 = indexFloatArrayAsFloatX4# ba2# (unInt i) 495 | 496 | {-# INLINE distance_ByteArray_simd8 #-} 497 | distance_ByteArray_simd8 :: ByteArray -> ByteArray -> Float 498 | distance_ByteArray_simd8 !(ByteArray ba1#) !(ByteArray ba2#) = sqrt $ sum8 (go zeros (veclen-1)) 499 | where 500 | zeros = broadcastFloatX8# (unFloat 0) 501 | 502 | go tot (-1) = tot 503 | go tot i = go tot' (i-8) 504 | where 505 | tot' = plusFloatX8# tot sqrarr 506 | sqrarr = timesFloatX8# minarr minarr 507 | minarr = minusFloatX8# arr1 arr2 508 | 509 | arr1 = indexFloatArrayAsFloatX8# ba1# (unInt i) 510 | arr2 = indexFloatArrayAsFloatX8# ba2# (unInt i) 511 | 512 | {-# INLINE distance_ByteArray_simd8' #-} 513 | distance_ByteArray_simd8' :: ByteArray -> ByteArray -> Float 514 | distance_ByteArray_simd8' !(ByteArray ba1#) !(ByteArray ba2#) = sqrt $ sum8' (go zeros (veclen-1)) 515 | where 516 | zeros = broadcastFloatX8# (unFloat 0) 517 | 518 | go tot (-1) = tot 519 | go tot i = go tot' (i-8) 520 | where 521 | tot' = plusFloatX8# tot sqrarr 522 | sqrarr = timesFloatX8# minarr minarr 523 | minarr = minusFloatX8# arr1 arr2 524 | 525 | arr1 = indexFloatArrayAsFloatX8# ba1# (unInt i) 526 | arr2 = indexFloatArrayAsFloatX8# ba2# (unInt i) 527 | 528 | {-# INLINE distance_ByteArray_simd16 #-} 529 | distance_ByteArray_simd16 :: ByteArray -> ByteArray -> Float 530 | distance_ByteArray_simd16 !(ByteArray ba1#) !(ByteArray ba2#) = sqrt $ sum16 (go zeros (veclen-1)) 531 | where 532 | zeros = broadcastFloatX16# (unFloat 0) 533 | 534 | go tot (-1) = tot 535 | go tot i = go tot' (i-16) 536 | where 537 | tot' = plusFloatX16# tot sqrarr 538 | sqrarr = timesFloatX16# minarr minarr 539 | minarr = minusFloatX16# arr1 arr2 540 | 541 | arr1 = indexFloatArrayAsFloatX16# ba1# (unInt i) 542 | arr2 = indexFloatArrayAsFloatX16# ba2# (unInt i) 543 | 544 | {-# INLINE distance_ByteArray_simd16' #-} 545 | distance_ByteArray_simd16' :: ByteArray -> ByteArray -> Float 546 | distance_ByteArray_simd16' !(ByteArray ba1#) !(ByteArray ba2#) = sqrt $ sum16' (go zeros (veclen-1)) 547 | where 548 | zeros = broadcastFloatX16# (unFloat 0) 549 | 550 | go tot (-1) = tot 551 | go tot i = go tot' (i-16) 552 | where 553 | tot' = plusFloatX16# tot sqrarr 554 | sqrarr = timesFloatX16# minarr minarr 555 | minarr = minusFloatX16# arr1 arr2 556 | 557 | arr1 = indexFloatArrayAsFloatX16# ba1# (unInt i) 558 | arr2 = indexFloatArrayAsFloatX16# ba2# (unInt i) 559 | 560 | ------- 561 | 562 | {-# INLINE unFloat #-} 563 | unFloat :: Float -> Float# 564 | unFloat (F# f) = f 565 | 566 | {-# INLINE unInt #-} 567 | unInt :: Int -> Int# 568 | unInt (I# i) = i 569 | 570 | {-# INLINE sum4 #-} 571 | sum4 :: FloatX4# -> Float 572 | sum4 arr = F# r1 + F# r2 + F# r3 + F# r4 573 | where 574 | (# r1, r2, r3, r4 #) = unpackFloatX4# arr 575 | 576 | {-# INLINE sum8 #-} 577 | sum8 :: FloatX8# -> Float 578 | sum8 arr = F# r1 + F# r2 + F# r3 + F# r4 579 | + F# r5 + F# r6 + F# r7 + F# r8 580 | where 581 | (# r1, r2, r3, r4, r5, r6, r7, r8 #) = unpackFloatX8# arr 582 | 583 | {-# INLINE sum8' #-} 584 | sum8' :: FloatX8# -> Float 585 | sum8' arr = sum4 a1 + sum4 a2 586 | where 587 | a1 = packFloatX4# (# r1, r2, r3, r4 #) 588 | a2 = packFloatX4# (# r5, r6, r7, r8 #) 589 | (# r1, r2, r3, r4, r5, r6, r7, r8 #) = unpackFloatX8# arr 590 | 591 | {-# INLINE sum16 #-} 592 | sum16 :: FloatX16# -> Float 593 | sum16 arr = F# r1 + F# r2 + F# r3 + F# r4 594 | + F# r5 + F# r6 + F# r7 + F# r8 595 | + F# r9 + F# r10+ F# r11+ F# r12 596 | + F# r13+ F# r14+ F# r15+ F# r16 597 | where 598 | (# r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13, r14, r15, r16 #) = 599 | unpackFloatX16# arr 600 | 601 | {-# INLINE sum16' #-} 602 | sum16' :: FloatX16# -> Float 603 | sum16' arr = sum8' a1 + sum8' a2 604 | where 605 | a1 = packFloatX8# (# r1, r2, r3, r4, r5, r6, r7, r8 #) 606 | a2 = packFloatX8# (# r9, r10, r11, r12, r13, r14, r15, r16 #) 607 | (# r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13, r14, r15, r16 #) = 608 | unpackFloatX16# arr 609 | -------------------------------------------------------------------------------- /examples/plots/mkplots.gnu: -------------------------------------------------------------------------------- 1 | set terminal png enhanced size 600,400 2 | 3 | #unset key 4 | set key top left 5 | #set key outside bottom center horizontal 6 | set ytics nomirror 7 | set xtics nomirror 8 | 9 | set xlabel "value of p" 10 | set ylabel "running time (seconds)" 11 | set border 3 12 | 13 | set style data histogram 14 | set style histogram cluster gap 1 15 | set style fill solid border -1 16 | 17 | set output "supercomp-lebesgue.png" 18 | set title "run times of L_p nearest neighbor calculation\n(solid columns compiled with fast-math, hashed columns without)" 19 | #set title "run times of L_p nearest neighbor calculation" 20 | plot 'supercomp-lebesgue.dat' using 2:xtic(1) lt 1 lw 1 lc rgb '#007700' title col,\ 21 | 'supercomp-lebesgue.dat' using 5:xtic(1) lt 1 lw 1 lc rgb '#007700' title col fillstyle pattern 6,\ 22 | 'supercomp-lebesgue.dat' using 3:xtic(1) lt 1 lw 1 lc rgb '#770000' title col,\ 23 | 'supercomp-lebesgue.dat' using 6:xtic(1) lt 1 lw 1 lc rgb '#770000' title col fillstyle pattern 6,\ 24 | 'supercomp-lebesgue.dat' using 4:xtic(1) lt 1 lw 1 lc rgb '#000077' title col,\ 25 | 'supercomp-lebesgue.dat' using 7:xtic(1) lt 1 lw 1 lc rgb '#000077' title col fillstyle pattern 6 26 | 27 | 28 | set xlabel "number of datapoints (i.e. size of outer vector)" 29 | set style lines 1 30 | #set log x 31 | #set log y 32 | set output "unboxed_vs_boxed.png" 33 | set title "computing the nearest neighbor of every data point" 34 | plot 'unboxed.dat' using 2:3 lt 1 lw 2 lc rgb '#007700' title col with lines,\ 35 | 'unboxed.dat' using 2:4 lt 1 lw 2 lc rgb '#770000' title col with lines 36 | -------------------------------------------------------------------------------- /examples/plots/supercomp-lebesgue.dat: -------------------------------------------------------------------------------- 1 | p Static RunTime "hand opt" "" "" "" 2 | 1 0.141 4.16 0.140 0.143 4.28 0.138 3 | 2 0.038 4.19 0.039 0.038 4.30 0.038 4 | 3 0.270 6.16 0.273 2.43 6.25 0.274 5 | 4 0.055 6.16 0.054 2.43 6.25 0.055 6 | 33.5 1.82 5.49 1.83 1.87 5.69 1.80 7 | 1.612e7 1.82 5.54 1.84 1.83 5.67 1.81 8 | -------------------------------------------------------------------------------- /examples/plots/unboxed.dat: -------------------------------------------------------------------------------- 1 | Veclen Numvec UnboxedUnboxed BoxedUnboxed 2 | 400 100 0.00508 0.00528 3 | 400 200 0.02050 0.02138 4 | 400 400 0.08304 0.09203 5 | 400 800 0.328 0.466 6 | 400 1600 1.385 2.17 7 | 400 2000 2.25 3.4 8 | 400 3200 5.95 8.53 9 | 400 4000 9.6 13.5 10 | 400 5000 14.9 20.9 11 | 400 6400 24.5 35.5 12 | 400 8000 38.8 54.5 13 | 400 10000 56.7 85 14 | 400 11000 74.0 104 15 | 400 12800 101.9 142 16 | -------------------------------------------------------------------------------- /examples/supercomp-lebesgue.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O2 -fllvm -mavx512f -optlo -O3 -optlo -enable-unsafe-fp-math #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE UnboxedTuples #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | {-# LANGUAGE ConstraintKinds #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | -- | This example performs a number of criterion benchmarks calculating various 19 | -- Lp (Lebesgue) metrics. The variable p is specified at the type level. 20 | module Main 21 | where 22 | 23 | import Control.Category 24 | import Control.DeepSeq 25 | import Control.Monad 26 | import Control.Monad.Random 27 | import qualified Criterion.Config as Criterion 28 | import Criterion.Main 29 | import Data.Monoid 30 | import qualified Data.Vector.Generic as VG 31 | import qualified Data.Vector.Generic.Mutable as VGM 32 | import qualified Data.Params.Vector.Unboxed as VPU 33 | import qualified Data.Params.Vector.UnboxedRaw as VPUR 34 | import qualified Data.Params.Vector.Storable as VPS 35 | import qualified Data.Params.Vector.Storable as VPSR 36 | import qualified Data.Vector.Unboxed as VU 37 | import qualified Data.Vector as V 38 | import Prelude hiding ((.),id) 39 | 40 | import GHC.Prim 41 | import GHC.Float 42 | import GHC.Base (Int(..)) 43 | import Language.Haskell.TH hiding (reify) 44 | import Language.Haskell.TH.Syntax hiding (reify) 45 | import qualified Language.Haskell.TH as TH 46 | 47 | import Data.Params 48 | import Data.Params.Frac 49 | import Data.Params.PseudoPrim 50 | import Data.Params.Vector 51 | import Numeric.FastMath 52 | 53 | ------------------------------------------------------------------------------- 54 | 55 | newtype Lebesgue (p::Config Frac) (vec :: * -> *) elem = Lebesgue (vec elem) 56 | deriving (Read,Show,Eq,Ord) 57 | 58 | mkParamClass_Config "p" (ConT $ mkName "Float" ) 59 | mkHasDictionary_Config "p" (ConT $ mkName "Float" ) 60 | mkParamInstance "p" (ConT $ mkName "Float" ) ''Lebesgue 61 | mkReifiableConstraint "p" 62 | mkTypeLens_Config "p" 63 | mkViewParam_Config "p" ''Lebesgue 64 | mkApplyConstraint_Config "p" ''Lebesgue 65 | 66 | mkTypeLens_Star "elem" 67 | mkViewParam_Star "elem" ''Lebesgue 68 | mkApplyConstraint_Star "elem" ''Lebesgue 69 | mkHasDictionary_Star "elem" 70 | mkParamClass_Star "elem" 71 | 72 | mkParamClass_Star "vec" 73 | mkTypeLens_Star "vec" 74 | mkHasDictionary_Star "vec" 75 | 76 | instance 77 | ( ViewParam p1 (vec elem) 78 | ) => ViewParam (Param_vec p1) (Lebesgue p vec elem) 79 | where 80 | viewParam _ _ = viewParam (undefined::TypeLens Base p1) (undefined :: vec elem) 81 | 82 | type instance ApplyConstraint_GetConstraint (Param_vec p) 83 | = ApplyConstraint_GetConstraint p 84 | 85 | type instance ApplyConstraint_GetType (Param_vec p1) (Lebesgue p vec elem) 86 | = ApplyConstraint_GetType p1 (Lebesgue p vec elem) 87 | 88 | v = VG.fromList [1..10] :: Lebesgue (Static (2/1)) (VPU.Vector Automatic) Float 89 | v' = VG.fromList [1..10] :: Lebesgue (Static (2/1)) (VPU.Vector (Static 10)) Float 90 | 91 | ------------------- 92 | 93 | instance NFData (vec elem) => NFData (Lebesgue p vec elem) where 94 | rnf (Lebesgue v) = rnf v 95 | 96 | instance PseudoPrim (vec elem) => PseudoPrim (Lebesgue p vec elem) where 97 | newtype PseudoPrimInfo (Lebesgue p vec elem) 98 | = PseudoPrimInfo_ManyParams (PseudoPrimInfo (vec elem)) 99 | pp_sizeOf# (PseudoPrimInfo_ManyParams ppi) = pp_sizeOf# ppi 100 | pp_alignment# (PseudoPrimInfo_ManyParams ppi) = pp_alignment# ppi 101 | pp_indexByteArray# (PseudoPrimInfo_ManyParams ppi) arr# i# 102 | = Lebesgue $ pp_indexByteArray# ppi arr# i# 103 | pp_readByteArray# (PseudoPrimInfo_ManyParams ppi) marr# i# s# 104 | = case pp_readByteArray# ppi marr# i# s# of 105 | (# s, d #) -> (# s, Lebesgue d #) 106 | pp_writeByteArray# (PseudoPrimInfo_ManyParams ppi) marr# i# (Lebesgue d) s# 107 | = pp_writeByteArray# ppi marr# i# d s# 108 | seqInfo (Lebesgue d) = seqInfo d 109 | emptyInfo = PseudoPrimInfo_ManyParams $ emptyInfo 110 | {-# INLINE pp_sizeOf# #-} 111 | {-# INLINE pp_alignment# #-} 112 | {-# INLINE pp_indexByteArray# #-} 113 | {-# INLINE pp_readByteArray# #-} 114 | {-# INLINE pp_writeByteArray# #-} 115 | {-# INLINE seqInfo #-} 116 | {-# INLINE emptyInfo #-} 117 | 118 | --------------------------------------- 119 | -- Vector instances 120 | 121 | instance VG.Vector vec elem => VG.Vector (Lebesgue p vec) elem where 122 | {-# INLINE basicUnsafeFreeze #-} 123 | {-# INLINE basicUnsafeThaw #-} 124 | {-# INLINE basicLength #-} 125 | {-# INLINE basicUnsafeSlice #-} 126 | {-# INLINE basicUnsafeIndexM #-} 127 | {-# INLINE basicUnsafeCopy #-} 128 | {-# INLINE elemseq #-} 129 | basicUnsafeFreeze (MLebesgue v) = liftM Lebesgue $ VG.basicUnsafeFreeze v 130 | basicUnsafeThaw (Lebesgue v) = liftM MLebesgue $ VG.basicUnsafeThaw v 131 | basicLength (Lebesgue v) = VG.basicLength v 132 | basicUnsafeSlice s t (Lebesgue v) = Lebesgue $ VG.basicUnsafeSlice s t v 133 | basicUnsafeIndexM (Lebesgue v) i = VG.basicUnsafeIndexM v i 134 | basicUnsafeCopy (MLebesgue vm) (Lebesgue v) = VG.basicUnsafeCopy vm v 135 | elemseq (Lebesgue v) a b = VG.elemseq v a b 136 | 137 | newtype MLebesgue (p::Config Frac) v s a = MLebesgue ( v s a ) 138 | 139 | instance VGM.MVector v a => VGM.MVector (MLebesgue p v) a where 140 | {-# INLINE basicLength #-} 141 | {-# INLINE basicUnsafeSlice #-} 142 | {-# INLINE basicOverlaps #-} 143 | {-# INLINE basicUnsafeNew #-} 144 | {-# INLINE basicUnsafeReplicate #-} 145 | {-# INLINE basicUnsafeRead #-} 146 | {-# INLINE basicUnsafeWrite #-} 147 | basicLength (MLebesgue v) = VGM.basicLength v 148 | basicUnsafeSlice s t (MLebesgue v) = MLebesgue $ VGM.basicUnsafeSlice s t v 149 | basicOverlaps (MLebesgue v1) (MLebesgue v2) = VGM.basicOverlaps v1 v2 150 | basicUnsafeNew p = liftM MLebesgue $ VGM.basicUnsafeNew p 151 | basicUnsafeReplicate i a = liftM MLebesgue $ VGM.basicUnsafeReplicate i a 152 | basicUnsafeRead (MLebesgue v) i = VGM.basicUnsafeRead v i 153 | basicUnsafeWrite (MLebesgue v) i a = VGM.basicUnsafeWrite v i a 154 | 155 | type instance VG.Mutable (Lebesgue p v) = MLebesgue p (VG.Mutable v) 156 | 157 | --------------------------------------- 158 | -- the Lebesgue distance 159 | 160 | lp_distance :: 161 | ( VG.Vector vec elem 162 | , Floating elem 163 | , elem ~ Float 164 | , ViewParam Param_p (Lebesgue p vec elem) 165 | ) => Lebesgue p vec elem -> Lebesgue p vec elem -> elem 166 | lp_distance !v1 !v2 = (go 0 (VG.length v1-1))**(1/p) 167 | where 168 | p = viewParam _p v1 169 | 170 | go tot (-1) = tot 171 | go tot i = go (tot+diff1**p) (i-1) 172 | where 173 | diff1 = abs $ v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 174 | 175 | l1_distance :: (VG.Vector v f, Floating f) => v f -> v f -> f 176 | l1_distance !v1 !v2 = go 0 (VG.length v1-1) 177 | where 178 | go tot (-1) = tot 179 | go tot i = go (tot+diff1) (i-1) 180 | where 181 | diff1 = abs $ v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 182 | 183 | l1_distance' :: (VG.Vector v f, Floating f) => v f -> v f -> f 184 | l1_distance' !v1 !v2 = go 0 (VG.length v1-1) 185 | where 186 | go tot (-1) = tot 187 | go tot i = go (tot+(sqrt $ diff1*diff1)) (i-1) 188 | where 189 | diff1 = v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 190 | 191 | l2_distance :: (VG.Vector v f, Floating f) => v f -> v f -> f 192 | l2_distance !v1 !v2 = sqrt $ go 0 (VG.length v1-1) 193 | where 194 | go tot (-1) = tot 195 | go tot i = go (tot+diff1*diff1) (i-1) 196 | where 197 | diff1 = v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 198 | 199 | l3_distance :: (VG.Vector v f, Floating f) => v f -> v f -> f 200 | l3_distance !v1 !v2 = (go 0 (VG.length v1-1))**(1/3) 201 | where 202 | go tot (-1) = tot 203 | go tot i = go (tot+diff1*diff1*diff1) (i-1) 204 | where 205 | diff1 = abs $ v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 206 | 207 | l4_distance :: (VG.Vector v f, Floating f) => v f -> v f -> f 208 | l4_distance !v1 !v2 = sqrt $ sqrt $ go 0 (VG.length v1-1) 209 | where 210 | go tot (-1) = tot 211 | go tot i = go (tot+diff1*diff1*diff1*diff1) (i-1) 212 | where 213 | diff1 = abs $ v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 214 | l77_distance :: (VG.Vector v f, Floating f) => v f -> v f -> f 215 | l77_distance !v1 !v2 = (go 0 (VG.length v1-1))**(2/77) 216 | where 217 | go tot (-1) = tot 218 | go tot i = go (tot+diff1**(77/2)) (i-1) 219 | where 220 | diff1 = abs $ v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 221 | 222 | l79_distance :: (VG.Vector v f, Floating f) => v f -> v f -> f 223 | l79_distance !v1 !v2 = (go 0 (VG.length v1-1))**(2/79) 224 | where 225 | go tot (-1) = tot 226 | go tot i = go (tot+diff1**(1651110466/1024)) (i-1) 227 | where 228 | diff1 = abs $ v1 `VG.unsafeIndex` i-v2 `VG.unsafeIndex` i 229 | 230 | ------------------------------------------------------------------------------- 231 | -- criterion tests 232 | 233 | -- | size of each vector to test; must be divisible by 4 234 | type Veclen = 16 235 | veclen = intparam (Proxy::Proxy Veclen) 236 | 237 | -- | number of vectors in 2d tests 238 | type Numvec = 1000 239 | numvec = intparam (Proxy::Proxy Numvec) 240 | 241 | -- | criterion configuration parameters 242 | critConfig = Criterion.defaultConfig 243 | { Criterion.cfgPerformGC = Criterion.ljust True 244 | , Criterion.cfgSamples = Criterion.ljust 30 245 | -- , cfgSummaryFile = ljust $ "results/summary-"++show veclen++"-"++show numvec++".csv" 246 | -- , cfgReport = ljust "report.html" 247 | } 248 | 249 | mkRuleFrac 1 250 | mkRuleFrac 2 251 | mkRuleFrac 3 252 | mkRuleFrac 4 253 | mkRuleFrac (77/2) 254 | 255 | ------------------------------------------------------------------------------- 256 | -- main 257 | 258 | main = do 259 | 260 | ----------------------------------- 261 | -- initialize single vectors 262 | 263 | putStrLn "constructing single vectors" 264 | 265 | let dimL1 :: [Float] = evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 1) 266 | dimL2 :: [Float] = evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 2) 267 | 268 | ----------------------------------- 269 | -- initialize 2d vectors 270 | 271 | putStrLn "constructing 2d vectors of vectors" 272 | 273 | let dimLL1 :: [[Float]] = 274 | [ evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen i) | i <- [1..numvec]] 275 | dimLL2 :: [[Float]] = 276 | [ evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen i) | i <- [2..numvec+1]] 277 | 278 | let vvl1a = VG.fromList $ map VG.fromList dimLL1 279 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (1/1)) (VPU.Vector (Static Veclen)) Float) 280 | vvl1b = VG.fromList $ map VG.fromList dimLL2 281 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (1/1)) (VPU.Vector (Static Veclen)) Float) 282 | 283 | let vvl2b = VG.fromList $ map VG.fromList dimLL1 284 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (2/1)) (VPU.Vector (Static Veclen)) Float) 285 | vvl2a = VG.fromList $ map VG.fromList dimLL2 286 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (2/1)) (VPU.Vector (Static Veclen)) Float) 287 | 288 | let vvl3b = VG.fromList $ map VG.fromList dimLL1 289 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (3/1)) (VPU.Vector (Static Veclen)) Float) 290 | vvl3a = VG.fromList $ map VG.fromList dimLL2 291 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (3/1)) (VPU.Vector (Static Veclen)) Float) 292 | 293 | let vvl4b = VG.fromList $ map VG.fromList dimLL1 294 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (4/1)) (VPU.Vector (Static Veclen)) Float) 295 | vvl4a = VG.fromList $ map VG.fromList dimLL2 296 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (4/1)) (VPU.Vector (Static Veclen)) Float) 297 | 298 | let vvl77b = VG.fromList $ map VG.fromList dimLL1 299 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (77/2)) (VPU.Vector (Static Veclen)) Float) 300 | vvl77a = VG.fromList $ map VG.fromList dimLL2 301 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (77/2)) (VPU.Vector (Static Veclen)) Float) 302 | 303 | let vvl79b = VG.fromList $ map VG.fromList dimLL1 304 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (1651110466/1024)) (VPU.Vector (Static Veclen)) Float) 305 | vvl79a = VG.fromList $ map VG.fromList dimLL2 306 | :: VPU.Vector (Static Numvec) (Lebesgue (Static (1651110466/1024)) (VPU.Vector (Static Veclen)) Float) 307 | 308 | let vvlna = VG.fromList $ map VG.fromList dimLL1 309 | :: VPU.Vector (Static Numvec) (Lebesgue RunTime (VPU.Vector (Static Veclen)) Float) 310 | vvlnb = VG.fromList $ map VG.fromList dimLL2 311 | :: VPU.Vector (Static Numvec) (Lebesgue RunTime (VPU.Vector (Static Veclen)) Float) 312 | 313 | deepseq vvl1a $ deepseq vvl1b $ return () 314 | deepseq vvl2a $ deepseq vvl2b $ return () 315 | deepseq vvl3a $ deepseq vvl3b $ return () 316 | deepseq vvl4a $ deepseq vvl4b $ return () 317 | deepseq vvl77a $ deepseq vvl77b $ return () 318 | deepseq vvl79a $ deepseq vvl79b $ return () 319 | deepseq vvlna $ deepseq vvlnb $ return () 320 | 321 | ----------------------------------- 322 | -- tests 323 | 324 | putStrLn "starting criterion" 325 | 326 | let test i = mkApWith1Param 327 | (Proxy::Proxy (VPU.Vector 328 | (Static Numvec) 329 | (Lebesgue RunTime (VPU.Vector (Static Veclen)) Float))) 330 | (Proxy::Proxy Float) 331 | (_elem._p) 332 | i 333 | (distance_allToAll lp_distance vvlna) 334 | 335 | defaultMainWith critConfig (return ()) 336 | [ bgroup "Static" 337 | [ bench "(1/1)" $ nf (distance_allToAll lp_distance vvl1a) vvl1b 338 | , bench "(2/1)" $ nf (distance_allToAll lp_distance vvl2a) vvl2b 339 | , bench "(3/1)" $ nf (distance_allToAll lp_distance vvl3a) vvl3b 340 | , bench "(4/1)" $ nf (distance_allToAll lp_distance vvl4a) vvl4b 341 | , bench "(77/2)" $ nf (distance_allToAll lp_distance vvl77a) vvl77b 342 | , bench "(1651110466/1024)" $ nf (distance_allToAll lp_distance vvl79a) vvl79b 343 | ] 344 | , bgroup "RunTime" 345 | [ bench "(1/1)" $ nfWith1Constraint (test 1) vvlnb 346 | , bench "(2/1)" $ nfWith1Constraint (test 2) vvlnb 347 | , bench "(3/1)" $ nfWith1Constraint (test 3) vvlnb 348 | , bench "(4/1)" $ nfWith1Constraint (test 4) vvlnb 349 | , bench "(77/2)" $ nfWith1Constraint (test $ 77/2) vvlnb 350 | , bench "(1651110466/1024)" $ nfWith1Constraint (test $ 1651110466/1024) vvlnb 351 | ] 352 | , bgroup "HandOpt" 353 | [ bench "(1/1)" $ nf (distance_allToAll l1_distance vvlna) vvlnb 354 | , bench "(1/1)'" $ nf (distance_allToAll l1_distance' vvlna) vvlnb 355 | , bench "(2/1)" $ nf (distance_allToAll l2_distance vvlna) vvlnb 356 | , bench "(3/1)" $ nf (distance_allToAll l3_distance vvlna) vvlnb 357 | , bench "(4/1)" $ nf (distance_allToAll l4_distance vvlna) vvlnb 358 | , bench "(77/2)" $ nf (distance_allToAll l77_distance vvlna) vvlnb 359 | , bench "(1651110466/1024)" $ nf (distance_allToAll l79_distance vvlna) vvlnb 360 | ] 361 | ] 362 | 363 | nfWith1Constraint :: NFData b => ((p => a) -> b) -> (p => a) -> Pure 364 | nfWith1Constraint = nf 365 | 366 | ------------------------------------------------------------------------------- 367 | -- test functions 368 | 369 | -- | sums the distance between a point and every point in a vector in time O(p) 370 | distance_oneToAll :: 371 | ( VG.Vector v1 (v2 f) 372 | , VG.Vector v2 f 373 | , Floating f 374 | ) => (v2 f -> v2 f -> f) -> v2 f -> v1 (v2 f) -> f 375 | distance_oneToAll !dist !v !vv = go 0 (VG.length vv-1) 376 | where 377 | go !tot (-1) = tot 378 | go !tot !i = go tot' (i-1) 379 | where 380 | tot' = tot + dist v (vv `VG.unsafeIndex` i) 381 | 382 | -- | sums the distance between every point in vv1 and every point in vv2 in time O(p^2) 383 | distance_allToAll :: 384 | ( VG.Vector v1 (v2 f) 385 | , VG.Vector v2 f 386 | , Floating f 387 | ) => (v2 f -> v2 f -> f) -> v1 (v2 f) -> v1 (v2 f) -> f 388 | distance_allToAll !dist !vv1 !vv2 = go 0 (VG.length vv1-1) 389 | where 390 | go !tot (-1) = tot 391 | go !tot !i = go tot' (i-1) 392 | where 393 | tot' = tot + distance_oneToAll dist (vv1 `VG.unsafeIndex` i) vv2 394 | -------------------------------------------------------------------------------- /examples/supercomp-manyparams.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O2 -fllvm -mavx512f #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE UnboxedTuples #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ConstraintKinds #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | -- | This file contains a single data type called "ManyParams" that has many 18 | -- type level parameters. Criterion benchmarks show that specifying these 19 | -- parameters at compile time results in approximately a 25% performance improvement 20 | -- vs specifying at run time. 21 | module Main 22 | where 23 | 24 | import Control.Category 25 | import Control.DeepSeq 26 | import Control.Monad 27 | import Control.Monad.Random 28 | import Criterion.Config 29 | import Criterion.Main 30 | import Data.Monoid 31 | import qualified Data.Vector.Generic as VG 32 | import qualified Data.Params.Vector.Unboxed as VPU 33 | import qualified Data.Params.Vector.UnboxedRaw as VPUR 34 | import qualified Data.Params.Vector.Storable as VPS 35 | import qualified Data.Params.Vector.Storable as VPSR 36 | import qualified Data.Vector.Unboxed as VU 37 | import qualified Data.Vector as V 38 | import Prelude hiding ((.),id) 39 | 40 | import GHC.Base (Int(..)) 41 | import Language.Haskell.TH hiding (reify) 42 | import Language.Haskell.TH.Syntax hiding (reify) 43 | import qualified Language.Haskell.TH as TH 44 | 45 | import Data.Params 46 | import Data.Params.Frac 47 | import Data.Params.PseudoPrim 48 | import Data.Params.Vector 49 | 50 | ------------------------------------------------------------------------------- 51 | -- test functions 52 | 53 | -- {-# NOINLINE sumVector #-} 54 | sumVector :: (Monoid e, VG.Vector v e) => v e -> e 55 | sumVector v = VG.foldl1' mappend v 56 | 57 | newtype ManyParams 58 | (p1 :: Param Nat) 59 | (p2 :: Param Nat) 60 | (p3 :: Param Nat) 61 | (p4 :: Param Nat) 62 | (p5 :: Param Nat) 63 | = ManyParams Int 64 | deriving (Read,Show,Eq,Ord) 65 | mkParams ''ManyParams 66 | 67 | instance NFData (ManyParams p1 p2 p3 p4 p5) where 68 | rnf (ManyParams x) = rnf x 69 | 70 | instance PseudoPrim (ManyParams p1 p2 p3 p4 p5) where 71 | newtype PseudoPrimInfo (ManyParams p1 p2 p3 p4 p5) 72 | = PseudoPrimInfo_ManyParams (PseudoPrimInfo Int) 73 | pp_sizeOf# (PseudoPrimInfo_ManyParams ppi) = pp_sizeOf# ppi 74 | pp_alignment# (PseudoPrimInfo_ManyParams ppi) = pp_alignment# ppi 75 | pp_indexByteArray# (PseudoPrimInfo_ManyParams ppi) arr# i# 76 | = ManyParams $ pp_indexByteArray# ppi arr# i# 77 | pp_readByteArray# (PseudoPrimInfo_ManyParams ppi) marr# i# s# 78 | = case pp_readByteArray# ppi marr# i# s# of 79 | (# s, d #) -> (# s, ManyParams d #) 80 | pp_writeByteArray# (PseudoPrimInfo_ManyParams ppi) marr# i# (ManyParams d) s# 81 | = pp_writeByteArray# ppi marr# i# d s# 82 | seqInfo (ManyParams d) = seqInfo d 83 | emptyInfo = PseudoPrimInfo_ManyParams $ emptyInfo 84 | {-# INLINE pp_sizeOf# #-} 85 | {-# INLINE pp_alignment# #-} 86 | {-# INLINE pp_indexByteArray# #-} 87 | {-# INLINE pp_readByteArray# #-} 88 | {-# INLINE pp_writeByteArray# #-} 89 | {-# INLINE seqInfo #-} 90 | {-# INLINE emptyInfo #-} 91 | 92 | instance 93 | ( ViewParam Param_p1 t 94 | , ViewParam Param_p2 t 95 | , ViewParam Param_p3 t 96 | , ViewParam Param_p4 t 97 | , ViewParam Param_p5 t 98 | , t ~ ManyParams p1 p2 p3 p4 p5 99 | ) => Monoid (ManyParams p1 p2 p3 p4 p5) 100 | where 101 | 102 | {-# INLINE mempty #-} 103 | mempty = ManyParams 0 104 | 105 | {-# INLINE mappend #-} 106 | mappend m@(ManyParams m1) (ManyParams m2) = ManyParams 107 | $ m1+m2 108 | + viewParam _p1 m 109 | + viewParam _p2 m 110 | + viewParam _p3 m 111 | + viewParam _p4 m 112 | + viewParam _p5 m 113 | 114 | ------------------------------------------------------------------------------- 115 | -- criterion tests 116 | 117 | -- | criterion configuration parameters 118 | critConfig = defaultConfig 119 | { cfgPerformGC = ljust True 120 | , cfgSamples = ljust 1000 121 | -- , cfgSummaryFile = ljust $ "results/summary-"++show veclen++"-"++show numvec++".csv" 122 | -- , cfgReport = ljust "report.html" 123 | } 124 | 125 | veclen = 10000000 126 | 127 | type P1 = Static 1211 128 | type P2 = Static 1222 129 | type P3 = Static 1233 130 | type P4 = Static 1244 131 | type P5 = Static 1215 132 | 133 | -- type P1 = Static (1211/1) 134 | -- type P2 = Static (1222/1) 135 | -- type P3 = Static (1233/1) 136 | -- type P4 = Static (1244/1) 137 | -- type P5 = Static (1215/1) 138 | 139 | type MP5 = ManyParams P1 P2 P3 P4 P5 140 | type MP4 = ManyParams P1 P2 P3 P4 RunTime 141 | type MP3 = ManyParams P1 P2 P3 RunTime RunTime 142 | type MP2 = ManyParams P1 P2 RunTime RunTime RunTime 143 | type MP1 = ManyParams P1 RunTime RunTime RunTime RunTime 144 | type MP0 = ManyParams RunTime RunTime RunTime RunTime RunTime 145 | 146 | ------------------------------------------------------------------------------- 147 | -- main function 148 | 149 | nfWith1Constraint :: NFData b => ((p => a) -> b) -> (p => a) -> Pure 150 | nfWith1Constraint = nf 151 | 152 | nfWith2Constraint :: NFData b => (((p1,p2) => a) -> b) -> ((p1,p2) => a) -> Pure 153 | nfWith2Constraint = nf 154 | 155 | nfWith3Constraint :: NFData b => (((p1,p2,p3) => a) -> b) -> ((p1,p2,p3) => a) -> Pure 156 | nfWith3Constraint = nf 157 | 158 | main = do 159 | 160 | ----------------------------------- 161 | -- initializing tests 162 | 163 | putStrLn "initializing tests" 164 | 165 | -- let randL = evalRand (replicateM veclen $ getRandomR (-10000,10000)) (mkStdGen $ 1) 166 | let randL = replicate veclen 1 167 | 168 | let vs5 = VG.fromList (map ManyParams randL) :: VPU.Vector Automatic MP5 169 | vs4 = VG.fromList (map ManyParams randL) :: VPU.Vector Automatic MP4 170 | vs3 = VG.fromList (map ManyParams randL) :: VPU.Vector Automatic MP3 171 | vs2 = VG.fromList (map ManyParams randL) :: VPU.Vector Automatic MP2 172 | vs1 = VG.fromList (map ManyParams randL) :: VPU.Vector Automatic MP1 173 | vs0 = VG.fromList (map ManyParams randL) :: VPU.Vector Automatic MP0 174 | 175 | deepseq vs5 $ return () 176 | deepseq vs4 $ return () 177 | deepseq vs3 $ return () 178 | deepseq vs2 $ return () 179 | deepseq vs1 $ return () 180 | deepseq vs0 $ return () 181 | 182 | let test4 = mkApWith1Param 183 | (Proxy::Proxy (VPU.Vector Automatic MP4)) 184 | (Proxy::Proxy MP4) 185 | (_elem._p5) 2222 186 | sumVector 187 | 188 | let test3 = mkApWith2Param 189 | (Proxy::Proxy (VPU.Vector Automatic MP3)) 190 | (Proxy::Proxy MP3) 191 | (_elem._p5) 2222 192 | (_elem._p4) 2223 193 | sumVector 194 | 195 | let test2 = mkApWith3Param 196 | (Proxy::Proxy (VPU.Vector Automatic MP2)) 197 | (Proxy::Proxy MP2) 198 | (_elem._p5) 2222 199 | (_elem._p4) 2223 200 | (_elem._p3) 2224 201 | sumVector 202 | 203 | ----------------------------------- 204 | -- run tests 205 | 206 | putStrLn "starting criterion" 207 | 208 | defaultMainWith critConfig (return ()) 209 | [ bench "vs5" $ nf sumVector vs5 210 | , bench "vs4" $ nfWith1Constraint test4 vs4 211 | , bench "vs3" $ nfWith2Constraint test3 vs3 212 | , bench "vs2" $ nfWith3Constraint test2 vs2 213 | ] 214 | 215 | 216 | 217 | -------------------------------------------------------------------------------- /src/Data/Params/Applicative.hs: -------------------------------------------------------------------------------- 1 | module Data.Params.Applicative 2 | where 3 | 4 | import Control.Category 5 | import Prelude hiding ( (.), id, Functor(..), Applicative(..) ) 6 | 7 | import Data.Params 8 | import Data.Params.Functor 9 | 10 | ------------------------------------------------------------------------------- 11 | -- Applicative class 12 | 13 | class Functor lens tb => Applicative lens tb where 14 | 15 | pure :: GetParam lens tb -> TypeLens Base lens -> tb 16 | 17 | ap :: 18 | ( tf ~ SetParam lens (a -> b) tb 19 | , ta ~ SetParam lens a tb 20 | , a ~ GetParam lens ta 21 | , b ~ GetParam lens tb 22 | ) 23 | => TypeLens Base lens 24 | -> tf 25 | -> ta 26 | -> tb 27 | 28 | --------------------------------------- 29 | -- instances 30 | 31 | instance Applicative Base t where 32 | pure a _ = a 33 | ap _ f = f 34 | 35 | ------------------- 36 | 37 | instance Applicative p a => Applicative (Param_a p) (Maybe a) where 38 | pure a lens = Just $ pure a (zoom lens) 39 | ap lens Nothing _ = Nothing 40 | ap lens (Just f) Nothing = Nothing 41 | ap lens (Just f) (Just b) = Just $ ap (zoom lens) f b 42 | 43 | ------------------- 44 | 45 | instance Applicative p a => Applicative (Param_a p) (Either a b) where 46 | pure a lens = Left $ pure a (zoom lens) 47 | ap lens (Right a) _ = Right a 48 | ap lens (Left f) (Right a) = Right a 49 | ap lens (Left f) (Left b) = Left $ ap (zoom lens) f b 50 | 51 | instance Applicative p b => Applicative (Param_b p) (Either a b) where 52 | pure b lens = Right $ pure b (zoom lens) 53 | ap lens (Left a) _ = Left a 54 | ap lens (Right f) (Left a) = Left a 55 | ap lens (Right f) (Right b) = Right $ ap (zoom lens) f b 56 | 57 | ------------------------------------------------------------------------------- 58 | -- combinators 59 | 60 | infixl 4 <$> 61 | (<$>) :: 62 | ( Functor lens tb 63 | , b ~ GetParam lens tb 64 | , ta ~ SetParam lens a tb 65 | ) => (a -> b) 66 | -> ta 67 | -> TypeLens Base lens 68 | -> tb 69 | (f <$> t) lens = fmap lens f t 70 | 71 | infixr 0 @@ 72 | (@@) :: (TypeLens p q -> b) -> TypeLens p q -> b 73 | (@@) = id 74 | 75 | at :: TypeLens q p -> (TypeLens q p -> t) -> t 76 | at lens f = f lens 77 | 78 | infixl 4 <*> 79 | (<*>) :: 80 | ( Applicative lens tb 81 | , tf ~ SetParam lens (a -> b) tb 82 | , ta ~ SetParam lens a tb 83 | , a ~ GetParam lens ta 84 | , b ~ GetParam lens tb 85 | ) => (TypeLens Base lens -> tf) 86 | -> ta 87 | -> (TypeLens Base lens -> tb) 88 | (<*>) tf ta lens = ap lens (tf lens) ta 89 | 90 | infixl 4 <*>- 91 | (tf <*>- ta) lens = (tf <*> ta lens) lens 92 | 93 | infixl 4 <* 94 | (u <* v) lens = pure const <*> u <*> v @@ lens 95 | 96 | infixl 4 *> 97 | (u *> v) lens = pure (const id) <*> u <*> v @@ lens 98 | 99 | infixl 4 <*- 100 | infixl 4 -<*- 101 | infixl 4 -<* 102 | (u <*- v) lens = ( u <* v lens ) lens 103 | (u -<*- v) lens = ( u lens <* v lens ) lens 104 | (u -<* v) lens = ( u lens <* v ) lens 105 | 106 | infixl 4 *>- 107 | infixl 4 -*>- 108 | infixl 4 -*> 109 | (u *>- v) lens = ( u *> v lens ) lens 110 | (u -*>- v) lens = ( u lens *> v lens ) lens 111 | (u -*> v) lens = ( u lens *> v ) lens 112 | 113 | -------------------------------------------------------------------------------- /src/Data/Params/Frac.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | -- | Provides type level fractions based on type nats 4 | module Data.Params.Frac 5 | ( Frac (..) 6 | , KnownFrac (..) 7 | , fracVal 8 | ) 9 | where 10 | 11 | import GHC.TypeLits 12 | import Data.Proxy 13 | 14 | -- | (Kind) This is the kind of type-level fractions. 15 | -- It is not built in to GHC, but instead defined in terms of 'Nat' 16 | data Frac = (/) Nat Nat 17 | 18 | -- | This class gives the 'Rational' associated with a type-level fraction. 19 | class KnownFrac (n :: Frac) where 20 | fracSing :: SFrac n 21 | 22 | instance (KnownNat a, KnownNat b) => KnownFrac (a/b) where 23 | fracSing = SFrac 24 | (fromIntegral $ natVal (Proxy::Proxy a)) 25 | (fromIntegral $ natVal (Proxy::Proxy b)) 26 | 27 | -- | get the value from a type frac 28 | -- fracVal :: forall n proxy. (KnownFrac n) => proxy n -> Rational 29 | fracVal :: forall f n proxy. (KnownFrac n, Fractional f) => proxy n -> f 30 | fracVal _ = case fracSing :: SFrac n of 31 | SFrac a b -> fromIntegral a / fromIntegral b 32 | 33 | data SFrac (n :: Frac) = SFrac 34 | {-#UNPACK#-}!Int 35 | {-#UNPACK#-}!Int 36 | -- data SFrac (n :: Frac) = SFrac Integer Integer 37 | -------------------------------------------------------------------------------- /src/Data/Params/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Data.Params.Functor 4 | where 5 | 6 | import Control.Category 7 | import Prelude hiding ((.), id, Functor(..), Applicative(..)) 8 | 9 | import Data.Maybe 10 | import Data.Params 11 | 12 | import GHC.Exts 13 | 14 | ------------------------------------------------------------------------------- 15 | 16 | class Functor lens tb where 17 | fmap' :: ( b ~ GetParam lens tb, ta ~ SetParam lens a tb ) 18 | => TypeLens p lens 19 | -> (a -> b) -> ta -> tb 20 | 21 | fmap :: 22 | ( Functor lens tb 23 | , b ~ GetParam lens tb 24 | , ta ~ SetParam lens a tb 25 | ) => TypeLens Base lens 26 | -> (a -> b) -> ta -> tb 27 | fmap lens = fmap' (lens._base) 28 | 29 | ------------------- 30 | -- Either 31 | 32 | mkParams ''Either 33 | 34 | -- type instance Objective (Param_a p) = Objective_Param_a (Param_a p) 35 | -- type family Objective_Param_a (lens :: * -> Constraint) :: * -> Constraint where 36 | -- Objective_Param_a (Param_a Base) = Param_a Base 37 | -- Objective_Param_a (Param_a p) = Objective p 38 | -- 39 | -- type instance Objective (Param_b p) = Objective_Param_b (Param_b p) 40 | -- type family Objective_Param_b (lens :: * -> Constraint) :: * -> Constraint where 41 | -- Objective_Param_b (Param_b Base) = Param_b Base 42 | -- Objective_Param_b (Param_b p) = Objective p 43 | 44 | 45 | instance Functor p b => Functor (Param_b p) (Either a b) where 46 | fmap' lens f (Left a) = Left a 47 | fmap' lens f (Right b) = Right $ fmap' (zoom lens) f b 48 | 49 | instance Functor p a => Functor (Param_a p) (Either a b) where 50 | fmap' lens f (Left a) = Left $ fmap' (zoom lens) f a 51 | fmap' lens f (Right b) = Right b 52 | 53 | instance Functor Base t where 54 | fmap' _ f a = f a 55 | 56 | ------------------- 57 | -- Maybe 58 | 59 | mkParams ''Maybe 60 | instance Functor p a => Functor (Param_a p) (Maybe a) where 61 | fmap' lens f Nothing = Nothing 62 | fmap' lens f (Just a) = Just $ fmap' (zoom lens) f a 63 | -------------------------------------------------------------------------------- /src/Data/Params/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | This module exports instances for common Haskell types 4 | module Data.Params.Instances 5 | where 6 | 7 | 8 | -------------------------------------------------------------------------------- /src/Data/Params/ModInt.hs: -------------------------------------------------------------------------------- 1 | module Data.Params.ModInt 2 | where 3 | 4 | import Data.Params 5 | 6 | ------------------------------------------------------------------------------- 7 | -- general 8 | 9 | data family ModIntegral (modulus :: Param Nat) i 10 | 11 | type ModInt modulus = ModIntegral modulus Int 12 | type ModInteger modulus = ModIntegral modulus Integer 13 | 14 | ------------------------------------------------------------------------------- 15 | -- Static 16 | 17 | newtype instance ModIntegral (Static n) i = ModIntegral_Static i 18 | deriving (Read,Show,Eq,Ord) 19 | 20 | instance (KnownNat n, Integral i) => Num (ModIntegral (Static n) i) where 21 | (ModIntegral_Static a)+(ModIntegral_Static b) = ModIntegral_Static $ (a+b) `mod` n 22 | where n = fromIntegral $ natVal (Proxy::Proxy n) 23 | 24 | (ModIntegral_Static a)*(ModIntegral_Static b) = ModIntegral_Static $ (a*b) `mod` n 25 | where n = fromIntegral $ natVal (Proxy::Proxy n) 26 | 27 | abs = id 28 | 29 | signum = id 30 | 31 | fromInteger a = ModIntegral_Static $ (fromIntegral $ a `mod` n) 32 | where n = fromIntegral $ natVal (Proxy::Proxy n) 33 | 34 | negate (ModIntegral_Static a) = ModIntegral_Static $ (a-n) `mod` n 35 | where n = fromIntegral $ natVal (Proxy::Proxy n) 36 | 37 | ------------------------------------------------------------------------------- 38 | -- RunTime 39 | 40 | newtype instance ModIntegral RunTime i = ModIntegral_RunTime i 41 | deriving (Read,Show,Eq,Ord) 42 | mkParams ''ModIntegral 43 | 44 | instance 45 | ( Param_modulus (ModIntegral RunTime i) 46 | , Integral i 47 | ) => Num (ModIntegral RunTime i) 48 | where 49 | (ModIntegral_RunTime a)+(ModIntegral_RunTime b) = ModIntegral_RunTime $ (a+b) `mod` n 50 | where n = fromIntegral $ param_modulus (undefined:: (ModIntegral RunTime i)) 51 | 52 | (ModIntegral_RunTime a)*(ModIntegral_RunTime b) = ModIntegral_RunTime $ (a*b) `mod` n 53 | where n = fromIntegral $ param_modulus (undefined:: (ModIntegral RunTime i)) 54 | 55 | abs = id 56 | 57 | signum = id 58 | 59 | fromInteger a = ModIntegral_RunTime $ (fromIntegral $ a `mod` n) 60 | where n = fromIntegral $ param_modulus (undefined:: (ModIntegral RunTime i)) 61 | 62 | negate (ModIntegral_RunTime a) = ModIntegral_RunTime $ a-n `mod` n 63 | where n = fromIntegral $ param_modulus (undefined:: (ModIntegral RunTime i)) 64 | -------------------------------------------------------------------------------- /src/Data/Params/Monad.hs: -------------------------------------------------------------------------------- 1 | module Data.Params.Monad 2 | where 3 | 4 | import Control.Category 5 | import Prelude hiding ( (.), id, Functor(..), Applicative(..), Monad(..) ) 6 | import qualified Prelude as P 7 | import GHC.Exts 8 | 9 | import Data.Params hiding ( (\\) ) 10 | import Data.Params.Applicative 11 | import Data.Params.Functor 12 | 13 | ------------------------------------------------------------------------------- 14 | -- Monad class 15 | 16 | class Applicative lens tfb => Monad lens tfb where 17 | join :: tffb ~ CoJoin lens tfb 18 | => TypeLens Base lens -> tffb -> tfb 19 | 20 | type family CoJoin (lens :: * -> Constraint) t 21 | type instance CoJoin lens t 22 | = SetParam' 23 | lens 24 | ( SetParam' 25 | ( Objective lens ) 26 | ( GetParam lens t ) 27 | ( GetParam (RemoveObjective lens) t ) 28 | ) 29 | t 30 | 31 | ------------------------------------------------------------------------------- 32 | -- functions 33 | 34 | return :: Monad lens t 35 | => GetParam lens t 36 | -> TypeLens Base lens 37 | -> t 38 | return = pure 39 | 40 | infixl 1 \\= 41 | (m \\= f) lens = join lens $ fmap lens f m 42 | 43 | infixl 1 \\=- 44 | infixl 1 -\\=- 45 | infixl 1 -\\= 46 | (m \\=- f) lens = ( m \\= \a -> f a $ objective lens ) lens 47 | (m -\\=- f) lens = ( m lens \\= \a -> f a $ objective lens ) lens 48 | (m -\\= f) lens = ( m lens \\= \a -> f a ) lens 49 | 50 | atM lens m = at (removeObjective lens) $ do 51 | return $ at (objective lens) $ m 52 | 53 | ------------------- 54 | 55 | 56 | -- > (\\) :: forall a b ma mb lens. 57 | -- > ( b ~ GetParam lens mb 58 | -- > , ma ~ SetParam lens a mb 59 | -- > , ma ~ SetParam lens (GetParam lens ma) mb 60 | -- > , a ~ GetParam lens ma 61 | -- > ) => ma -> mb -> TypeLens Base lens -> mb 62 | 63 | (m \\ f) lens = (m \\= \ (_::String) -> f) lens 64 | 65 | -- FIXME: The compiler can't figure out the type of (\\) without the String annotation; GHC bug? 66 | 67 | infixl 1 \\ 68 | 69 | infixl 1 \\- 70 | infixl 1 -\\- 71 | infixl 1 -\\ 72 | ( m \\- f ) lens = ( m \\ f (objective lens) ) lens 73 | ( m -\\- f ) lens = ( m lens \\ f (objective lens) ) lens 74 | ( m -\\ f ) lens = ( m lens \\ f ) lens 75 | 76 | ------------------- 77 | -- do notation 78 | 79 | infixl 1 >>= 80 | (m >>= f) lens = (m -\\=- f) lens 81 | 82 | infixl 1 >> 83 | m >> f = m -\\- f 84 | 85 | fail = error 86 | 87 | ifThenElse False _ f = f 88 | ifThenElse True t _ = t 89 | 90 | 91 | ------------------------------------------------------------------------------- 92 | -- instances 93 | 94 | instance Monad (Param_a Base) (Either a b) where 95 | join lens (Left (Left a)) = Left a 96 | join lens (Left (Right b)) = Right b 97 | join lens (Right b) = Right b 98 | 99 | instance Monad (Param_b Base) (Either a b) where 100 | join lens (Right (Right b)) = Right b 101 | join lens (Right (Left a)) = Left a 102 | join lens (Left a) = Left a 103 | 104 | instance 105 | ( Monad p a 106 | , Either (CoJoin p a) b ~ CoJoin (Param_a p) (Either a b) -- follows from the lens laws 107 | ) => Monad (Param_a p) (Either a b) 108 | where 109 | 110 | join lens (Left a) = Left $ join (zoom lens) a 111 | join lens (Right b) = Right b 112 | 113 | instance 114 | ( Monad p b 115 | , Either a (CoJoin p b) ~ CoJoin (Param_b p) (Either a b) -- follows from the lens laws 116 | ) => Monad (Param_b p) (Either a b) 117 | where 118 | 119 | join lens (Left a) = Left a 120 | join lens (Right b) = Right $ join (zoom lens) b 121 | 122 | --------------------------------------- 123 | 124 | instance Monad (Param_a Base) (Maybe a) where 125 | join lens Nothing = Nothing 126 | join lens (Just Nothing) = Nothing 127 | join lens (Just (Just a)) = Just a 128 | 129 | instance 130 | ( Monad p a 131 | , Maybe (CoJoin p a) ~ CoJoin (Param_a p) (Maybe a) -- follows from the lens laws 132 | ) => Monad (Param_a p) (Maybe a) 133 | where 134 | 135 | join lens Nothing = Nothing 136 | join lens (Just a) = Just $ join (zoom lens) a 137 | 138 | -------------------------------------------------------------------------------- /src/Data/Params/PseudoPrim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnboxedTuples #-} 4 | 5 | -- | This modules extends the 'Prim' from "Data.Primitive" class to cases 6 | -- where we don't know the primitive information (like the size) at compile 7 | -- time. Instead, we must pass in a 'PseudoPrimInfo' object that will get 8 | -- evaluated on every function call and that contains the needed information. 9 | -- 10 | -- For 'PseudoPrim' instances that are also 'Prim' instances, this involves 11 | -- no run time overhead. For 'PseudoPrim' instances that cannot be made 12 | -- 'Prim' instances, this involves a mild memory and speed bookkeeping 13 | -- overhead. 14 | module Data.Params.PseudoPrim 15 | where 16 | 17 | import GHC.Base (Int (..)) 18 | import GHC.Int 19 | import GHC.Prim 20 | import Data.Word 21 | 22 | import Control.Monad.Primitive 23 | import Data.Primitive 24 | 25 | ------------------------------------------------------------------------------- 26 | -- PseudoPrim class 27 | 28 | class PseudoPrim a where 29 | data family PseudoPrimInfo a 30 | pp_sizeOf# :: PseudoPrimInfo a -> Int# 31 | pp_alignment# :: PseudoPrimInfo a -> Int# 32 | pp_indexByteArray# :: PseudoPrimInfo a -> ByteArray# -> Int# -> a 33 | pp_readByteArray# :: PseudoPrimInfo a -> MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) 34 | pp_writeByteArray# :: PseudoPrimInfo a -> MutableByteArray# s -> Int# -> a -> State# s -> State# s 35 | 36 | -- | Do we need to evaluate the info in order to call these functions? 37 | seqInfo :: a -> Bool 38 | 39 | -- | If 'seqInfo' returns 'True', then this function is undefined. 40 | -- Otherwise, it containes an empty 'PseudoPrimInfo' whose type is 41 | -- sufficient to determine all the needed information. 42 | emptyInfo :: PseudoPrimInfo a 43 | 44 | #define mkPseudoPrim(t,ppi) \ 45 | instance PseudoPrim t where\ 46 | newtype PseudoPrimInfo t = ppi () ;\ 47 | pp_sizeOf# a = sizeOf# (undefined :: t) ;\ 48 | pp_alignment# a = alignment# (undefined :: t) ;\ 49 | pp_indexByteArray# a = indexByteArray# ;\ 50 | pp_readByteArray# _ = readByteArray# ;\ 51 | pp_writeByteArray# _ = writeByteArray# ;\ 52 | seqInfo _ = False ;\ 53 | emptyInfo = ppi () 54 | 55 | mkPseudoPrim(Double,PseudoPrimInfo_Double) 56 | mkPseudoPrim(Float,PseudoPrimInfo_Float) 57 | mkPseudoPrim(Int,PseudoPrimInfo_Int) 58 | mkPseudoPrim(Char,PseudoPrimInfo_Char) 59 | mkPseudoPrim(Word8,PseudoPrimInfo_Word8) 60 | mkPseudoPrim(Word16,PseudoPrimInfo_Word16) 61 | mkPseudoPrim(Word32,PseudoPrimInfo_Word32) 62 | mkPseudoPrim(Word64,PseudoPrimInfo_Word64) 63 | 64 | ------------------------------------------------------------------------------- 65 | -- helper functions 66 | 67 | {-# INLINE pp_sizeOf #-} 68 | pp_sizeOf :: PseudoPrim a => PseudoPrimInfo a -> Int 69 | pp_sizeOf x = I# (pp_sizeOf# x) 70 | 71 | {-# INLINE pp_alignment #-} 72 | pp_alignment :: PseudoPrim a => PseudoPrimInfo a -> Int 73 | pp_alignment x = I# (pp_alignment# x) 74 | 75 | {-# INLINE pp_readByteArray #-} 76 | pp_readByteArray 77 | :: (PseudoPrim a, PrimMonad m) => PseudoPrimInfo a -> MutableByteArray (PrimState m) -> Int -> m a 78 | pp_readByteArray ppi (MutableByteArray arr#) (I# i#) = primitive (pp_readByteArray# ppi arr# i#) 79 | 80 | {-# INLINE pp_writeByteArray #-} 81 | pp_writeByteArray 82 | :: (PseudoPrim a, PrimMonad m) => PseudoPrimInfo a -> MutableByteArray (PrimState m) -> Int -> a -> m () 83 | pp_writeByteArray ppi (MutableByteArray arr#) (I# i#) x = primitive_ (pp_writeByteArray# ppi arr# i# x) 84 | 85 | {-# INLINE pp_indexByteArray #-} 86 | pp_indexByteArray :: PseudoPrim a => PseudoPrimInfo a -> ByteArray -> Int -> a 87 | pp_indexByteArray ppi (ByteArray arr#) (I# i#) = pp_indexByteArray# ppi arr# i# 88 | -------------------------------------------------------------------------------- /src/Data/Params/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Provides the infrastructure that is common to all types of parameterized 4 | -- vectors. 5 | module Data.Params.Vector 6 | ( 7 | 8 | -- * Type lenses 9 | _len 10 | , _elem 11 | 12 | -- * Classes 13 | , Param_len (..) 14 | , Param_elem (..) 15 | , Def (..) 16 | 17 | ) 18 | where 19 | 20 | import Language.Haskell.TH hiding (reify) 21 | import Language.Haskell.TH.Syntax hiding (reify) 22 | import qualified Language.Haskell.TH as TH 23 | 24 | import Data.Params 25 | 26 | mkParamClass_Config "len" (ConT ''Int) 27 | mkParamClass_Star "elem" 28 | mkReifiableConstraint "len" 29 | mkTypeLens_Config "len" 30 | mkTypeLens_Star "elem" 31 | mkHasDictionary_Star "elem" 32 | mkHasDictionary_Config "len" (ConT ''Int) 33 | 34 | -------------------------------------------------------------------------------- /src/Data/Params/Vector/Storable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE UnboxedTuples #-} 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | 8 | -- | Efficient vectors requiring a storable instance for the elements. 9 | -- These vectors can be considerably faster than unboxed vectors in 10 | -- some cases. 11 | -- This is because a storable vector of fixed size need only keep track 12 | -- of a single pointer; everything else is known at compile time. 13 | -- This lets us move some variables from memory into the assembly 14 | -- instructions. 15 | -- Tricks like this are not available in c code and can be very important. 16 | -- We store less memory, use fewer registers, run fewer assembly instructions, 17 | -- and have fewer cache misses. 18 | -- In short, this data type is awesome. 19 | -- 20 | -- A 'Storable' instance lets us create vectors of vectors; however, 21 | -- I'm not 100% convinced that it is correct with respect to memory leaks. 22 | 23 | module Data.Params.Vector.Storable 24 | where 25 | 26 | import Control.Monad 27 | import Control.Monad.Primitive 28 | import Control.DeepSeq 29 | -- import Data.Primitive 30 | import Data.Primitive.Addr 31 | import Data.Primitive.ByteArray 32 | import Data.Primitive.Types 33 | import GHC.Ptr 34 | import GHC.ForeignPtr 35 | import Foreign.Ptr 36 | import Foreign.ForeignPtr hiding (unsafeForeignPtrToPtr) 37 | import Foreign.ForeignPtr.Unsafe 38 | import Foreign.Marshal.Array 39 | import Foreign.Storable 40 | import qualified Data.Vector.Generic as VG 41 | import qualified Data.Vector.Generic.Mutable as VGM 42 | import qualified Data.Vector.Unboxed as VU 43 | import qualified Data.Vector.Unboxed.Mutable as VUM 44 | import qualified Data.Vector.Primitive as VP 45 | import qualified Data.Vector.Primitive.Mutable as VPM 46 | 47 | import GHC.Base (Int (..)) 48 | import GHC.Int 49 | import GHC.Prim 50 | import GHC.TypeLits 51 | import Data.Params 52 | import Data.Params.Vector 53 | 54 | import Unsafe.Coerce 55 | 56 | ------------------------------------------------------------------------------- 57 | -- taken from Data.Vector.Storable.Internal 58 | 59 | {-# INLINE getPtr #-} 60 | getPtr :: ForeignPtr a -> Ptr a 61 | getPtr (ForeignPtr addr _) = Ptr addr 62 | 63 | {-# INLINE mallocVector #-} 64 | mallocVector :: Storable a => Int -> IO (ForeignPtr a) 65 | mallocVector = 66 | #if __GLASGOW_HASKELL__ >= 605 67 | doMalloc undefined 68 | where 69 | doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) 70 | doMalloc dummy size = mallocPlainForeignPtrBytes (size * Foreign.Storable.sizeOf dummy) 71 | #else 72 | mallocForeignPtrArray 73 | #endif 74 | 75 | ------------------------------------------------------------------------------- 76 | 77 | -- u :: Vector (Static 1) (Vector (Static 10) Int) 78 | -- u = VG.singleton $ VG.fromList [1..10] 79 | -- 80 | -- u' :: Vector (Static 1) (Vector RunTime Int) 81 | -- u' = withParam3 (_elem._len $ 10) $ VG.singleton $ VG.fromList [1..10] 82 | -- 83 | -- u'' :: Vector (Static 1) (Vector RunTime Int) 84 | -- u'' = withParam3 (_elem._len $ 10) $ VG.singleton $ VG.fromList [1..10] 85 | -- 86 | -- v' = withParam3 (_len 10) $ VG.fromList [1..10] :: Vector RunTime Int 87 | -- 88 | -- w :: Vector RunTime (Vector (Static 10) Int) 89 | -- w = withParam3 (_len 1) $ VG.singleton $ VG.fromList [1..10] 90 | -- 91 | -- w' :: Vector RunTime (Vector RunTime Int) 92 | -- w' = withParam3 (_len 1) 93 | -- $ withParam3 (_elem._len $ 10) 94 | -- $ VG.singleton $ VG.fromList [1..10] 95 | 96 | --------- 97 | 98 | ------------------------------------------------------------------------------- 99 | -- immutable automatically sized vector 100 | 101 | data family Vector (len::Config Nat) elem 102 | mkParams ''Vector 103 | 104 | instance (Show elem, VG.Vector (Vector len) elem) => Show (Vector len elem) where 105 | show v = "fromList "++show (VG.toList v) 106 | 107 | instance (Eq elem, VG.Vector (Vector len) elem) => Eq (Vector len elem) where 108 | a == b = (VG.toList a) == (VG.toList b) 109 | 110 | instance (Ord elem, VG.Vector (Vector len) elem) => Ord (Vector len elem) where 111 | compare a b = compare (VG.toList a) (VG.toList b) 112 | 113 | --------------------------------------- 114 | -- fixed size 115 | 116 | newtype instance Vector (Static len) elem = Vector (ForeignPtr elem) 117 | 118 | instance NFData (Vector (Static len) elem) where 119 | rnf a = seq a () 120 | 121 | instance 122 | ( Storable elem 123 | , KnownNat len 124 | ) => VG.Vector (Vector (Static len)) elem 125 | where 126 | 127 | {-# INLINE basicUnsafeFreeze #-} 128 | basicUnsafeFreeze (MVector fp) = return $ Vector fp 129 | 130 | {-# INLINE basicUnsafeThaw #-} 131 | basicUnsafeThaw (Vector fp) = return $ MVector fp 132 | 133 | {-# INLINE [2] basicLength #-} 134 | basicLength _ = intparam (Proxy::Proxy len) 135 | 136 | {-# INLINE basicUnsafeSlice #-} 137 | basicUnsafeSlice j n v = if n /= intparam (Proxy::Proxy len) || j /= 0 138 | then error $ "Vector.basicUnsafeSlice not allowed to change size" 139 | else v 140 | 141 | {-# INLINE basicUnsafeIndexM #-} 142 | basicUnsafeIndexM (Vector fp) i = return 143 | . unsafeInlineIO 144 | $ withForeignPtr fp $ \p -> 145 | peekElemOff p i 146 | 147 | {-# INLINE basicUnsafeCopy #-} 148 | basicUnsafeCopy (MVector fp) (Vector fq) 149 | = unsafePrimToPrim 150 | $ withForeignPtr fp $ \p -> 151 | withForeignPtr fq $ \q -> 152 | Foreign.Marshal.Array.copyArray p q len 153 | where 154 | len = intparam (Proxy::Proxy len) 155 | 156 | {-# INLINE elemseq #-} 157 | elemseq _ = seq 158 | 159 | ------------------- 160 | -- storable instance allows us to make vectors of vectors 161 | 162 | -- class PseudoStorable a where 163 | -- psizeOf :: a -> Int 164 | -- palignment :: a -> Int 165 | -- ppeek :: Ptr a -> IO a 166 | -- ppoke :: Ptr a -> a -> IO () 167 | 168 | instance 169 | ( Storable elem 170 | , KnownNat len 171 | ) => Storable (Vector (Static len) elem) 172 | where 173 | 174 | {-# INLINE sizeOf #-} 175 | sizeOf _ = len * sizeOf (undefined::elem) 176 | where 177 | len = intparam (Proxy::Proxy len) 178 | 179 | {-# INLINE alignment #-} 180 | alignment _ = alignment (undefined::elem) 181 | 182 | {-# INLINE peek #-} 183 | peek p = unsafePrimToPrim $ do 184 | fp <- newForeignPtr_ (castPtr p :: Ptr elem) 185 | return $ Vector fp 186 | 187 | {-# INLINE poke #-} 188 | poke p (Vector fq) = unsafePrimToPrim $ do 189 | withForeignPtr fq $ \q -> 190 | Foreign.Marshal.Array.copyArray (castPtr p) q len 191 | where 192 | len = intparam (Proxy::Proxy len) 193 | 194 | instance 195 | ( Storable elem 196 | , ViewParam Param_len (Vector RunTime elem) 197 | ) => Storable (Vector RunTime elem) 198 | where 199 | 200 | {-# INLINE sizeOf #-} 201 | sizeOf v = len * sizeOf (undefined::elem) 202 | where 203 | len = viewParam _len v 204 | 205 | {-# INLINE alignment #-} 206 | alignment _ = alignment (undefined::elem) 207 | 208 | -- {-# INLINE peek #-} 209 | -- peek p = unsafePrimToPrim $ do 210 | -- fp <- newForeignPtr_ (castPtr p :: Ptr elem) 211 | -- return $ Vector_RunTime fp 212 | -- 213 | -- {-# INLINE poke #-} 214 | -- poke p (Vector fq) = unsafePrimToPrim $ do 215 | -- withForeignPtr fq $ \q -> 216 | -- Foreign.Marshal.Array.copyArray (castPtr p) q len 217 | -- where 218 | -- len = viewParam _len (undefined::Vector RunTime elem) 219 | -- -- len = intparam (Proxy::Proxy len) 220 | 221 | ------------------------------------------------------------------------------- 222 | -- mutable vector 223 | 224 | type instance VG.Mutable (Vector len) = MVector len 225 | 226 | data family MVector (len::Config Nat) s elem 227 | 228 | --------------------------------------- 229 | -- fixed size 230 | 231 | newtype instance MVector (Static len) s elem = MVector (ForeignPtr elem) 232 | 233 | instance 234 | ( Storable elem 235 | , KnownNat len 236 | ) => VGM.MVector (MVector (Static len)) elem 237 | where 238 | 239 | {-# INLINE basicLength #-} 240 | basicLength _ = intparam (Proxy::Proxy len) 241 | 242 | {-# INLINE basicUnsafeSlice #-} 243 | basicUnsafeSlice i m v = if m /= intparam (Proxy::Proxy len) 244 | then error $ "MVector.basicUnsafeSlice not allowed to change size; i="++show i++"; m="++show m++"; len="++show (intparam (Proxy::Proxy len)) 245 | else v 246 | 247 | {-# INLINE basicOverlaps #-} 248 | basicOverlaps (MVector fp) (MVector fq) 249 | = between p q (q `advancePtr` len) || between q p (p `advancePtr` len) 250 | where 251 | between x y z = x >= y && x < z 252 | p = getPtr fp 253 | q = getPtr fq 254 | len = intparam (Proxy::Proxy len) 255 | 256 | {-# INLINE basicUnsafeNew #-} 257 | basicUnsafeNew n = unsafePrimToPrim $ do 258 | fp <- mallocVector len 259 | return $ MVector fp 260 | where 261 | len = intparam (Proxy::Proxy len) 262 | 263 | {-# INLINE basicUnsafeRead #-} 264 | basicUnsafeRead (MVector fp) i = unsafePrimToPrim 265 | $ withForeignPtr fp (`peekElemOff` i) 266 | 267 | {-# INLINE basicUnsafeWrite #-} 268 | basicUnsafeWrite (MVector fp) i x = unsafePrimToPrim 269 | $ withForeignPtr fp $ \p -> pokeElemOff p i x 270 | 271 | {-# INLINE basicUnsafeCopy #-} 272 | basicUnsafeCopy (MVector fp) (MVector fq) = unsafePrimToPrim 273 | $ withForeignPtr fp $ \p -> 274 | withForeignPtr fq $ \q -> 275 | Foreign.Marshal.Array.copyArray p q len 276 | where 277 | len = intparam (Proxy::Proxy len) 278 | 279 | {-# INLINE basicUnsafeMove #-} 280 | basicUnsafeMove (MVector fp) (MVector fq) = unsafePrimToPrim 281 | $ withForeignPtr fp $ \p -> 282 | withForeignPtr fq $ \q -> 283 | moveArray p q len 284 | where 285 | len = intparam (Proxy::Proxy len) 286 | 287 | -- {-# INLINE basicSet #-} 288 | -- basicSet (MVector i arr) x = setByteArray arr i (intparam(Proxy::Proxy len)) x 289 | 290 | --------------------------------------- 291 | -- variable size 292 | 293 | -- newtype instance MVector Automatic s elem = MVector_Automatic (VPM.MVector s elem) 294 | -- mkParams ''MVector 295 | -- 296 | -- instance Prim elem => VGM.MVector (MVector Automatic) elem where 297 | -- 298 | -- {-# INLINE basicLength #-} 299 | -- basicLength (MVector_Automatic v) = VGM.basicLength v 300 | -- 301 | -- {-# INLINE basicUnsafeSlice #-} 302 | -- basicUnsafeSlice i m (MVector_Automatic v) = MVector_Automatic $ VGM.basicUnsafeSlice i m v 303 | -- 304 | -- {-# INLINE basicOverlaps #-} 305 | -- basicOverlaps (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicOverlaps v1 v2 306 | -- 307 | -- {-# INLINE basicUnsafeNew #-} 308 | -- basicUnsafeNew i = MVector_Automatic `liftM` VGM.basicUnsafeNew i 309 | -- 310 | -- {-# INLINE basicUnsafeRead #-} 311 | -- basicUnsafeRead (MVector_Automatic v) i = VGM.basicUnsafeRead v i 312 | -- 313 | -- {-# INLINE basicUnsafeWrite #-} 314 | -- basicUnsafeWrite (MVector_Automatic v) i x = VGM.basicUnsafeWrite v i x 315 | -- 316 | -- {-# INLINE basicUnsafeCopy #-} 317 | -- basicUnsafeCopy (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicUnsafeCopy v1 v2 318 | -- 319 | -- {-# INLINE basicUnsafeMove #-} 320 | -- basicUnsafeMove (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicUnsafeMove v1 v2 321 | -- 322 | -- {-# INLINE basicSet #-} 323 | -- basicSet (MVector_Automatic v) x = VGM.basicSet v x 324 | 325 | -------------------------------------------------------------------------------- /src/Data/Params/Vector/StorableRaw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE UnboxedTuples #-} 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | 8 | module Data.Params.Vector.StorableRaw 9 | where 10 | 11 | import Control.Monad 12 | import Control.Monad.Primitive 13 | import Control.DeepSeq 14 | -- import Data.Primitive 15 | import Data.Primitive.Addr 16 | import Data.Primitive.ByteArray 17 | import Data.Primitive.Types 18 | import GHC.Ptr 19 | import GHC.ForeignPtr 20 | import Foreign.Ptr 21 | import Foreign.Ptr 22 | import Foreign.Marshal.Array 23 | import Foreign.Marshal.Alloc 24 | import Foreign.Storable 25 | import qualified Data.Vector.Generic as VG 26 | import qualified Data.Vector.Generic.Mutable as VGM 27 | import qualified Data.Vector.Unboxed as VU 28 | import qualified Data.Vector.Unboxed.Mutable as VUM 29 | import qualified Data.Vector.Primitive as VP 30 | import qualified Data.Vector.Primitive.Mutable as VPM 31 | 32 | import GHC.Base (Int (..)) 33 | import GHC.Int 34 | import GHC.Prim 35 | import GHC.TypeLits 36 | import Data.Params 37 | import Data.Params.Vector 38 | 39 | import Unsafe.Coerce 40 | 41 | ------------------------------------------------------------------------------- 42 | -- immutable automatically sized vector 43 | 44 | data family Vector (len::Config Nat) elem 45 | 46 | instance (Show elem, VG.Vector (Vector len) elem) => Show (Vector len elem) where 47 | show v = "fromList "++show (VG.toList v) 48 | 49 | instance (Eq elem, VG.Vector (Vector len) elem) => Eq (Vector len elem) where 50 | a == b = (VG.toList a) == (VG.toList b) 51 | 52 | instance (Ord elem, VG.Vector (Vector len) elem) => Ord (Vector len elem) where 53 | compare a b = compare (VG.toList a) (VG.toList b) 54 | 55 | --------------------------------------- 56 | -- static size 57 | 58 | newtype instance Vector (Static len) elem = Vector (Ptr elem) 59 | 60 | mkParams ''Vector 61 | 62 | instance NFData (Vector (Static len) elem) where 63 | rnf a = seq a () 64 | 65 | instance 66 | ( Storable elem 67 | , KnownNat len 68 | ) => VG.Vector (Vector (Static len)) elem 69 | where 70 | 71 | {-# INLINE basicUnsafeFreeze #-} 72 | basicUnsafeFreeze (MVector p) = return $ Vector p 73 | 74 | {-# INLINE basicUnsafeThaw #-} 75 | basicUnsafeThaw (Vector p) = return $ MVector p 76 | 77 | {-# INLINE [2] basicLength #-} 78 | basicLength _ = intparam (Proxy::Proxy len) 79 | 80 | {-# INLINE basicUnsafeSlice #-} 81 | basicUnsafeSlice j n v = if n /= intparam (Proxy::Proxy len) || j /= 0 82 | then error $ "Vector.basicUnsafeSlice not allowed to change size" 83 | else v 84 | 85 | {-# INLINE basicUnsafeIndexM #-} 86 | basicUnsafeIndexM (Vector p) i = return 87 | . unsafeInlineIO 88 | $ peekElemOff p i 89 | 90 | {-# INLINE basicUnsafeCopy #-} 91 | basicUnsafeCopy (MVector p) (Vector q) 92 | = unsafePrimToPrim 93 | $ Foreign.Marshal.Array.copyArray p q len 94 | where 95 | len = intparam (Proxy::Proxy len) 96 | 97 | {-# INLINE elemseq #-} 98 | elemseq _ = seq 99 | 100 | ------------------- 101 | -- storable instance allows us to make vectors of vectors 102 | 103 | instance 104 | ( Storable elem 105 | , KnownNat len 106 | ) => Storable (Vector (Static len) elem) 107 | where 108 | 109 | {-# INLINE sizeOf #-} 110 | sizeOf _ = len * sizeOf (undefined::elem) 111 | where 112 | len = intparam (Proxy::Proxy len) 113 | 114 | {-# INLINE alignment #-} 115 | alignment _ = alignment (undefined::elem) 116 | 117 | {-# INLINE peek #-} 118 | peek p = return $ Vector $ castPtr p 119 | 120 | {-# INLINE peekElemOff #-} 121 | peekElemOff p i = return $ Vector $ (castPtr p) `advancePtr` i 122 | 123 | {-# INLINE poke #-} 124 | poke p (Vector q) = unsafePrimToPrim 125 | $ Foreign.Marshal.Array.copyArray (castPtr p) q len 126 | where 127 | len = intparam (Proxy::Proxy len) 128 | 129 | -- instance 130 | -- ( Storable elem 131 | -- , ViewParam' GetParam_len (Vector RunTime elem) 132 | -- ) => Storable (Vector RunTime elem) 133 | -- where 134 | -- 135 | -- {-# INLINE sizeOf #-} 136 | -- sizeOf v = len * sizeOf (undefined::elem) 137 | -- where 138 | -- len = viewParam _len v 139 | -- 140 | -- {-# INLINE alignment #-} 141 | -- alignment _ = alignment (undefined::elem) 142 | -- 143 | -- {-# INLINE peek #-} 144 | -- peek p = unsafePrimToPrim $ do 145 | -- fp <- newForeignPtr_ (castPtr p :: Ptr elem) 146 | -- return $ Vector_RunTime fp 147 | -- 148 | -- {-# INLINE poke #-} 149 | -- poke p (Vector fq) = unsafePrimToPrim $ do 150 | -- withForeignPtr fq $ \q -> 151 | -- Foreign.Marshal.Array.copyArray (castPtr p) q len 152 | -- where 153 | -- len = viewParam _len (undefined::Vector RunTime elem) 154 | -- -- len = intparam (Proxy::Proxy len) 155 | 156 | ------------------------------------------------------------------------------- 157 | -- mutable vector 158 | 159 | type instance VG.Mutable (Vector len) = MVector len 160 | 161 | data family MVector (len::Config Nat) s elem 162 | 163 | --------------------------------------- 164 | -- fixed size 165 | 166 | newtype instance MVector (Static len) s elem = MVector (Ptr elem) 167 | 168 | instance 169 | ( Storable elem 170 | , KnownNat len 171 | ) => VGM.MVector (MVector (Static len)) elem 172 | where 173 | 174 | {-# INLINE basicLength #-} 175 | basicLength _ = intparam (Proxy::Proxy len) 176 | 177 | {-# INLINE basicUnsafeSlice #-} 178 | basicUnsafeSlice i m v = if m /= intparam (Proxy::Proxy len) 179 | then error $ "MVector.basicUnsafeSlice not allowed to change size; i="++show i++"; m="++show m++"; len="++show (intparam (Proxy::Proxy len)) 180 | else v 181 | 182 | {-# INLINE basicOverlaps #-} 183 | basicOverlaps (MVector p) (MVector q) 184 | = between p q (q `advancePtr` len) || between q p (p `advancePtr` len) 185 | where 186 | between x y z = x >= y && x < z 187 | len = intparam (Proxy::Proxy len) 188 | 189 | {-# INLINE basicUnsafeNew #-} 190 | basicUnsafeNew n = unsafePrimToPrim $ do 191 | p <- mallocBytes $ len * sizeOf (undefined::elem) 192 | return $ MVector p 193 | where 194 | len = intparam (Proxy::Proxy len) 195 | 196 | {-# INLINE basicUnsafeRead #-} 197 | basicUnsafeRead (MVector p) i = unsafePrimToPrim 198 | $ peekElemOff p i 199 | 200 | {-# INLINE basicUnsafeWrite #-} 201 | basicUnsafeWrite (MVector p) i x = unsafePrimToPrim 202 | $ pokeElemOff p i x 203 | 204 | {-# INLINE basicUnsafeCopy #-} 205 | basicUnsafeCopy (MVector p) (MVector q) = unsafePrimToPrim 206 | $ Foreign.Marshal.Array.copyArray p q len 207 | where 208 | len = intparam (Proxy::Proxy len) 209 | 210 | {-# INLINE basicUnsafeMove #-} 211 | basicUnsafeMove (MVector p) (MVector q) = unsafePrimToPrim 212 | $ moveArray p q len 213 | where 214 | len = intparam (Proxy::Proxy len) 215 | 216 | -- {-# INLINE basicSet #-} 217 | -- basicSet (MVector i arr) x = setByteArray arr i (intparam(Proxy::Proxy len)) x 218 | 219 | --------------------------------------- 220 | -- variable size 221 | 222 | -- newtype instance MVector Automatic s elem = MVector_Automatic (VPM.MVector s elem) 223 | -- mkParams ''MVector 224 | -- 225 | -- instance Prim elem => VGM.MVector (MVector Automatic) elem where 226 | -- 227 | -- {-# INLINE basicLength #-} 228 | -- basicLength (MVector_Automatic v) = VGM.basicLength v 229 | -- 230 | -- {-# INLINE basicUnsafeSlice #-} 231 | -- basicUnsafeSlice i m (MVector_Automatic v) = MVector_Automatic $ VGM.basicUnsafeSlice i m v 232 | -- 233 | -- {-# INLINE basicOverlaps #-} 234 | -- basicOverlaps (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicOverlaps v1 v2 235 | -- 236 | -- {-# INLINE basicUnsafeNew #-} 237 | -- basicUnsafeNew i = MVector_Automatic `liftM` VGM.basicUnsafeNew i 238 | -- 239 | -- {-# INLINE basicUnsafeRead #-} 240 | -- basicUnsafeRead (MVector_Automatic v) i = VGM.basicUnsafeRead v i 241 | -- 242 | -- {-# INLINE basicUnsafeWrite #-} 243 | -- basicUnsafeWrite (MVector_Automatic v) i x = VGM.basicUnsafeWrite v i x 244 | -- 245 | -- {-# INLINE basicUnsafeCopy #-} 246 | -- basicUnsafeCopy (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicUnsafeCopy v1 v2 247 | -- 248 | -- {-# INLINE basicUnsafeMove #-} 249 | -- basicUnsafeMove (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicUnsafeMove v1 v2 250 | -- 251 | -- {-# INLINE basicSet #-} 252 | -- basicSet (MVector_Automatic v) x = VGM.basicSet v x 253 | 254 | 255 | -------------------------------------------------------------------------------- /src/Data/Params/Vector/Unboxed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE UnboxedTuples #-} 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | module Data.Params.Vector.Unboxed 8 | ( Vector 9 | , module Data.Params.Vector 10 | ) 11 | where 12 | 13 | import Control.Category 14 | import Prelude hiding ((.),id) 15 | 16 | import Control.Monad 17 | import Control.Monad.Primitive 18 | import Control.DeepSeq 19 | import Data.Primitive 20 | import Data.Primitive.ByteArray 21 | -- import Data.Primitive.Types 22 | -- import GHC.Ptr 23 | -- import Foreign.Ptr 24 | -- import Foreign.ForeignPtr hiding (unsafeForeignPtrToPtr) 25 | -- import Foreign.ForeignPtr.Unsafe 26 | -- import Foreign.Marshal.Array 27 | import qualified Data.Vector.Generic as VG 28 | import qualified Data.Vector.Generic.Mutable as VGM 29 | import qualified Data.Vector.Unboxed as VU 30 | import qualified Data.Vector.Unboxed.Mutable as VUM 31 | import qualified Data.Vector.Primitive as VP 32 | import qualified Data.Vector.Primitive.Mutable as VPM 33 | 34 | import GHC.Base (Int (..)) 35 | import GHC.Int 36 | import GHC.Prim 37 | import GHC.TypeLits 38 | 39 | import Data.Params 40 | import Data.Params.Vector 41 | import Data.Params.PseudoPrim 42 | 43 | import Debug.Trace 44 | 45 | 46 | ------------------------------------------------------------------------------- 47 | -- immutable automatically sized vector 48 | 49 | data family Vector (len::Config Nat) elem 50 | mkParams ''Vector 51 | 52 | instance (Show elem, VG.Vector (Vector len) elem) => Show (Vector len elem) where 53 | show v = "fromList "++show (VG.toList v) 54 | 55 | instance (Eq elem, VG.Vector (Vector len) elem) => Eq (Vector len elem) where 56 | a == b = (VG.toList a) == (VG.toList b) 57 | 58 | instance (Ord elem, VG.Vector (Vector len) elem) => Ord (Vector len elem) where 59 | compare a b = compare (VG.toList a) (VG.toList b) 60 | 61 | --------------------------------------- 62 | -- Static size 63 | 64 | data instance Vector (Static len) elem = Vector 65 | {-#UNPACK#-}!Int 66 | {-#UNPACK#-}!(PseudoPrimInfo elem) 67 | {-#UNPACK#-}!ByteArray 68 | 69 | instance 70 | ( KnownNat len 71 | , PseudoPrim elem 72 | ) => StaticToAutomatic 73 | Param_len 74 | (Vector (Static len) elem) 75 | (Vector Automatic elem) 76 | where 77 | 78 | staticToAutomatic _ (Vector off ppi arr) = Vector_Automatic off len ppi arr 79 | where 80 | len = fromIntegral $ natVal (Proxy::Proxy len) 81 | 82 | mkPseudoPrimInfoFromStatic _ (PseudoPrimInfo_VectorStatic ppi) 83 | = PseudoPrimInfo_VectorAutomatic len (len*size) ppi 84 | where 85 | len = fromIntegral $ natVal (Proxy::Proxy len) 86 | size = pp_sizeOf ppi 87 | 88 | instance 89 | ( KnownNat len 90 | , StaticToAutomatic p elem elem' 91 | ) => StaticToAutomatic 92 | (Param_elem p) 93 | (Vector (Static len) elem) 94 | (Vector (Static len) elem') 95 | where 96 | 97 | staticToAutomatic _ (Vector off ppi arr) = Vector off ppi' arr 98 | where 99 | ppi' = mkPseudoPrimInfoFromStatic (TypeLens::TypeLens Base p) ppi 100 | 101 | mkPseudoPrimInfoFromStatic _ (PseudoPrimInfo_VectorStatic ppi) 102 | = PseudoPrimInfo_VectorStatic $ mkPseudoPrimInfoFromStatic (TypeLens :: TypeLens Base p) ppi 103 | 104 | instance 105 | ( PseudoPrim elem 106 | ) => RunTimeToAutomatic 107 | Param_len 108 | (Vector RunTime elem) 109 | (Vector Automatic elem) 110 | where 111 | 112 | runTimeToAutomatic lens p v = mkApWith1Param 113 | (Proxy::Proxy (Vector RunTime elem)) 114 | (Proxy::Proxy (Vector Automatic elem)) 115 | lens 116 | p 117 | go 118 | v 119 | where 120 | go v@(Vector_RunTime off ppi arr) = Vector_Automatic off len ppi arr 121 | where 122 | len = VG.length v 123 | 124 | mkPseudoPrimInfoFromRuntime _ len (PseudoPrimInfo_VectorRunTime ppi) 125 | = PseudoPrimInfo_VectorAutomatic len (len*pp_sizeOf ppi) ppi 126 | 127 | instance 128 | ( RunTimeToAutomatic p elem elem' 129 | , HasDictionary p 130 | , ReifiableConstraint (ApplyConstraint_GetConstraint p) 131 | ) => RunTimeToAutomatic 132 | (Param_elem p) 133 | (Vector (Static len) elem) 134 | (Vector (Static len) elem') 135 | where 136 | 137 | runTimeToAutomatic lens p v = mkApWith1Param 138 | (Proxy::Proxy (Vector (Static len) elem)) 139 | (Proxy::Proxy (Vector (Static len) elem')) 140 | lens 141 | p 142 | go 143 | v 144 | where 145 | go :: Vector (Static len) elem -> Vector (Static len) elem' 146 | go (Vector off ppi arr) = Vector off ppi' arr 147 | where 148 | ppi' = mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi 149 | :: PseudoPrimInfo elem' 150 | 151 | mkPseudoPrimInfoFromRuntime _ p (PseudoPrimInfo_VectorStatic ppi) 152 | = PseudoPrimInfo_VectorStatic $ mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi 153 | 154 | instance 155 | ( RunTimeToAutomatic p elem elem' 156 | , HasDictionary p 157 | , ReifiableConstraint (ApplyConstraint_GetConstraint p) 158 | ) => RunTimeToAutomatic 159 | (Param_elem p) 160 | (Vector RunTime elem) 161 | (Vector RunTime elem') 162 | where 163 | 164 | runTimeToAutomatic lens p v = mkApWith1Param 165 | (Proxy::Proxy (Vector RunTime elem)) 166 | (Proxy::Proxy (Vector RunTime elem')) 167 | lens 168 | p 169 | go 170 | v 171 | where 172 | go :: Vector RunTime elem -> Vector RunTime elem' 173 | go (Vector_RunTime off ppi arr) = Vector_RunTime off ppi' arr 174 | where 175 | ppi' = mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi 176 | :: PseudoPrimInfo elem' 177 | 178 | mkPseudoPrimInfoFromRuntime _ p (PseudoPrimInfo_VectorRunTime ppi) 179 | = PseudoPrimInfo_VectorRunTime $ mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi 180 | 181 | instance 182 | ( RunTimeToAutomatic p elem elem' 183 | , HasDictionary p 184 | , ReifiableConstraint (ApplyConstraint_GetConstraint p) 185 | ) => RunTimeToAutomatic 186 | (Param_elem p) 187 | (Vector Automatic elem) 188 | (Vector Automatic elem') 189 | where 190 | 191 | runTimeToAutomatic lens p v = mkApWith1Param 192 | (Proxy::Proxy (Vector Automatic elem)) 193 | (Proxy::Proxy (Vector Automatic elem')) 194 | lens 195 | p 196 | go 197 | v 198 | where 199 | go :: Vector Automatic elem -> Vector Automatic elem' 200 | go (Vector_Automatic len off ppi arr) = Vector_Automatic len off ppi' arr 201 | where 202 | ppi' = mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi 203 | :: PseudoPrimInfo elem' 204 | 205 | mkPseudoPrimInfoFromRuntime _ p (PseudoPrimInfo_VectorAutomatic len size ppi) 206 | = PseudoPrimInfo_VectorAutomatic 207 | len 208 | size 209 | (mkPseudoPrimInfoFromRuntime (TypeLens::TypeLens Base p) p ppi) 210 | 211 | ------------------- 212 | 213 | instance NFData (Vector (Static len) elem) where 214 | rnf a = seq a () 215 | 216 | instance 217 | ( PseudoPrim elem 218 | , KnownNat len 219 | ) => VG.Vector (Vector (Static len)) elem 220 | where 221 | 222 | {-# INLINE basicUnsafeFreeze #-} 223 | basicUnsafeFreeze (MVector i ppi marr) = Vector i ppi `liftM` unsafeFreezeByteArray marr 224 | 225 | {-# INLINE basicUnsafeThaw #-} 226 | basicUnsafeThaw (Vector i ppi arr) = MVector i ppi `liftM` unsafeThawByteArray arr 227 | 228 | {-# INLINE [2] basicLength #-} 229 | basicLength _ = viewParam _len (undefined::Vector (Static len) elem) 230 | 231 | {-# INLINE basicUnsafeSlice #-} 232 | basicUnsafeSlice j n v = if n /= viewParam _len (undefined::Vector (Static len) elem) || j /= 0 233 | then error $ "Vector.basicUnsafeSlice not allowed to change size" 234 | else v 235 | 236 | {-# INLINE basicUnsafeIndexM #-} 237 | basicUnsafeIndexM (Vector i ppi arr) j = return $! pp_indexByteArray ppi arr (i+j) 238 | 239 | -- {-# INLINE basicUnsafeCopy #-} 240 | -- basicUnsafeCopy (MVector i ppi1 dst) (Vector j ppi2src) = 241 | -- copyByteArray dst (i*sz) src (j*sz) (len*sz) 242 | -- where 243 | -- sz = pp_sizeOf (undefined :: elem) 244 | -- len = getParam_len (undefined::Vector (Static len) elem) 245 | 246 | {-# INLINE elemseq #-} 247 | elemseq _ = seq 248 | 249 | ------------------- 250 | -- primitive instance allows unboxing unboxed vectors 251 | 252 | unInt :: Int -> Int# 253 | unInt (I# i) = i 254 | 255 | instance 256 | ( Prim elem 257 | , PseudoPrim elem 258 | , KnownNat len 259 | ) => Prim (Vector (Static len) elem) 260 | where 261 | 262 | {-# INLINE sizeOf# #-} 263 | sizeOf# _ = 264 | unInt (sizeOf (undefined::elem)* (intparam (Proxy::Proxy len))) 265 | 266 | {-# INLINE alignment# #-} 267 | alignment# _ = 268 | unInt (alignment (undefined :: elem)) 269 | -- unInt (sizeOf ppi * (intparam (Proxy::Proxy len))) 270 | 271 | {-# INLINE indexByteArray# #-} 272 | indexByteArray# arr# i# = 273 | Vector ((I# i#)*(intparam (Proxy::Proxy len))) (emptyInfo::PseudoPrimInfo elem) (ByteArray arr#) 274 | 275 | {-# INLINE readByteArray# #-} 276 | readByteArray# marr# i# s# = 277 | (# s#, Vector (I# i#) (emptyInfo::PseudoPrimInfo elem) (ByteArray (unsafeCoerce# marr#)) #) 278 | 279 | {-# INLINE writeByteArray# #-} 280 | writeByteArray# marr# i# x s# = go 0 s# 281 | where 282 | go i s = ( if i >= intparam (Proxy::Proxy len) 283 | then s 284 | else go (i+1) 285 | (writeByteArray# marr# 286 | (i# *# (unInt ( intparam (Proxy::Proxy len))) +# (unInt i)) 287 | -- (x VG.! i) 288 | (x `VG.unsafeIndex` i) 289 | s 290 | ) 291 | ) 292 | where 293 | iii = I# (i# *# (sizeOf# (undefined::elem)) +# (unInt i)) 294 | 295 | instance 296 | ( PseudoPrim elem 297 | , KnownNat len 298 | , Show elem 299 | ) => PseudoPrim (Vector (Static len) elem) 300 | where 301 | 302 | newtype PseudoPrimInfo (Vector (Static len) elem) = 303 | PseudoPrimInfo_VectorStatic (PseudoPrimInfo elem) 304 | 305 | {-# INLINE pp_sizeOf# #-} 306 | pp_sizeOf# (PseudoPrimInfo_VectorStatic ppi) = 307 | unInt (pp_sizeOf ppi * (intparam (Proxy::Proxy len))) 308 | 309 | {-# INLINE pp_alignment# #-} 310 | pp_alignment# (PseudoPrimInfo_VectorStatic ppi) = 311 | unInt (pp_alignment ppi) 312 | -- unInt (pp_sizeOf ppi * (intparam (Proxy::Proxy len))) 313 | 314 | {-# INLINE pp_indexByteArray# #-} 315 | pp_indexByteArray# (PseudoPrimInfo_VectorStatic ppi) arr# i# = 316 | Vector ((I# i#)*(intparam (Proxy::Proxy len))) ppi (ByteArray arr#) 317 | 318 | {-# INLINE pp_readByteArray# #-} 319 | pp_readByteArray# (PseudoPrimInfo_VectorStatic ppi) marr# i# s# = 320 | (# s#, Vector (I# i#) ppi (ByteArray (unsafeCoerce# marr#)) #) 321 | 322 | {-# INLINE pp_writeByteArray# #-} 323 | pp_writeByteArray# (PseudoPrimInfo_VectorStatic ppi) marr# i# x s# = go 0 s# 324 | where 325 | go i s = ( if i >= intparam (Proxy::Proxy len) 326 | then s 327 | else go (i+1) 328 | (pp_writeByteArray# ppi marr# 329 | (i# *# (unInt ( intparam (Proxy::Proxy len))) +# (unInt i)) 330 | -- (x VG.! i) 331 | (x `VG.unsafeIndex` i) 332 | s 333 | ) 334 | ) 335 | where 336 | iii = I# (i# *# (pp_sizeOf# ppi) +# (unInt i)) 337 | 338 | {-# INLINE seqInfo #-} 339 | seqInfo _ = seqInfo (undefined::elem) 340 | 341 | {-# INLINE emptyInfo #-} 342 | emptyInfo = PseudoPrimInfo_VectorStatic emptyInfo 343 | 344 | ---------------------------------------- 345 | -- RunTime size 346 | 347 | data instance Vector RunTime elem = Vector_RunTime 348 | {-#UNPACK#-}!Int 349 | {-#UNPACK#-}!(PseudoPrimInfo elem) 350 | {-#UNPACK#-}!ByteArray 351 | 352 | instance NFData (Vector RunTime elem) where 353 | rnf a = seq a () 354 | 355 | 356 | instance 357 | ( PseudoPrim elem 358 | -- , GetParam_len (Vector RunTime elem) 359 | -- , ViewParam GetParam_len (Vector RunTime elem) 360 | , ViewParam Param_len (Vector RunTime elem) 361 | ) => VG.Vector (Vector RunTime) elem 362 | where 363 | 364 | {-# INLINE basicUnsafeFreeze #-} 365 | -- basicUnsafeFreeze (MVector_RunTime len i marr) = if len==getParam_len (undefined::Vector RunTime elem) 366 | basicUnsafeFreeze (MVector_RunTime len i ppi marr) = 367 | if len == viewParam _len (undefined::Vector RunTime elem) 368 | then Vector_RunTime i ppi `liftM` unsafeFreezeByteArray marr 369 | else error $ "basicUnsafeFreeze cannot change RunTime vector size" 370 | ++ "; len="++show len 371 | ++ "; getParam_len="++show (viewParam _len (undefined::Vector RunTime elem)) 372 | 373 | {-# INLINE basicUnsafeThaw #-} 374 | basicUnsafeThaw (Vector_RunTime i ppi arr) = 375 | MVector_RunTime (viewParam _len (undefined::Vector RunTime elem)) i ppi `liftM` unsafeThawByteArray arr 376 | -- MVector_RunTime (getParam_len (undefined::Vector RunTime elem)) i `liftM` unsafeThawByteArray arr 377 | 378 | {-# INLINE [2] basicLength #-} 379 | basicLength _ = viewParam _len (undefined::Vector RunTime elem) 380 | -- basicLength _ = getParam_len (undefined::Vector RunTime elem) 381 | 382 | {-# INLINE basicUnsafeSlice #-} 383 | -- basicUnsafeSlice j n v = if n /= getParam_len (undefined::Vector RunTime elem) || j /= 0 384 | basicUnsafeSlice j n v = 385 | if n /= viewParam _len (undefined::Vector RunTime elem) || j /= 0 386 | then error $ "Vector_RunTime.basicUnsafeSlice not allowed to change size" 387 | else v 388 | 389 | {-# INLINE basicUnsafeIndexM #-} 390 | basicUnsafeIndexM (Vector_RunTime i ppi arr) j = return $! pp_indexByteArray ppi arr (i+j) 391 | 392 | -- {-# INLINE basicUnsafeCopy #-} 393 | -- basicUnsafeCopy (MVector_RunTime n i dst) (Vector_RunTime j src) = if n==len 394 | -- then copyByteArray dst (i*sz) src (j*sz) (len*sz) 395 | -- else error "basicUnsafeCopy cannot change RunTime vector size" 396 | -- where 397 | -- sz = pp_sizeOf (undefined :: elem) 398 | -- -- len = getParam_len (undefined::Vector RunTime elem) 399 | -- len = viewParam _len (undefined::Vector RunTime elem) 400 | 401 | {-# INLINE elemseq #-} 402 | elemseq _ = seq 403 | 404 | ------------------- 405 | 406 | instance 407 | ( PseudoPrim elem 408 | -- , GetParam_len (Vector RunTime elem) 409 | , ViewParam Param_len (Vector RunTime elem) 410 | ) => PseudoPrim (Vector RunTime elem) 411 | where 412 | 413 | newtype PseudoPrimInfo (Vector RunTime elem) = 414 | PseudoPrimInfo_VectorRunTime (PseudoPrimInfo elem) 415 | 416 | {-# INLINE pp_sizeOf# #-} 417 | pp_sizeOf# (PseudoPrimInfo_VectorRunTime ppi) = 418 | -- unInt (pp_sizeOf ppi * (getParam_len (undefined::Vector RunTime elem))) 419 | unInt (pp_sizeOf ppi * (viewParam _len (undefined::Vector RunTime elem))) 420 | 421 | {-# INLINE pp_alignment# #-} 422 | pp_alignment# (PseudoPrimInfo_VectorRunTime ppi) = 423 | unInt (pp_alignment ppi) 424 | -- unInt (pp_sizeOf (undefined::elem) * (getParam_len (undefined::Vector RunTime elem))) 425 | 426 | {-# INLINE pp_indexByteArray# #-} 427 | pp_indexByteArray# (PseudoPrimInfo_VectorRunTime ppi)arr# i# = 428 | -- Vector_RunTime ((I# i#)*(getParam_len (undefined::Vector RunTime elem))) ppi (ByteArray arr#) 429 | Vector_RunTime ((I# i#)*(viewParam _len (undefined::Vector RunTime elem))) ppi (ByteArray arr#) 430 | 431 | {-# INLINE pp_readByteArray# #-} 432 | pp_readByteArray# (PseudoPrimInfo_VectorRunTime ppi) marr# i# s# = 433 | (# s#, Vector_RunTime (I# i#) ppi (ByteArray (unsafeCoerce# marr#)) #) 434 | 435 | {-# INLINE pp_writeByteArray# #-} 436 | pp_writeByteArray# (PseudoPrimInfo_VectorRunTime ppi) marr# i# x s# = go 0 s# 437 | where 438 | go i s = ( if i >= len 439 | then s 440 | else go (i+1) 441 | (pp_writeByteArray# ppi marr# 442 | (i# *# (unInt len) +# (unInt i)) 443 | (x VG.! i) 444 | s 445 | ) 446 | ) 447 | where 448 | len = viewParam _len (undefined::Vector RunTime elem) 449 | -- len = getParam_len (undefined::Vector RunTime elem) 450 | iii = I# (i# *# (pp_sizeOf# ppi) +# (unInt i)) 451 | 452 | {-# INLINE seqInfo #-} 453 | seqInfo _ = seqInfo (undefined::elem) 454 | 455 | {-# INLINE emptyInfo #-} 456 | emptyInfo = PseudoPrimInfo_VectorRunTime emptyInfo 457 | 458 | --------------------------------------- 459 | -- Automatic sized 460 | 461 | data instance Vector Automatic elem = Vector_Automatic 462 | {-#UNPACK#-}!Int 463 | {-#UNPACK#-}!Int 464 | {-#UNPACK#-}!(PseudoPrimInfo elem) 465 | {-#UNPACK#-}!ByteArray 466 | 467 | instance NFData (Vector Automatic elem) where 468 | rnf v = seq v () 469 | 470 | instance PseudoPrim elem => VG.Vector (Vector Automatic) elem where 471 | 472 | {-# INLINE basicUnsafeFreeze #-} 473 | basicUnsafeFreeze (MVector_Automatic i n ppi marr) 474 | = Vector_Automatic i n ppi `liftM` unsafeFreezeByteArray marr 475 | 476 | {-# INLINE basicUnsafeThaw #-} 477 | basicUnsafeThaw (Vector_Automatic i n ppi arr) 478 | = MVector_Automatic i n ppi `liftM` unsafeThawByteArray arr 479 | 480 | {-# INLINE basicLength #-} 481 | basicLength (Vector_Automatic _ n _ _) = n 482 | 483 | {-# INLINE basicUnsafeSlice #-} 484 | basicUnsafeSlice j n (Vector_Automatic i _ ppi arr) = Vector_Automatic (i+j) n ppi arr 485 | 486 | {-# INLINE basicUnsafeIndexM #-} 487 | basicUnsafeIndexM (Vector_Automatic i _ ppi arr) j = return $! pp_indexByteArray ppi arr (i+j) 488 | 489 | -- {-# INLINE basicUnsafeCopy #-} 490 | -- basicUnsafeCopy (MVector_Automatic i n dst) (Vector_Automatic j _ src) 491 | -- = copyByteArray dst (i*sz) src (j*sz) (n*sz) 492 | -- where 493 | -- sz = sizeOf (indefinido :: a) 494 | 495 | {-# INLINE elemseq #-} 496 | elemseq _ = seq 497 | 498 | instance PseudoPrim elem => PseudoPrim (Vector Automatic elem) where 499 | data PseudoPrimInfo (Vector Automatic elem) = PseudoPrimInfo_VectorAutomatic 500 | {-#UNPACK#-}!(Int) -- length 501 | {-#UNPACK#-}!(Int) -- sizeOf 502 | {-#UNPACK#-}!(PseudoPrimInfo elem) 503 | 504 | {-# INLINE pp_sizeOf# #-} 505 | pp_sizeOf# (PseudoPrimInfo_VectorAutomatic _ s _) = unInt s 506 | 507 | {-# INLINE pp_alignment# #-} 508 | pp_alignment# (PseudoPrimInfo_VectorAutomatic _ _ ppi) = 509 | unInt (pp_alignment ppi) 510 | 511 | {-# INLINE pp_indexByteArray# #-} 512 | pp_indexByteArray# (PseudoPrimInfo_VectorAutomatic len _ ppi) arr# i# = 513 | Vector_Automatic ((I# i#)*len) len ppi (ByteArray arr#) 514 | 515 | {-# INLINE pp_readByteArray# #-} 516 | pp_readByteArray# (PseudoPrimInfo_VectorAutomatic len _ ppi) marr# i# s# = 517 | (# s#, Vector_Automatic (I# i#) len ppi (ByteArray (unsafeCoerce# marr#)) #) 518 | 519 | {-# INLINE pp_writeByteArray# #-} 520 | pp_writeByteArray# (PseudoPrimInfo_VectorAutomatic len _ ppi) marr# i# x s# = go 0 s# 521 | where 522 | go i s = ( if i >= len 523 | then s 524 | else go (i+1) 525 | (pp_writeByteArray# ppi marr# 526 | (i# *# (unInt len) +# (unInt i)) 527 | (x VG.! i) 528 | s 529 | ) 530 | ) 531 | where 532 | iii = I# (i# *# (pp_sizeOf# ppi) +# (unInt i)) 533 | 534 | {-# INLINE seqInfo #-} 535 | seqInfo _ = False 536 | 537 | {-# INLINE emptyInfo #-} 538 | emptyInfo = error "emptyInfo of PseudoPrimInfo_VectorAutomatic" 539 | 540 | 541 | ------------------------------------------------------------------------------- 542 | -- mutable vector 543 | 544 | data family MVector (len::Config Nat) s elem 545 | 546 | type instance VG.Mutable (Vector len) = MVector len 547 | 548 | --------------------------------------- 549 | -- static size 550 | 551 | data instance MVector (Static len) s elem = MVector 552 | {-#UNPACK#-}!Int 553 | {-#UNPACK#-}!(PseudoPrimInfo elem) 554 | {-#UNPACK#-}!(MutableByteArray s) 555 | 556 | instance 557 | ( PseudoPrim elem 558 | , KnownNat len 559 | ) => VGM.MVector (MVector (Static len)) elem 560 | where 561 | 562 | {-# INLINE basicLength #-} 563 | basicLength _ = fromIntegral $ natVal (Proxy::Proxy len) 564 | 565 | {-# INLINE basicUnsafeSlice #-} 566 | basicUnsafeSlice i m v = if m /= len 567 | then error $ "MVector (Static len) .basicUnsafeSlice not allowed to change size" 568 | ++"; i="++show i 569 | ++"; m="++show m 570 | ++"; len="++show len 571 | else v 572 | where 573 | -- len = getParam_len (undefined::MVector (Static len) s elem) 574 | len = intparam (Proxy::Proxy len) 575 | 576 | {-# INLINE basicOverlaps #-} 577 | basicOverlaps (MVector i ppi1 arr1) (MVector j ppi2 arr2) 578 | = sameMutableByteArray arr1 arr2 579 | && (between i j (j+len) || between j i (i+len)) 580 | where 581 | len = intparam (Proxy::Proxy len) 582 | between x y z = x >= y && x < z 583 | 584 | {-# INLINE basicUnsafeNew #-} 585 | basicUnsafeNew n = if seqInfo (undefined::elem) 586 | then error "basicUnsafeNew: seqInfo" 587 | else do 588 | arr <- newPinnedByteArray (len * pp_sizeOf (emptyInfo :: PseudoPrimInfo elem)) 589 | return $ MVector 0 (emptyInfo::PseudoPrimInfo elem) arr 590 | where 591 | len = intparam (Proxy::Proxy len) 592 | 593 | {-# INLINE basicUnsafeRead #-} 594 | basicUnsafeRead (MVector i ppi arr) j = pp_readByteArray ppi arr (i+j) 595 | 596 | {-# INLINE basicUnsafeWrite #-} 597 | basicUnsafeWrite (MVector i ppi arr) j x = pp_writeByteArray ppi arr (i+j) x 598 | 599 | -- {-# INLINE basicUnsafeCopy #-} 600 | -- basicUnsafeCopy (MVector i ppi dst) (MVector j ppi src) = 601 | -- copyMutableByteArray ppi dst (i*sz) src (j*sz) (len*sz) 602 | -- where 603 | -- sz = pp_sizeOf (undefined :: elem) 604 | -- len = intparam (Proxy::Proxy len) 605 | -- 606 | -- {-# INLINE basicUnsafeMove #-} 607 | -- basicUnsafeMove (MVector i dst) (MVector j src) = moveByteArray dst (i*sz) src (j*sz) (len * sz) 608 | -- where 609 | -- sz = pp_sizeOf (undefined :: elem) 610 | -- len = intparam (Proxy::Proxy len) 611 | -- 612 | -- {-# INLINE basicSet #-} 613 | -- basicSet (MVector i arr) x = setByteArray arr i (intparam(Proxy::Proxy len)) x 614 | 615 | 616 | --------------------------------------- 617 | -- RunTime size 618 | 619 | data instance MVector RunTime s elem = MVector_RunTime 620 | {-#UNPACK#-}!Int 621 | {-#UNPACK#-}!Int 622 | {-#UNPACK#-}!(PseudoPrimInfo elem) 623 | {-#UNPACK#-}!(MutableByteArray s) 624 | 625 | instance 626 | ( PseudoPrim elem 627 | ) => VGM.MVector (MVector RunTime) elem 628 | where 629 | 630 | {-# INLINE basicLength #-} 631 | basicLength (MVector_RunTime n _ ppi _) = n 632 | 633 | {-# INLINE basicUnsafeSlice #-} 634 | basicUnsafeSlice i m (MVector_RunTime n j ppi v) = MVector_RunTime m (i+j) ppi v 635 | -- basicUnsafeSlice i m v = if m /= len 636 | -- then error $ "MVector.basicUnsafeSlice not allowed to change size" 637 | -- ++"; i="++show i 638 | -- ++"; m="++show m 639 | -- ++"; len="++show len 640 | -- else v 641 | -- where 642 | -- len = VGM.length v 643 | 644 | {-# INLINE basicOverlaps #-} 645 | basicOverlaps (MVector_RunTime m i ppi1 arr1) (MVector_RunTime n j ppi2 arr2) 646 | = sameMutableByteArray arr1 arr2 647 | && (between i j (j+m) || between j i (i+n)) 648 | where 649 | between x y z = x >= y && x < z 650 | 651 | {-# INLINE basicUnsafeNew #-} 652 | basicUnsafeNew n = if seqInfo (undefined::elem) 653 | then error "basicUnsafeNew: seqInfo" 654 | else do 655 | arr <- newPinnedByteArray (n * pp_sizeOf (emptyInfo :: PseudoPrimInfo elem)) 656 | return $ MVector_RunTime n 0 emptyInfo arr 657 | 658 | {-# INLINE basicUnsafeRead #-} 659 | basicUnsafeRead (MVector_RunTime _ i ppi arr) j = pp_readByteArray ppi arr (i+j) 660 | 661 | {-# INLINE basicUnsafeWrite #-} 662 | basicUnsafeWrite (MVector_RunTime _ i ppi arr) j x = pp_writeByteArray ppi arr (i+j) x 663 | 664 | 665 | -- {-# INLINE basicUnsafeCopy #-} 666 | -- basicUnsafeCopy (MVector_RunTime n i dst) (MVector_RunTime m j src) 667 | -- = if n==m 668 | -- then copyMutableByteArray dst (i*sz) src (j*sz) (n*sz) 669 | -- else error "basicUnsafeCopy cannot change size of RunTime MVector" 670 | -- where 671 | -- sz = pp_sizeOf (undefined :: elem) 672 | -- 673 | -- {-# INLINE basicUnsafeMove #-} 674 | -- basicUnsafeMove (MVector_RunTime n i dst) (MVector_RunTime m j src) 675 | -- = if n==m 676 | -- then moveByteArray dst (i*sz) src (j*sz) (n * sz) 677 | -- else error "basicUnsafeMove cannot change size of RunTime MVector" 678 | -- where 679 | -- sz = pp_sizeOf (undefined :: elem) 680 | -- 681 | -- {-# INLINE basicSet #-} 682 | -- basicSet (MVector_RunTime n i arr) x = setByteArray arr i n x 683 | 684 | 685 | --------------------------------------- 686 | -- Automatic size 687 | 688 | data instance MVector Automatic s elem = MVector_Automatic 689 | {-#UNPACK#-}!Int 690 | {-#UNPACK#-}!Int 691 | {-#UNPACK#-}!(PseudoPrimInfo elem) 692 | {-#UNPACK#-}!(MutableByteArray s) 693 | 694 | instance 695 | ( PseudoPrim elem 696 | ) => VGM.MVector (MVector Automatic) elem 697 | where 698 | 699 | {-# INLINE basicLength #-} 700 | basicLength (MVector_Automatic _ n ppi _) = n 701 | 702 | {-# INLINE basicUnsafeSlice #-} 703 | basicUnsafeSlice i m (MVector_Automatic j n ppi v) = MVector_Automatic (i+j) m ppi v 704 | -- basicUnsafeSlice i m v = if m /= len 705 | -- then error $ "MVector.basicUnsafeSlice not allowed to change size" 706 | -- ++"; i="++show i 707 | -- ++"; m="++show m 708 | -- ++"; len="++show len 709 | -- else v 710 | -- where 711 | -- len = VGM.length v 712 | 713 | {-# INLINE basicOverlaps #-} 714 | basicOverlaps (MVector_Automatic i m ppi1 arr1) (MVector_Automatic j n ppi2 arr2) 715 | = sameMutableByteArray arr1 arr2 716 | && (between i j (j+m) || between j i (i+n)) 717 | where 718 | between x y z = x >= y && x < z 719 | 720 | {-# INLINE basicUnsafeNew #-} 721 | basicUnsafeNew n = if seqInfo (undefined::elem) 722 | then error "basicUnsafeNew: seqInfo" 723 | else do 724 | arr <- newPinnedByteArray (n * pp_sizeOf (emptyInfo :: PseudoPrimInfo elem)) 725 | return $ MVector_Automatic 0 n emptyInfo arr 726 | 727 | {-# INLINE basicUnsafeRead #-} 728 | basicUnsafeRead (MVector_Automatic i _ ppi arr) j = pp_readByteArray ppi arr (i+j) 729 | 730 | {-# INLINE basicUnsafeWrite #-} 731 | basicUnsafeWrite (MVector_Automatic i _ ppi arr) j x = pp_writeByteArray ppi arr (i+j) x 732 | 733 | 734 | -- {-# INLINE basicUnsafeCopy #-} 735 | -- basicUnsafeCopy (MVector_Automatic i n dst) (MVector_Automatic j m src) 736 | -- = if n==m 737 | -- then copyMutableByteArray dst (i*sz) src (j*sz) (n*sz) 738 | -- else error "basicUnsafeCopy cannot change size of Automatic MVector" 739 | -- where 740 | -- sz = pp_sizeOf (undefined :: elem) 741 | -- 742 | -- {-# INLINE basicUnsafeMove #-} 743 | -- basicUnsafeMove (MVector_Automatic i n dst) (MVector_Automatic j m src) 744 | -- = if n==m 745 | -- then moveByteArray dst (i*sz) src (j*sz) (n * sz) 746 | -- else error "basicUnsafeMove cannot change size of Automatic MVector" 747 | -- where 748 | -- sz = pp_sizeOf (undefined :: elem) 749 | -- 750 | -- {-# INLINE basicSet #-} 751 | -- basicSet (MVector_Automatic i n arr) x = setByteArray arr i n x 752 | -------------------------------------------------------------------------------- /src/Data/Params/Vector/UnboxedRaw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE UnboxedTuples #-} 5 | 6 | -- | An UnboxedRaw vector is just like the Unboxed vector, except that we no 7 | -- longer store an offset to our position in the fixed size version. 8 | -- This gives us a very thin wrapping around 'ByteArray's that is extremely 9 | -- fast. 10 | -- The only disadvantage is that we cannot make vectors of vectors of 11 | -- UnboxedRaw vectors. 12 | -- If you don't need that capability, you should use this module. 13 | 14 | module Data.Params.Vector.UnboxedRaw 15 | where 16 | 17 | import Control.Monad 18 | import Control.Monad.Primitive 19 | import Control.DeepSeq 20 | import Data.Primitive 21 | import Data.Primitive.ByteArray 22 | import Data.Primitive.Types 23 | -- import GHC.Ptr 24 | -- import Foreign.Ptr 25 | -- import Foreign.ForeignPtr hiding (unsafeForeignPtrToPtr) 26 | -- import Foreign.ForeignPtr.Unsafe 27 | -- import Foreign.Marshal.Array 28 | import qualified Data.Vector.Generic as VG 29 | import qualified Data.Vector.Generic.Mutable as VGM 30 | import qualified Data.Vector.Unboxed as VU 31 | import qualified Data.Vector.Unboxed.Mutable as VUM 32 | import qualified Data.Vector.Primitive as VP 33 | import qualified Data.Vector.Primitive.Mutable as VPM 34 | 35 | import GHC.Base (Int (..)) 36 | import GHC.Int 37 | import GHC.Prim 38 | import GHC.TypeLits 39 | import Data.Params 40 | import Data.Params.Vector 41 | 42 | ------------------------------------------------------------------------------- 43 | -- immutable automatically sized vector 44 | 45 | data family Vector (len::Config Nat) elem 46 | 47 | instance (Show elem, VG.Vector (Vector len) elem) => Show (Vector len elem) where 48 | show v = "fromList "++show (VG.toList v) 49 | 50 | instance (Eq elem, VG.Vector (Vector len) elem) => Eq (Vector len elem) where 51 | a == b = (VG.toList a) == (VG.toList b) 52 | 53 | instance (Ord elem, VG.Vector (Vector len) elem) => Ord (Vector len elem) where 54 | compare a b = compare (VG.toList a) (VG.toList b) 55 | 56 | --------------------------------------- 57 | -- fixed size 58 | 59 | newtype instance Vector (Static len) elem = Vector ByteArray 60 | 61 | mkParams ''Vector 62 | 63 | 64 | instance NFData (Vector (Static len) elem) where 65 | rnf a = seq a () 66 | 67 | instance 68 | ( Prim elem 69 | , KnownNat len 70 | ) => VG.Vector (Vector (Static len)) elem 71 | where 72 | 73 | {-# INLINE basicUnsafeFreeze #-} 74 | basicUnsafeFreeze (MVector marr) = Vector `liftM` unsafeFreezeByteArray marr 75 | 76 | {-# INLINE basicUnsafeThaw #-} 77 | basicUnsafeThaw (Vector arr) = MVector `liftM` unsafeThawByteArray arr 78 | 79 | {-# INLINE [2] basicLength #-} 80 | basicLength _ = intparam (Proxy::Proxy len) 81 | 82 | {-# INLINE basicUnsafeSlice #-} 83 | basicUnsafeSlice j n v = if n /= intparam (Proxy::Proxy len) || j /= 0 84 | then error $ "Vector.basicUnsafeSlice not allowed to change size" 85 | else v 86 | 87 | {-# INLINE basicUnsafeIndexM #-} 88 | basicUnsafeIndexM (Vector arr) j = return $! indexByteArray arr j 89 | 90 | {-# INLINE basicUnsafeCopy #-} 91 | basicUnsafeCopy (MVector dst) (Vector src) = copyByteArray dst 0 src 0 (len*sz) 92 | where 93 | sz = sizeOf (undefined :: elem) 94 | len = intparam (Proxy::Proxy len) 95 | 96 | {-# INLINE elemseq #-} 97 | elemseq _ = seq 98 | 99 | --------------------------------------- 100 | -- automatically sized 101 | 102 | newtype instance Vector Automatic elem = Vector_Automatic (VP.Vector elem) 103 | 104 | instance NFData elem => NFData (Vector Automatic elem) where 105 | rnf (Vector_Automatic v) = rnf v 106 | 107 | instance Prim elem => VG.Vector (Vector Automatic) elem where 108 | {-# INLINE basicUnsafeFreeze #-} 109 | basicUnsafeFreeze (MVector_Automatic v) = Vector_Automatic `liftM` VG.basicUnsafeFreeze v 110 | 111 | {-# INLINE basicUnsafeThaw #-} 112 | basicUnsafeThaw (Vector_Automatic v) = MVector_Automatic `liftM` VG.basicUnsafeThaw v 113 | 114 | {-# INLINE basicLength #-} 115 | basicLength (Vector_Automatic v) = VG.basicLength v 116 | 117 | {-# INLINE basicUnsafeSlice #-} 118 | basicUnsafeSlice i m (Vector_Automatic v) = Vector_Automatic $ VG.basicUnsafeSlice i m v 119 | 120 | {-# INLINE basicUnsafeIndexM #-} 121 | basicUnsafeIndexM (Vector_Automatic v) i = VG.basicUnsafeIndexM v i 122 | 123 | {-# INLINE basicUnsafeCopy #-} 124 | basicUnsafeCopy (MVector_Automatic mv) (Vector_Automatic v) = VG.basicUnsafeCopy mv v 125 | 126 | {-# INLINE elemseq #-} 127 | elemseq _ = seq 128 | 129 | ------------------------------------------------------------------------------- 130 | -- mutable vector 131 | 132 | type instance VG.Mutable (Vector len) = MVector len 133 | 134 | data family MVector (len::Config Nat) s elem 135 | 136 | --------------------------------------- 137 | -- fixed size 138 | 139 | newtype instance MVector (Static len) s elem = MVector (MutableByteArray s) 140 | 141 | instance 142 | ( Prim elem 143 | , KnownNat len 144 | ) => VGM.MVector (MVector (Static len)) elem 145 | where 146 | 147 | {-# INLINE basicLength #-} 148 | basicLength _ = intparam (Proxy::Proxy len) 149 | 150 | {-# INLINE basicUnsafeSlice #-} 151 | basicUnsafeSlice i m v = if m /= intparam (Proxy::Proxy len) 152 | then error $ "MVector.basicUnsafeSlice not allowed to change size; i="++show i++"; m="++show m++"; len="++show (intparam (Proxy::Proxy len)) 153 | else v 154 | 155 | {-# INLINE basicOverlaps #-} 156 | basicOverlaps (MVector arr1) (MVector arr2) 157 | = sameMutableByteArray arr1 arr2 158 | 159 | {-# INLINE basicUnsafeNew #-} 160 | basicUnsafeNew n = MVector `liftM` newPinnedByteArray (len * sizeOf (undefined :: elem)) 161 | where 162 | len = intparam (Proxy::Proxy len) 163 | 164 | {-# INLINE basicUnsafeRead #-} 165 | basicUnsafeRead (MVector arr) j = readByteArray arr j 166 | 167 | {-# INLINE basicUnsafeWrite #-} 168 | basicUnsafeWrite (MVector arr) j x = writeByteArray arr j x 169 | 170 | 171 | {-# INLINE basicUnsafeCopy #-} 172 | basicUnsafeCopy (MVector dst) (MVector src) = copyMutableByteArray dst 0 src 0 (len*sz) 173 | where 174 | sz = sizeOf (undefined :: elem) 175 | len = intparam (Proxy::Proxy len) 176 | 177 | {-# INLINE basicUnsafeMove #-} 178 | basicUnsafeMove (MVector dst) (MVector src) = moveByteArray dst 0 src 0 (len * sz) 179 | where 180 | sz = sizeOf (undefined :: elem) 181 | len = intparam (Proxy::Proxy len) 182 | 183 | {-# INLINE basicSet #-} 184 | basicSet (MVector arr) x = setByteArray arr 0 (intparam(Proxy::Proxy len)) x 185 | 186 | --------------------------------------- 187 | -- variable size 188 | 189 | newtype instance MVector Automatic s elem = MVector_Automatic (VPM.MVector s elem) 190 | mkParams ''MVector 191 | 192 | instance Prim elem => VGM.MVector (MVector Automatic) elem where 193 | 194 | {-# INLINE basicLength #-} 195 | basicLength (MVector_Automatic v) = VGM.basicLength v 196 | 197 | {-# INLINE basicUnsafeSlice #-} 198 | basicUnsafeSlice i m (MVector_Automatic v) = MVector_Automatic $ VGM.basicUnsafeSlice i m v 199 | 200 | {-# INLINE basicOverlaps #-} 201 | basicOverlaps (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicOverlaps v1 v2 202 | 203 | {-# INLINE basicUnsafeNew #-} 204 | basicUnsafeNew i = MVector_Automatic `liftM` VGM.basicUnsafeNew i 205 | 206 | {-# INLINE basicUnsafeRead #-} 207 | basicUnsafeRead (MVector_Automatic v) i = VGM.basicUnsafeRead v i 208 | 209 | {-# INLINE basicUnsafeWrite #-} 210 | basicUnsafeWrite (MVector_Automatic v) i x = VGM.basicUnsafeWrite v i x 211 | 212 | {-# INLINE basicUnsafeCopy #-} 213 | basicUnsafeCopy (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicUnsafeCopy v1 v2 214 | 215 | {-# INLINE basicUnsafeMove #-} 216 | basicUnsafeMove (MVector_Automatic v1) (MVector_Automatic v2) = VGM.basicUnsafeMove v1 v2 217 | 218 | {-# INLINE basicSet #-} 219 | basicSet (MVector_Automatic v) x = VGM.basicSet v x 220 | 221 | -------------------------------------------------------------------------------- /typeparams.cabal: -------------------------------------------------------------------------------- 1 | Name: typeparams 2 | Version: 0.0.6 3 | Synopsis: Lens-like interface for type level parameters; allows unboxed unboxed vectors and supercompilation 4 | Description: 5 | This library provides a lens-like interface for working with type parameters. In the code: 6 | . 7 | > data Example p1 (p2::Config Nat) (p3::Constraint) = Example 8 | . 9 | @p1@, @p2@, and @p3@ are the type parameters. 10 | . 11 | Two example uses of this library are for unboxing unboxed vectors and supercompilation-like optimizations. Please see the for a detailed description and tutorial. After reading through that, the haddock documentation will make more sense. 12 | 13 | Category: Configuration, Dependent Types, Data, Optimization 14 | License: BSD3 15 | License-file: LICENSE 16 | Author: Mike izbicki 17 | Maintainer: mike@izbicki.me 18 | Build-Type: Simple 19 | Cabal-Version: >=1.8 20 | homepage: http://github.com/mikeizbicki/typeparams/ 21 | bug-reports: http://github.com/mikeizbicki/typeparams/issues 22 | 23 | Library 24 | Build-Depends: 25 | base >= 4.7 && < 5, 26 | deepseq >= 1.3, 27 | tagged >= 0.7, 28 | reflection >= 1.3, 29 | constraints >= 0.3.4, 30 | primitive >= 0.5, 31 | template-haskell , 32 | ghc-prim , 33 | 34 | -- examples 35 | vector >= 0.10 36 | 37 | hs-source-dirs: 38 | src 39 | 40 | ghc-options: 41 | -fllvm 42 | -O2 43 | -funbox-strict-fields 44 | 45 | Exposed-modules: 46 | Data.Params 47 | Data.Params.Applicative 48 | Data.Params.Frac 49 | Data.Params.PseudoPrim 50 | Data.Params.Functor 51 | Data.Params.Monad 52 | Data.Params.Vector 53 | -- Data.Params.Vector.Storable 54 | -- Data.Params.Vector.StorableRaw 55 | Data.Params.Vector.Unboxed 56 | -- Data.Params.Vector.UnboxedRaw 57 | 58 | Extensions: 59 | FlexibleInstances 60 | FlexibleContexts 61 | MultiParamTypeClasses 62 | FunctionalDependencies 63 | UndecidableInstances 64 | ScopedTypeVariables 65 | BangPatterns 66 | TypeOperators 67 | GeneralizedNewtypeDeriving 68 | TypeFamilies 69 | StandaloneDeriving 70 | GADTs 71 | KindSignatures 72 | ConstraintKinds 73 | RankNTypes 74 | 75 | --------------------------------------------------------------------------------